Page MenuHomeFreeBSD
Files F148383585

D2355.1786565257.diff
No OneTemporary
Actions

Size
104 KB
Referenced Files
None
Subscribers
None

D2355.1786565257.diff
View Options

Index: htdocs/cgi/Gnats.pm
===================================================================
--- htdocs/cgi/Gnats.pm
+++ htdocs/cgi/Gnats.pm
@@ -1,41 +0,0 @@
-# $FreeBSD$
-package Gnats;
-
-# We probably don't have "our" in this Perl
-use vars qw/
- $gnats_root
- $query_pr
- $submission_address
- $submission_program
- $use_mail
- /;
-
-$gnats_root="/usr/local/libexec/gnats";
-$query_pr="/usr/local/bin/query-pr.web";
-$submission_address="freebsd-gnats-submit\@FreeBSD.org";
-$use_mail=1;
-
-if ($use_mail) {
- if (-e "/usr/lib/sendmail") { $submission_program = "/usr/lib/sendmail -t" };
- if (-e "/usr/sbin/sendmail") { $submission_program = "/usr/sbin/sendmail -t" };
-} else {
- if (-e "$gnats_root/queue-pr") { $submission_program = "$gnats_root/queue-pr -q" };
-}
-
-##### End site specific stuff
-
-BEGIN {
- use Exporter();
- use vars qw/$VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS/;
- $VERSION = 0.01; # Has to have two decimal places
- @ISA = qw/Exporter/;
- # Names for sets of symbols
- %EXPORT_TAGS = (
- 'standard'=>[qw/$gnats_root $query_pr $submission_address
- $submission_program/],
- );
- Exporter::export_tags('standard');
- Exporter::export_ok_tags('standard');
-}
-
-1;
Index: htdocs/cgi/GnatsPR.pm
===================================================================
--- htdocs/cgi/GnatsPR.pm
+++ htdocs/cgi/GnatsPR.pm
@@ -1,641 +0,0 @@
-#!/usr/bin/perl -Tw
-#------------------------------------------------------------------------------
-# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $FreeBSD$
-#------------------------------------------------------------------------------
-
-package GnatsPR;
-
-#use MIME::Base64; # ports/converters/p5-MIME-Base64
-#use MIME::QuotedPrint; #
-#use Convert::UU qw(uudecode uuencode); # ports/converters/p5-Convert-UU
-
-use GnatsPR::Section::Text;
-use GnatsPR::Section::Patch;
-use GnatsPR::Section::Email;
-use GnatsPR::Section::StateChange;
-use GnatsPR::Section::FieldStart;
-
-use GnatsPR::SectionIterator;
-
-use strict;
-
-require 5.006;
-
-
-#------------------------------------------------------------------------------
-# Constants
-#------------------------------------------------------------------------------
-
-use constant ENCODING_BASE64 => 1;
-use constant ENCODING_QP => 2;
-
-use constant PATCH_ANY => 0x0001;
-use constant PATCH_DIFF => 0x0002;
-use constant PATCH_UUENC => 0x0004;
-use constant PATCH_UUENC_BIN => 0x0008;
-use constant PATCH_SHAR => 0x0010;
-use constant PATCH_BASE64 => 0x0020;
-
-
-#------------------------------------------------------------------------------
-# Func: new()
-# Desc: Constructor - Parses data if provided.
-#
-# Args: [data] - Raw data (or ref. to) from query-pr (optional)
-#
-# Retn: $self
-#------------------------------------------------------------------------------
-
-sub new
-{
- my $class = shift;
- my ($data) = @_;
-
- my $self = {
- blobs_single => {}, # Raw text, single-line fields
- blobs_multi => {}, # Raw text, multi-line fields
- header => {}, # E-mail header bits
- sections => {}, # Hash of arrayrefs of sections
- fromwebform => 0, # PR came from the web form?
- numfields => 0 # Number of fields we have
- };
-
- bless $self, $class;
-
- if (defined $data) {
- ref $data
- ? $self->Parse($data)
- : $self->Parse(\$data);
- }
-
- return $self;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: Header()
-# Desc: Return a value from the header hash.
-#
-# Args: $key - Header name, case insensitive.
-#
-# Retn: $val - Value.
-#------------------------------------------------------------------------------
-
-sub Header
-{
- my $self = shift;
- my ($key) = @_;
-
- return $self->{header}->{lc $key};
-}
-
-
-#------------------------------------------------------------------------------
-# Func: FieldSingle()
-# Desc: Return a single line field value.
-#
-# Args: $key - Field name.
-#
-# Retn: $val - Value.
-#------------------------------------------------------------------------------
-
-sub FieldSingle
-{
- my $self = shift;
- my ($key) = @_;
-
- return $self->{blobs_single}->{$key};
-}
-
-
-#------------------------------------------------------------------------------
-# Func: Parse()
-# Desc: Parse a blob of text from query-pr into a structured unit for easy
-# manipulation.
-#
-# Args: \$data - Raw data from query-pr (non-ref scalar is acceptable too).
-#
-# Retn: n/a
-#------------------------------------------------------------------------------
-
-sub Parse
-{
- my $self = shift;
- my ($data) = @_;
-
- my $ismulti = 0;
- my $pastheader = 0;
-
- # GNATS ensures that > isn't allowed as the first
- # character on a line, except for field headers.
- # Any lines beginning with > will be shunted into
- # 'Unformatted'
- my @fieldblobs = split /\n>(?!\s)/m, $$data;
-
- # In the rare case the Unformatted field did
- # have some debris, be sure to assemble it back
- # into a complete section.
- while ($fieldblobs[$#fieldblobs] !~ /^Unformatted:/) {
- my $last = pop @fieldblobs;
- exists $fieldblobs[$#fieldblobs] or last;
- $fieldblobs[$#fieldblobs] .= $last;
- }
-
- foreach my $blob (@fieldblobs) {
- my $key;
-
- # Parse e-mail header; we only care about a few
- # fields, not the e-mail routing stuff.
- if (!$pastheader) {
- foreach my $line (split /\n/, $blob) {
- if ($line =~ /^(\S+):\s*(.*)$/) {
- my $val = $2;
- $key = lc $1;
-
- # Ignore multiple defs (e.g. Received: headers)
- exists $self->{header}->{$key}
- and next;
-
- $self->{header}->{$key} = $val;
- } elsif ($line =~ /^\s+(.*)$/) {
- my $val = $1;
-
- defined $key
- or next;
-
- # No field to append to
- exists $self->{header}->{$key}
- or next;
-
- $self->{header}->{$key} .= "\n$val";
- }
- }
-
- $pastheader = 1;
- next;
- }
-
- if ($blob =~ s/^([^:]+):(\n|\s*)//) {
- $key = $1;
- #$ismulti = ($2 and $2 eq "\n");
-
- # It's multi-liners from here on in
- $key eq 'Organization'
- and $ismulti = 1;
- } else {
- # Hmm...
- next;
- }
-
- # Remove leading/trailing whitespace
- $blob =~ s/^[\n\s]+//;
- $blob =~ s/[\n\s]+$//;
-
- if ($ismulti) {
- $self->{blobs_multi}->{$key} = $blob;
- } else {
- $self->{blobs_single}->{$key} = $blob;
- }
- }
-
- $self->{numfields} = scalar @fieldblobs;
-
- $self->{fromwebform} =
- $self->{header}->{'x-send-pr-version'} =~ /^www-/;
-
- $self->ParseBlobs();
-}
-
-
-#------------------------------------------------------------------------------
-# Func: ParseBlobs()
-# Desc: Parse all the raw field "blobs" into section objects.
-#
-# Args: n/a
-#
-# Retn: n/a
-#------------------------------------------------------------------------------
-
-sub ParseBlobs
-{
- my $self = shift;
-
- foreach my $field (keys %{$self->{blobs_multi}}) {
- $self->{sections}->{$field} = [];
-
- push @{$self->{sections}->{$field}},
- new GnatsPR::Section::FieldStart($field);
-
- if ($field eq 'Fix') {
- $self->ParsePatches($field, \($self->{blobs_multi}->{$field}));
- next;
- }
-
- if ($field eq 'Audit-Trail') {
- # We'll break up the Audit-Trail field by change events.
- # This is the most reliable way to split, although it's far
- # from perfect. We'll then look for e-mail responses inside
- # each chunk for further splitting later.
- #
- # Notes/Caveats:
- # - If someone happened to paste an audit trail event
- # inside another's "Why" field, it'd break this. I haven't
- # seen this yet and don't expect to.
- # - The From-To field has to come first. No reason it wouldn't
- # under normal circumstances.
- # - Pasted e-mails in the Why field will be promoted to
- # responses, although they often break the GNATS conventions
- # we (ab)use to find e-mails (e.g.: leading space on message
- # body lines), which makes this more difficult.
- my @auditevents =
- split /(?=^(?:[A-Za-z_]+)-Changed-From-To: (?:.*?)\s*$)/m,
- $self->{blobs_multi}->{$field};
-
- foreach my $evt (@auditevents) {
- my $sect = new GnatsPR::Section::StateChange;
- my $gotwhat = 0;
- my $gotsect = 0;
- while ($evt =~ s/^([A-Za-z_]+)-Changed-([A-Za-z_-]+?): (.*?)\s*\n//) {
- my ($what, $key, $val) = ($1, $2, $3);
-
- if (!$gotwhat) {
- $sect->what($what);
- $gotwhat = 1;
- }
-
- $gotsect = 1;
-
- if ($key eq 'From-To') {
- my $fromto = $val;
- if ($fromto =~ /^(.*)->(.*)$/) {
- $sect->from($1);
- $sect->to($2);
- }
- } elsif ($key eq 'When') {
- $sect->when($val);
- } elsif ($key eq 'By') {
- $sect->by($val);
- } elsif ($key eq 'Why') {
- # This is the last one; it's a multi-line
- # field (remainder of the text.)
- last;
- }
- }
-
- push @{$self->{sections}->{$field}}, $sect
- if ($gotsect);
-
- # Now look for blocks that appear to be e-mail replies
- # Note: these header fields are the only ones we allow
- # as the first header; we could feasibly back-
- # track to find the start of the block (in case
- # we're not there already), but the more headers
- # we accept the more likely this will break on
- # some unexpected content.
- my $next_email = qr/^(From|To|Cc|Subject|Date): (.*)$/m;
- my $gotwhy = 0;
-
- while ($evt =~ /$next_email/) {
- my $match_start = $-[0];
- my ($header, $body, $indented);
- my $why;
-
- $match_start > 0
- and $why = substr($evt, 0, $match_start, '');
-
- if ($gotsect) {
- # We now know where "Why" terminates
- $sect->why($why) if $sect;
- } elsif ($why) {
- # If the first block was a date block,
- # we need to use a text section for the
- # intermediate text instead.
- push @{$self->{sections}->{$field}},
- new GnatsPR::Section::Text($why)
- unless ($why =~ /^[\n\s]+$/);
- }
-
- $gotwhy = 1;
- $sect = undef;
-
- # Chop leading blank lines
- $evt =~ s/^\n+//;
-
- if ($evt =~ /^$/m) {
- # First blank line signals the end of the
- # e-mail header
- $header = substr($evt, 0, $+[0]+1, '');
-
- # Deciding where the body ends is more
- # difficult...
-
- # First, let's see if the message is
- # indented (per GNATS standards)
- $indented = ($evt =~ /^ /);
-
- # If, so, find the next blank line, which
- # signals the body end.
- if ($indented) {
- if ($evt =~ /^$/m) {
- $body = substr($evt, 0, $-[0], '');
- } else {
- $body = $evt;
- }
- $body =~ s/^ //mg; # Remove indent char
- } else {
- # Look for another e-mail block
- if ($evt =~ /$next_email/) {
- $body = substr($evt, 0, $-[0], '');
- } else {
- # Otherwise, use the whole section
- $body = $evt;
- }
- }
-
- push @{$self->{sections}->{$field}},
- new GnatsPR::Section::Email($header, $body);
- } else {
- # No end-of-header marker: no choice but to
- # dump the (possible) e-mail into the Why field
-
- if ($gotsect && $sect) {
- $sect->why($evt);
- } elsif ($evt) {
- push @{$self->{sections}->{$field}},
- new GnatsPR::Section::Text($evt);
- }
- }
- }
-
- # Check for dangling "Why" block
- if (!$gotwhy) {
- if ($gotsect && $sect) {
- $sect->why($evt);
- } elsif ($evt) {
- push @{$self->{sections}->{$field}},
- new GnatsPR::Section::Text($evt);
- }
- }
- }
-
- next;
- }
-
- # Everything else is just text
- push @{$self->{sections}->{$field}},
- new GnatsPR::Section::Text($self->{blobs_multi}->{$field});
- }
-}
-
-
-#------------------------------------------------------------------------------
-# Func: ParsePatches()
-# Desc: Parse the patches out of the given blob of text, emitting Patch and
-# Text sections as appropriate.
-#
-# Args: $field - Field to push new sections to.
-# \$text - Raw text
-#
-# Retn: n/a
-#------------------------------------------------------------------------------
-
-sub ParsePatches
-{
- my $self = shift;
- my ($field, $text) = @_;
-
- while (my $pi = $self->FindPatchStart($text)) {
- # Everything up to this fragment can be
- # promoted to a text section
- push @{$self->{sections}->{$field}},
- new GnatsPR::Section::Text(substr(
- $$text,
- 0,
- $pi->{start},
- ''
- ))
- unless $pi->{start} == 0;
-
- $pi->{start} = 0;
-
- $self->FindPatchEnd($text, $pi);
-
- # Try to determine if a web/send-pr attachment
- # has another type of patch inside.
- if ($pi->{type} eq 'stdattach' or $pi->{type} eq 'webattach') {
- if (my $pi2 = $self->FindPatchStart($text)) {
- # Upgrade to more specific type
- $pi->{type} = $pi2->{type}
- if ($pi2->{start} == 0);
- }
- }
-
- push @{$self->{sections}->{$field}},
- new GnatsPR::Section::Patch(substr(
- $$text,
- 0,
- $pi->{size},
- ''
- ), $pi->{name}, $pi->{type});
-
- $$text =~ s/^[\n\s]+//;
- }
-
- # Rest of the field is text
- push @{$self->{sections}->{$field}},
- new GnatsPR::Section::Text($$text)
- if ($$text);
-
- $text = '';
-}
-
-
-#------------------------------------------------------------------------------
-# Func: FindPatchStart()
-# Desc: Find the beginning of the first patch inside the given text blob,
-# if there is one.
-#
-# Args: \$text - Raw text
-#
-# Retn: \%pi - Hash of patch info (or undef):
-# - start - Start offset of patch
-# - type - Type of attachment found
-# - name - Filename, if available
-#------------------------------------------------------------------------------
-
-sub FindPatchStart
-{
- my $self = shift;
- my ($text) = @_;
-
- # Patch from web CGI script. Characteristics:
- # - Only ever one of them.
- # - Appended to the end of Fix:
- # - Blank line after header line
- # - Could contain other types of patch (e.g. shar(1) archive)
- if ($$text =~ /^Patch attached with submission follows:$/m && $self->{fromwebform}) {
- my $start = $+[0]; # The newline on the above
-
- # Next non-blank line (i.e. start of patch)
- if ($$text =~ /\G^./m) {
- $start += $+[0]+1;
- return {start => $start, type => 'webattach'};
- }
-
- return undef;
- }
-
- # Patch from send-pr(1). Characteristics:
- # - Has header and footer line.
- # - Appended to the end of Fix:
- # - User has an opportunity to edit/mangle.
- # - Could contain other types of patch (e.g. shar(1) archive)
- if ($$text =~ /^---{1,8}\s?([A-Za-z0-9-_.,:%]+) (begins|starts) here\s?---+\n/mi) {
- my $r = {start => $-[0], type => 'stdattach', name => $1};
-
- # Chop header line
- substr($$text, $-[0], $+[0] - $-[0], '');
-
- return $r;
- }
-
- # Patch files from diff(1). Characteristics:
- # - Easy to find start.
- # - Difficult to find the end.
- $$text =~ /^((?:(?:---|\*\*\*)\ (?:\S+)\s*(?:Mon|Tue|Wed|Thu|Fri|Sat|Sun)\ .*)
- |(?:(?:---|\*\*\*)\ (?:\S+)\s*(?:\d\d\d\d-\d\d-\d\d\ \d\d:\d\d:\d\d\.\d+)\ .*)
- |(diff\ -.*?\ .*?\ .*)|(Index:\ \S+)
- |(\*{3}\ \d+,\d+\ \*{4}))$/mx
- and return {start => $-[0], type => 'diff'};
-
- # Shell archive from shar(1)
- $$text =~ /^# This is a shell archive\. Save it in a file, remove anything before/m
- and return {start => $-[0], type => 'shar'};
-
- # UUencoded file. Characteristics:
- # - Has header and footer.
- $$text =~ /^begin \d\d\d (.*)/m
- and return {start => $-[0], type => 'uuencoded', name => $1};
-
- # Base64 encoded file. Characteristics:
- # - Has header and footer.
- $$text =~ /^begin-base64 \d\d\d (.*)/m
- and return {start => $-[0], type => 'base64', name => $1};
-
- return undef;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: FindPatchEnd()
-# Desc: Find the end of the first patch inside the given text blob, if any.
-#
-# Args: \$text - Raw text
-# \%pi - Patch info hash from FindPatchStart(). We'll add more data:
-# - size - Length of the patch.
-#
-# Retn: \%pi - Same as above, except undef will be returned if no actual
-# endpoint was found (size in pi would extend to the end of the
-# text blob in this case.)
-#------------------------------------------------------------------------------
-
-sub FindPatchEnd
-{
- my $self = shift;
- my ($text, $pi) = @_;
-
- $pi->{size} = 0;
-
- if ($pi->{type} eq 'webattach') {
- $$text =~ /$/
- and $pi->{size} = $+[0];
- } elsif ($pi->{type} eq 'stdattach') {
- $$text =~ /^---{1,8}\s?\Q$pi->{name}\E ends here\s?---+/mi
- and $pi->{size} = $-[0]-1;
- # Chop footer line
- substr($$text, $-[0], $+[0] - $-[0], '');
- } elsif ($pi->{type} eq 'diff') {
- # XXX: could do better
- $$text =~ /^$/m
- and $pi->{size} = $-[0]-1;
- } elsif ($pi->{type} eq 'shar') {
- $$text =~ /^exit$/m
- and $pi->{size} = $+[0];
- } elsif ($pi->{type} eq 'uuencoded') {
- $$text =~ /^end$/m
- and $pi->{size} = $+[0];
- } elsif ($pi->{type} eq 'base64') {
- $$text =~ /^====$/m
- and $pi->{size} = $+[0];
- }
-
- if ($pi->{size} == 0) {
- $pi->{size} = length $$text;
- return undef;
- }
-
- return $pi;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: GetAttachment()
-# Desc: Recursively search sections for a downloadable attachment.
-#
-# Args: $num - Attachment index (counts from 1)
-#
-# Retn: $sec - Attachment section (or undef)
-#------------------------------------------------------------------------------
-
-sub GetAttachment
-{
- my $self = shift;
- my ($num) = @_;
- my $cur = 1;
-
- my $iter = GnatsPR::SectionIterator->new($self, 'Fix', 'Audit-Trail');
-
- while (my $item = $iter->next()) {
- if (ref $item eq 'GnatsPR::Section::Patch') {
- # Patch sections
- return $item if ($cur++ == $num);
- } elsif (ref $item eq 'GnatsPR::Section::Email') {
- # Attachments from MIME messages
- my $mime_iter = GnatsPR::MIMEIterator->new($item);
- while (my $part = $mime_iter->next()) {
- if ($part->isattachment) {
- return $part if ($cur++ == $num);
- }
- }
- }
- }
-
- return undef;
-}
-
-
-1;
Index: htdocs/cgi/GnatsPR/MIMEIterator.pm
===================================================================
--- htdocs/cgi/GnatsPR/MIMEIterator.pm
+++ htdocs/cgi/GnatsPR/MIMEIterator.pm
@@ -1,153 +0,0 @@
-#!/usr/bin/perl -Tw
-#------------------------------------------------------------------------------
-# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $FreeBSD$
-#------------------------------------------------------------------------------
-
-package GnatsPR::MIMEIterator;
-
-use strict;
-
-require 5.006;
-
-
-#------------------------------------------------------------------------------
-# Func: new()
-# Desc: Constructor.
-#
-# Args: $email - GnatsPR::Section::Email instance.
-#
-# Retn: $self
-#------------------------------------------------------------------------------
-
-sub new
-{
- my $class = shift;
- my $email = shift;
-
- my $self = {
- idxlist => [ -1 ],
- email => undef
- };
-
- bless $self, $class;
-
- $self->{email} = $email;
-
- return $self;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: next()
-# Desc: Return next iterator element.
-#
-# Args: n/a
-#
-# Retn: $next
-#------------------------------------------------------------------------------
-
-sub next
-{
- my $self = shift;
-
- my $curr = $self->_current();
-
- while (1) {
- my $next = ++$self->{idxlist}->[$#{$self->{idxlist}}];
-
- # Past last element?
- if ($next > $#{$curr->{mimeparts}}) {
- # Back out
- pop @{$self->{idxlist}};
-
- # Reached the root
- $#{$self->{idxlist}} > -1
- or return undef;
-
- $curr = $self->_current();
- next;
- }
-
- last;
- }
-
- my $rpart = $curr->{mimeparts}->[$self->{idxlist}->[$#{$self->{idxlist}}]];
-
- # Container part? - find a leaf node
- while ($#{$rpart->{mimeparts}} > -1) {
- $rpart = $rpart->{mimeparts}->[0];
- push @{$self->{idxlist}}, 0;
- }
-
- return $rpart;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: isfirst()
-# Desc: Determine if the iterator is at the first element.
-#
-# Args: n/a
-#
-# Retn: $isfirst - true/false
-#------------------------------------------------------------------------------
-
-sub isfirst
-{
- my $self = shift;
-
- return (
- $#{$self->{idxlist}} == 0
- and $self->{idxlist}->[$#{$self->{idxlist}}] == 0
- );
-}
-
-
-#------------------------------------------------------------------------------
-# Func: _current()
-# Desc: Traverse to, and return, the current container element.
-#
-# Args: n/a
-#
-# Retn: $curr
-#------------------------------------------------------------------------------
-
-sub _current
-{
- my $self = shift;
- my $curr = $self->{email};
-
- # Find current MIME part container
- for (my $depth = 0; $depth < $#{$self->{idxlist}}; $depth++) {
- $curr = $curr->{mimeparts}->[$self->{idxlist}->[$depth]];
- }
-
- return $curr;
-}
-
-
-1;
Index: htdocs/cgi/GnatsPR/Makefile
===================================================================
--- htdocs/cgi/GnatsPR/Makefile
+++ htdocs/cgi/GnatsPR/Makefile
@@ -1,14 +0,0 @@
-# $FreeBSD$
-
-.if exists(../Makefile.conf)
-.include "../Makefile.conf"
-.endif
-.if exists(../Makefile.inc)
-.include "../Makefile.inc"
-.endif
-
-SUBDIR= Section
-
-DATA= MIMEIterator.pm Section.pm SectionIterator.pm
-
-.include "${DOC_PREFIX}/share/mk/web.site.mk"
Index: htdocs/cgi/GnatsPR/Makefile.inc
===================================================================
--- htdocs/cgi/GnatsPR/Makefile.inc
+++ htdocs/cgi/GnatsPR/Makefile.inc
@@ -1,4 +0,0 @@
-# $FreeBSD$
-
-WEBBASE?= /data/cgi/GnatsPR
-DOC_PREFIX?= ${.CURDIR}/../../../../..
Index: htdocs/cgi/GnatsPR/Section.pm
===================================================================
--- htdocs/cgi/GnatsPR/Section.pm
+++ htdocs/cgi/GnatsPR/Section.pm
@@ -1,58 +0,0 @@
-#!/usr/bin/perl -Tw
-#------------------------------------------------------------------------------
-# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $FreeBSD$
-#------------------------------------------------------------------------------
-
-package Section;
-
-use strict;
-
-require 5.006;
-
-
-#------------------------------------------------------------------------------
-# Func: new()
-# Desc: Constructor.
-#
-# Args: n/a
-#
-# Retn: $self
-#------------------------------------------------------------------------------
-
-sub new
-{
- my $class = shift;
-
- my $self = {
- };
-
- bless $self, $class;
- return $self;
-}
-
-
-1;
Index: htdocs/cgi/GnatsPR/Section/Email.pm
===================================================================
--- htdocs/cgi/GnatsPR/Section/Email.pm
+++ htdocs/cgi/GnatsPR/Section/Email.pm
@@ -1,189 +0,0 @@
-#!/usr/bin/perl -Tw
-#------------------------------------------------------------------------------
-# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $FreeBSD$
-#------------------------------------------------------------------------------
-
-package GnatsPR::Section::Email;
-
-use GnatsPR::Section::MIME;
-
-use strict;
-
-require 5.006;
-
-
-#------------------------------------------------------------------------------
-# Func: new()
-# Desc: Constructor.
-#
-# Args: $header - Raw e-mail header.
-# $body - Raw message body.
-#
-# Retn: $self
-#------------------------------------------------------------------------------
-
-sub new
-{
- my $class = shift;
- my ($header, $body) = @_;
-
- my $self = {
- headerblob => '',
- bodyblob => '',
-
- headers => {},
-
- mimeparts => []
- };
-
- bless $self, $class;
-
- $self->{headerblob} = $header;
- $self->{bodyblob} = $body;
-
- $self->ParseHeader() if ($header);
- $self->ParseBody() if ($body);
-
- return $self;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: ParseHeader()
-# Desc: Parse header blob into fields.
-#
-# Args: n/a
-#
-# Retn: n/a
-#------------------------------------------------------------------------------
-
-sub ParseHeader
-{
- my $self = shift;
-
- my $key;
-
- foreach my $line (split /\n/, $self->{headerblob}) {
- if ($line =~ /^(\S+):\s*(.*)$/) {
- my $val = $2;
- $key = lc $1;
-
- # Ignore multiple defs (e.g. Received: headers)
- exists $self->{headers}->{$key}
- and next;
-
- $self->{headers}->{$key} = $val;
- } elsif ($line =~ /^\s*(.*)$/) {
- my $val = $1;
-
- defined $key
- or next;
-
- # No field to append to
- exists $self->{headers}->{$key}
- or next;
-
- $self->{headers}->{$key} .= ' '.$val;
- }
- }
-}
-
-
-#------------------------------------------------------------------------------
-# Func: ParseBody()
-# Desc: Parse body blob.
-#
-# Args: n/a
-#
-# Retn: n/a
-#------------------------------------------------------------------------------
-
-sub ParseBody
-{
- # XXX: recurse to second-level parts
-
- my $self = shift;
-
- $self->{mimeparts} = [];
-
- # First of all - attempt to split into MIME parts
- # Note that since GNATS nukes a bunch of the headers
- # that we need, this is purely of a heuristic nature.
-
- # Technically less permissive than RFC1341
-
- my $nextbound = qr/^--([A-Za-z0-9'()+_,-.\/:=?]{6,70})$/m;
- my $first = 1;
-
- while ($self->{bodyblob} =~ s/$nextbound//m) {
- my $last;
-
- if ($first) {
- my $boundary = $1;
- $nextbound = qr/^--\Q$boundary\E(--)?$/m;
- $last = 0;
- $first = 0;
- } else {
- $last = ($2 and $2 eq '--');
- }
-
- # Promote to MIME part
-
- push @{$self->{mimeparts}},
- new GnatsPR::Section::MIME(
- substr($self->{bodyblob}, 0, $-[0], '')
- )
- unless ($-[0] == 0);
- }
-
- if (!@{$self->{mimeparts}}) {
- # No parts - just plain text
- push @{$self->{mimeparts}},
- new GnatsPR::Section::MIME($self->{bodyblob});
- }
-}
-
-
-#------------------------------------------------------------------------------
-# Func: Header()
-# Desc: Return a header field.
-#
-# Args: $key - Header name, case insensitive.
-#
-# Retn: $val - Value.
-#------------------------------------------------------------------------------
-
-sub Header
-{
- my $self = shift;
- my ($key) = @_;
-
- return $self->{headers}->{lc $key};
-}
-
-
-1;
Index: htdocs/cgi/GnatsPR/Section/FieldStart.pm
===================================================================
--- htdocs/cgi/GnatsPR/Section/FieldStart.pm
+++ htdocs/cgi/GnatsPR/Section/FieldStart.pm
@@ -1,80 +0,0 @@
-#!/usr/bin/perl -Tw
-#------------------------------------------------------------------------------
-# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $FreeBSD$
-#------------------------------------------------------------------------------
-
-package GnatsPR::Section::FieldStart;
-
-use strict;
-
-require 5.006;
-
-
-#------------------------------------------------------------------------------
-# Func: new()
-# Desc: Constructor.
-#
-# Args: $name - Field name.
-#
-# Retn: $self
-#------------------------------------------------------------------------------
-
-sub new
-{
- my $class = shift;
- my ($name) = @_;
-
- my $self = {
- name => ''
- };
-
- bless $self, $class;
-
- $self->{name} = $name;
-
- return $self;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: string()
-# Desc: Return the field name.
-#
-# Args: n/a
-#
-# Retn: $string
-#------------------------------------------------------------------------------
-
-sub string
-{
- my $self = shift;
-
- return $self->{name};
-}
-
-
-1;
Index: htdocs/cgi/GnatsPR/Section/MIME.pm
===================================================================
--- htdocs/cgi/GnatsPR/Section/MIME.pm
+++ htdocs/cgi/GnatsPR/Section/MIME.pm
@@ -1,334 +0,0 @@
-#!/usr/bin/perl -Tw
-#------------------------------------------------------------------------------
-# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $FreeBSD$
-#------------------------------------------------------------------------------
-
-package GnatsPR::Section::MIME;
-
-use MIME::Base64; # ports/converters/p5-MIME-Base64
-use MIME::QuotedPrint; #
-use Convert::UU qw(uudecode uuencode); # ports/converters/p5-Convert-UU
-
-use Encode;
-
-use strict;
-
-require 5.006;
-
-
-#------------------------------------------------------------------------------
-# Func: new()
-# Desc: Constructor.
-#
-# Args: $blob - Raw MIME part, inc. any headers.
-#
-# Retn: $self
-#------------------------------------------------------------------------------
-
-sub new
-{
- my $class = shift;
- my ($blob) = @_;
-
- my $self = {
- body => '',
- decoded_body => '',
- headers => {},
- binary => 0,
- encoded => 0,
- attachment => 0,
- filename => '',
- mimeparts => [] # Sub parts (usually empty)
- };
-
- bless $self, $class;
-
- $self->{body} = $blob;
-
- $self->Parse() if ($blob);
-
- return $self;
-}
-
-
-#------------------------------------------------------------------------------
-# Accessors
-#------------------------------------------------------------------------------
-
-sub body
-{
- my $self = shift;
- $self->{body} = $_[0] if @_;
- return $self->{body};
-}
-
-sub isbinary
-{
- my $self = shift;
- return $self->{binary};
-}
-
-sub isencoded
-{
- my $self = shift;
- return $self->{encoded};
-}
-
-sub isattachment
-{
- my $self = shift;
- return $self->{attachment};
-}
-
-sub filename
-{
- my $self = shift;
- return $self->{filename};
-}
-
-sub data
-{
- my $self = shift;
- return $self->{encoded} ? $self->{decoded_body} : $self->{body};
-}
-
-sub size
-{
- my $self = shift;
- return length($self->{encoded} ? $self->{decoded_body} : $self->{body});
-}
-
-
-#------------------------------------------------------------------------------
-# Func: Parse()
-# Desc: Parse and decode raw MIME part.
-#
-# Args: n/a
-#
-# Retn: n/a
-#------------------------------------------------------------------------------
-
-sub Parse
-{
- my $self = shift;
-
- my $charset;
-
- $self->{body} =~ s/^[\n\s]+//;
- $self->{body} =~ s/[\n\s]+$/\n/;
-
- $self->ParseHeader();
-
- # Determine if we're a multi-part container
- if (lc $self->header('content-type') =~ /multipart/
- and $self->header('content-type:boundary')) {
- my $bound = $self->header('content-type:boundary');
- @{$self->{mimeparts}} =
- map {
- new GnatsPR::Section::MIME($_);
- }
- grep !/^[\n\s]*$/,
- split /^--\Q$bound\E(?:--)?$/m, $self->{body};
- $self->{body} = undef;
- return;
- }
-
- if ($self->header('content-type:charset')) {
- my $cs = $self->header('content-type:charset');
-
- if ($cs =~ /utf.*8/i) {
- $cs = 'utf-8';
- } else {
- $cs = Encode::resolve_alias($cs);
- }
-
- if ($cs and $cs ne 'ascii') {
- $charset = $cs;
- }
- }
-
- # Look for Quoted-Printable (explicit or using a silly heuristic)
- if (lc $self->header('content-transfer-encoding') eq 'quoted-printable'
- or $self->{body} =~ /=[0-9A-Fa-f]{2}=[0-9A-Fa-f]{2}/) {
- $self->{body} = decode_qp($self->{body});
- $self->{body} = decode($charset, $self->{body})
- if ($charset);
-
- # Base64 -- probably better not to decode
- } elsif (lc $self->header('content-transfer-encoding') eq 'base64') {
- $self->{decoded_body} = decode_base64($self->{body});
- $self->{decoded_body} = decode($charset, $self->{decoded_body})
- if ($charset);
- $self->{encoded} = 1;
- }
-
- # Catches too much stuff that we can display
- #if ($self->header('content-type')
- # && $self->header('content-type') !~ 'text/') {
- # $self->{binary} = 1;
- #}
-
- if (lc $self->header('content-disposition') eq 'attachment') {
- my $filename =
- $self->header('content-disposition:filename')
- || $self->header('content-type:name')
- || $self->header('x-attachment-id')
- || 'attachment';
-
- $filename =~ '(?:\.gz|\.bz2|\.zip|\.tar)$'
- and $self->{binary} = 1;
-
- $self->{attachment} = 1;
- $self->{filename} = $filename;
- }
-
- if ($self->{body} =~ /^begin \d\d\d (.*)/ && !$self->{encoded}) {
- $self->{decoded_body} = uudecode($self->{body});
- $self->{encoded} = 1;
- }
-}
-
-
-#------------------------------------------------------------------------------
-# Func: ParseHeader()
-# Desc: Parse out any MIME header fields.
-#
-# Args: n/a
-#
-# Retn: n/a
-#------------------------------------------------------------------------------
-
-sub ParseHeader
-{
- my $self = shift;
- my $header = '';
- my $key;
-
- # Start with some defaults
- $self->{headers}->{'content-type'} = 'text/plain';
-
- # No header?
- $self->{body} =~ /^Content-/i
- or return;
-
- # Ensure we have an end-of-header marker. Returning here
- # will result in some bodyless headers being dumped as
- # text (example in conf/138672) -- but I think this is
- # the safe option, in case such a header is in fact the
- # body of a malformed message.
- $self->{body} =~ /^$/m and $+[0] != length($self->{body}) or return;
-
- $header = substr($self->{body}, 0, $+[0]+1, '');
-
- $self->{body} =~ s/^[\n\s]+//;
-
- foreach my $line (split /\n/, $header) {
- if ($line =~ /^(\S+): (.*)$/) {
- $key = lc $1;
- $self->{headers}->{$key} = $2;
- } elsif ($line =~ /^\s+(.*)$/) {
- $key or next;
- $self->{headers}->{$key} .= ' ' . $1;
- }
- }
-
- # Split up aggregate headers into individual values
-
- foreach my $key (keys %{$self->{headers}}) {
- $self->{headers}->{$key} =~ /;/ or next;
-
- my @chars = split //, $self->{headers}->{$key};
- my $inquote = 0;
- my $gotkey = 0;
- my $k = '';
- my $v = '';
-
- foreach my $char (@chars) {
- if ($char eq '"') {
- $inquote = !$inquote;
- next;
- } elsif ($char eq '=' && !$inquote) {
- $gotkey = 1;
- next;
- } elsif ($char eq ';' && !$inquote) {
- if ($k and $v) {
- $k = lc $k;
- $self->{headers}->{"$key:$k"} = $v;
- }
- $k = $v = '';
- $gotkey = 0;
- next;
- } elsif (($char eq ' ' or $char eq '\t') && !$inquote) {
- next;
- }
-
- if ($gotkey) {
- $v .= $char;
- } else {
- $k .= $char;
- }
- }
-
- if ($k and $v) {
- $k = lc $k;
- $self->{headers}->{"$key:$k"} = $v;
- }
-
- $self->{headers}->{$key} =~ s/;.*$//;
- }
-
- # Normalise
-
- $self->{headers}->{'content-type'} =
- lc $self->{headers}->{'content-type'};
-}
-
-
-#------------------------------------------------------------------------------
-# Func: header()
-# Desc: Return header.
-#
-# Args: $key
-#
-# Retn: $val
-#------------------------------------------------------------------------------
-
-sub header
-{
- my $self = shift;
- my ($key) = @_;
-
- $key = lc $key;
-
- return $self->{headers}->{$key}
- if (exists $self->{headers}->{$key});
-
- return '';
-}
-
-
-1;
Index: htdocs/cgi/GnatsPR/Section/Makefile
===================================================================
--- htdocs/cgi/GnatsPR/Section/Makefile
+++ htdocs/cgi/GnatsPR/Section/Makefile
@@ -1,12 +0,0 @@
-# $FreeBSD$
-
-.if exists(../Makefile.conf)
-.include "../Makefile.conf"
-.endif
-.if exists(../Makefile.inc)
-.include "../Makefile.inc"
-.endif
-
-DATA= Email.pm FieldStart.pm MIME.pm Patch.pm StateChange.pm Text.pm
-
-.include "${DOC_PREFIX}/share/mk/web.site.mk"
Index: htdocs/cgi/GnatsPR/Section/Patch.pm
===================================================================
--- htdocs/cgi/GnatsPR/Section/Patch.pm
+++ htdocs/cgi/GnatsPR/Section/Patch.pm
@@ -1,188 +0,0 @@
-#!/usr/bin/perl -Tw
-#------------------------------------------------------------------------------
-# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $FreeBSD$
-#------------------------------------------------------------------------------
-
-package GnatsPR::Section::Patch;
-
-use MIME::Base64; # ports/converters/p5-MIME-Base64
-use Convert::UU qw(uudecode uuencode); # ports/converters/p5-Convert-UU
-
-use strict;
-
-require 5.006;
-
-
-#------------------------------------------------------------------------------
-# Func: new()
-# Desc: Constructor.
-#
-# Args: $text - Blob of text.
-# $filename - Filename of patch, if we have one.
-# $type - Patch type string (if known).
-#
-# Retn: $self
-#------------------------------------------------------------------------------
-
-sub new
-{
- my $class = shift;
- my ($text, $filename, $type) = @_;
-
- my $self = {
- text => '',
- filename => 'patch.txt',
- binary => 0,
- encoded => 0,
- type => 'unknown'
- };
-
- bless $self, $class;
-
- $self->{text} = $text;
-
- $self->{filename} = $filename if $filename;
- $self->{type} = $type if $type;
-
- $self->{filename} =~ '(?:\.gz|\.bz2|\.zip|\.tar)$'
- and $self->{binary} = 1;
-
- if ($self->{type} eq 'uuencoded') {
- $self->{encoded} = 1;
- $self->{decoded_text} = uudecode($self->{text});
- } elsif ($self->{type} eq 'base64') {
- $self->{encoded} = 1;
- $self->{decoded_text} = decode_base64($self->{text});
- }
-
- return $self;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: string()
-# Desc: Return string contained within.
-#
-# Args: n/a
-#
-# Retn: $string
-#------------------------------------------------------------------------------
-
-sub string
-{
- my $self = shift;
-
- return $self->{text};
-}
-
-
-#------------------------------------------------------------------------------
-# Func: size()
-# Desc: Return the length of the contained data.
-#
-# Args: n/a
-#
-# Retn: $string
-#------------------------------------------------------------------------------
-
-sub size
-{
- my $self = shift;
-
- return length($self->{encoded} ? $self->{decoded_text} : $self->{text});
-}
-
-
-#------------------------------------------------------------------------------
-# Func: data()
-# Desc: Return the raw decoded (if possible/necessary) data.
-#
-# Args: n/a
-#
-# Retn: $string
-#------------------------------------------------------------------------------
-
-sub data
-{
- my $self = shift;
-
- return $self->{encoded} ? $self->{decoded_text} : $self->{text};
-}
-
-
-#------------------------------------------------------------------------------
-# Func: filename()
-# Desc: Return the patch's filename.
-#
-# Args: n/a
-#
-# Retn: $filename
-#------------------------------------------------------------------------------
-
-sub filename
-{
- my $self = shift;
-
- return $self->{filename};
-}
-
-
-#------------------------------------------------------------------------------
-# Func: type()
-# Desc: Return the patch's type.
-#
-# Args: n/a
-#
-# Retn: $type
-#------------------------------------------------------------------------------
-
-sub type
-{
- my $self = shift;
-
- return $self->{type};
-}
-
-
-#------------------------------------------------------------------------------
-# Func: isbinary()
-# Desc: Is patch binary?
-#
-# Args: n/a
-#
-# Retn: $type
-#------------------------------------------------------------------------------
-
-sub isbinary
-{
- my $self = shift;
-
- return $self->{binary};
-}
-
-
-1;
Index: htdocs/cgi/GnatsPR/Section/StateChange.pm
===================================================================
--- htdocs/cgi/GnatsPR/Section/StateChange.pm
+++ htdocs/cgi/GnatsPR/Section/StateChange.pm
@@ -1,117 +0,0 @@
-#!/usr/bin/perl -Tw
-#------------------------------------------------------------------------------
-# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $FreeBSD$
-#------------------------------------------------------------------------------
-
-package GnatsPR::Section::StateChange;
-
-use strict;
-
-require 5.006;
-
-
-#------------------------------------------------------------------------------
-# Func: new()
-# Desc: Constructor.
-#
-# Args: n/a
-#
-# Retn: $self
-#------------------------------------------------------------------------------
-
-sub new
-{
- my $class = shift;
-
- my $self = {
- what => '', # State or Responsible
- from => '', # Change from
- to => '', # Change to
- why => '', # Reason for change
- when => '', # Date of change
- by => '' # Who changed it
- };
-
- bless $self, $class;
-
- return $self;
-}
-
-
-#------------------------------------------------------------------------------
-# Accessors
-#------------------------------------------------------------------------------
-
-sub what
-{
- my $self = shift;
- $self->{what} = $_[0] if @_;
- return $self->{what};
-}
-
-sub from
-{
- my $self = shift;
- $self->{from} = $_[0] if @_;
- return $self->{from};
-}
-
-sub to
-{
- my $self = shift;
- $self->{to} = $_[0] if @_;
- return $self->{to};
-}
-
-sub why
-{
- my $self = shift;
-
- if (scalar @_) {
- $self->{why} = $_[0];
- $self->{why} =~ s/^\s+//;
- $self->{why} =~ s/[\n\s]+$//;
- }
- return $self->{why};
-}
-
-sub when
-{
- my $self = shift;
- $self->{when} = $_[0] if @_;
- return $self->{when};
-}
-
-sub by
-{
- my $self = shift;
- $self->{by} = $_[0] if @_;
- return $self->{by};
-}
-
-
-1;
Index: htdocs/cgi/GnatsPR/Section/Text.pm
===================================================================
--- htdocs/cgi/GnatsPR/Section/Text.pm
+++ htdocs/cgi/GnatsPR/Section/Text.pm
@@ -1,82 +0,0 @@
-#!/usr/bin/perl -Tw
-#------------------------------------------------------------------------------
-# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $FreeBSD$
-#------------------------------------------------------------------------------
-
-package GnatsPR::Section::Text;
-
-use strict;
-
-require 5.006;
-
-
-#------------------------------------------------------------------------------
-# Func: new()
-# Desc: Constructor.
-#
-# Args: $text - Blob of text.
-#
-# Retn: $self
-#------------------------------------------------------------------------------
-
-sub new
-{
- my $class = shift;
- my ($text) = @_;
-
- my $self = {
- text => ''
- };
-
- bless $self, $class;
-
- $text =~ s/[\s\n]+$//s; # Tidy up trailing whitespace
-
- $self->{text} = $text;
-
- return $self;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: string()
-# Desc: Return string contained within.
-#
-# Args: n/a
-#
-# Retn: $string
-#------------------------------------------------------------------------------
-
-sub string
-{
- my $self = shift;
-
- return $self->{text};
-}
-
-
-1;
Index: htdocs/cgi/GnatsPR/SectionIterator.pm
===================================================================
--- htdocs/cgi/GnatsPR/SectionIterator.pm
+++ htdocs/cgi/GnatsPR/SectionIterator.pm
@@ -1,114 +0,0 @@
-#!/usr/bin/perl -Tw
-#------------------------------------------------------------------------------
-# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $FreeBSD$
-#------------------------------------------------------------------------------
-
-package GnatsPR::SectionIterator;
-
-use strict;
-
-require 5.006;
-
-
-#------------------------------------------------------------------------------
-# Func: new()
-# Desc: Constructor.
-#
-# Args: $gnatspr - GnatsPR instance.
-# @fields - Which fields we want sections from. The order determines
-# the order of the returned sections. Undefined behaviour if
-# no no fields specified.
-#
-# Retn: $self
-#------------------------------------------------------------------------------
-
-sub new
-{
- my $class = shift;
- my $gnatspr = shift;
-
- my $self = {
- gnatspr => $gnatspr,
- currfield => -1,
- currsection => -1,
- wantfields => []
- };
-
- bless $self, $class;
-
- while (my $f = shift) {
- push @{$self->{wantfields}}, $f;
- }
-
- return $self;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: next()
-# Desc: Return next iterator element.
-#
-# Args: n/a
-#
-# Retn: $next
-#------------------------------------------------------------------------------
-
-sub next
-{
- my $self = shift;
- my ($fieldkey, $maxsection);
-
- # Next section
- $self->{currsection}++;
-
- # First field?
- $self->{currfield} == -1
- and $self->{currfield} = 0;
-
- $fieldkey = $self->{wantfields}->[$self->{currfield}];
- $maxsection = $#{$self->{gnatspr}->{sections}->{$fieldkey}};
-
- # We've passed the last section in this field
- while ($self->{currsection} > $maxsection) {
- # Next field, first section
- $self->{currfield}++;
- $self->{currsection} = 0;
-
- # Run out of fields?
- $self->{currfield} > $#{$self->{wantfields}}
- and return undef;
-
- # Update, and go back to check next field
- $fieldkey = $self->{wantfields}->[$self->{currfield}];
- $maxsection = $#{$self->{gnatspr}->{sections}->{$fieldkey}};
- }
-
- return $self->{gnatspr}->{sections}->{$fieldkey}->[$self->{currsection}];
-}
-
-
-1;
Index: htdocs/cgi/Makefile
===================================================================
--- htdocs/cgi/Makefile
+++ htdocs/cgi/Makefile
@@ -8,15 +8,11 @@
.endif
DATA=
-DATA+= Gnats.pm
-DATA+= GnatsPR.pm
DATA+= cgi-lib.pl
DATA+= cgi-style.pl
-DATA+= query-pr-lib.pl
CGI=
CGI+= confirm-code.cgi
-CGI+= dosendpr.cgi
CGI+= getmsg.cgi
CGI+= mailindex.cgi
CGI+= man.cgi
@@ -25,12 +21,8 @@
CGI+= missing_handler.cgi
CGI+= monthly.cgi
CGI+= ports.cgi
-CGI+= query-pr.cgi
-CGI+= query-pr-summary.cgi
CGI+= search.cgi
-SUBDIR= GnatsPR
-
.SUFFIXES: .C .cgi
.C.cgi:
Index: htdocs/cgi/dosendpr.cgi
===================================================================
--- htdocs/cgi/dosendpr.cgi
+++ htdocs/cgi/dosendpr.cgi
@@ -1,226 +0,0 @@
-#!/usr/bin/perl
-#
-# Send-pr perl script to send a pr.
-#
-# Copyright (c) 1996 Free Range Media
-#
-# Copying and distribution permitted under the conditions of the
-# GNU General Public License Version 2.
-# (http://www.gnu.ai.mit.edu/copyleft/gpl.html)
-#
-# $FreeBSD$
-
-use Socket;
-use CGI qw/:standard/;
-use DB_File;
-use Fcntl qw(:DEFAULT :flock);
-require "./Gnats.pm"; import Gnats;
-
-my $blackhole = "dnsbl.njabl.org";
-my $openproxyip = "127.0.0.9";
-my $blackhole_err = 0;
-my $openproxy;
-
-my $expiretime = 2700;
-$dbpath = "/usr/local/www/var/confirm-code/sendpr-code.db";
-
-# Maximum size of patch that we'll accept from send-pr.html.
-$maxpatch = 102400;
-
-my $patchbuf;
-my $patchhandle;
-
-# Environment variables to stuff in the PR header.
-my @ENV_captures = qw/ REMOTE_HOST
- REMOTE_ADDR
- REMOTE_PORT
- HTTP_REFERER
- HTTP_CLIENT_IP
- HTTP_FORWARDED
- HTTP_VIA
- HTTP_X_FORWARDED_FOR /;
-
-# env2hdr (@ENV_captures)
-# Returns X-header style headers for inclusion in the header of a PR
-sub env2hdr (@) {
- my $headers = "";
- foreach my $var (@_) {
- next unless $ENV{$var};
- $headers .= "X-$var: $ENV{$var}\n";
- }
- return $headers;
-}
-
-# isopenproxy ($ip, $blackhole_zone, $positive_ip)
-# Returns undef on error, 0 if DNS lookup fails, $positive_ip if verified
-# proxy. A DNS lookup failing can either means that there was a network
-# problem, or that the IP is not listed in the blackhole zone.
-sub isopenproxy ($$$) {
- # If $? is already set, then a successful gethostbyname() leaves it set
- local $?;
- my ($ip, $zone, $proxyip) = @_;
- my ($reversed_ip, $packed);
- if (!defined $proxyip) { return undef };
-
- $reversed_ip = join('.', reverse split(/\./, $ip));
- $packed = gethostbyname("${reversed_ip}.${blackhole}");
- return undef if $?;
-
- if ($packed && (inet_ntoa($packed) eq $proxyip)) {
- return $proxyip;
- } else {
- return 0;
- }
-}
-
-sub prerror {
- print start_html("Problem Report Error");
- print "<p>There is an error in the configuration of the problem\n",
- "report form generator. Please back up one page and report\n",
- "the problem to the owner of that page.<br />",
- "Report <span class=\"prerror\">$_[0]</span>.</p>";
- print end_html();
- exit (1);
-}
-
-sub piloterror {
- print start_html("Problem Report Error");
- print "<p>There is an error with your problem\n",
- "report submission.\n",
- "The problem was: <span class=\"prerror\">$_[0]</span>.</p>";
- print end_html();
- exit (1);
-}
-
-print header();
-
-&prerror("request method problem") if $ENV{'REQUEST_METHOD'} eq 'GET';
-
-if (!$submission_program) { &prerror("submit program problem"); }
-
-if ($patchhandle = upload('patch')) {
-# use bytes;
- unless ((uploadInfo($patchhandle)->{'Content-Type'} =~ m!^text/.*!) ||
- (uploadInfo($patchhandle)->{'Content-Type'} =~ m!^application/shar$!)) {
- &piloterror("<p>Patch file has wrong content type: got " .
- uploadInfo($patchhandle)->{'Content-Type'} .
- " but was expecting one matching text/.* or application/shar.</p>" .
- "<p>Try renaming the file to have a .txt extension" .
- " to convince your browser to do the right thing.</p>");
- }
- read($patchhandle,$patchbuf,$maxpatch + 1);
- if (length($patchbuf) > $maxpatch) {
- &piloterror("Patch file too big (over ${maxpatch} bytes)");
- }
-}
-
-# Verify the code...
-
-$db_obj = tie(%db_hash, 'DB_File', $dbpath, O_CREAT|O_RDWR, 0644)
- or die "dbcreate $dbpath $!";
-$fd = $db_obj->fd;
-open(DB_FH, "+<&=$fd") or die "fdopen $!";
-
-unless (flock (DB_FH, LOCK_EX | LOCK_NB)) {
- unless (flock (DB_FH, LOCK_EX)) { die "flock: $!" }
-}
-
-$codeentered = param('code-confirm');
-$codeentered =~ s/.*/\U$&/; # Turn input uppercase
-$currenttime = time();
-if (defined($codeentered) && $codeentered && $db_hash{$codeentered} &&
- (($currenttime - $expiretime) <= $db_hash{$codeentered})) {
- if (!param('email') || !param('originator') ||
- !param('synopsis')) {
- print start_html("Problem Report Error");
- print "<h1>Bad Data</h1><p>You need to specify at least your ",
- "electronic mail address, your name and a synopsis ",
- "of the problem.<br /> Please return to the form and add the ",
- "missing information. Thank you.</p>";
- print end_html();
-
- exit(1);
- }
-} else {
- print start_html("Problem Report Error");
- print "<h1>Incorrect confirmation code</h1><p>You need to enter the correct ",
- "code from the image displayed. Please return to the form and enter the ",
- "code exactly as shown. Thank you.</p>";
- print end_html();
-
- exit(1);
-}
-
-# This code has now been used, so remove it.
-delete $db_hash{"$codeentered"};
-
-# Sweep for and remove expired codes.
-foreach $randomcode (keys %db_hash) {
- if ( ($currenttime - $expiretime) >= $db_hash{$randomcode}) {
- delete $db_hash{"$randomcode"};
- }
-}
-$db_obj->sync(); # to flush
-flock(DB_FH, LOCK_UN);
-undef $db_obj; # removing the last reference to the DB
- # closes it. Closing DB_FH is implicit.
-untie %db_hash;
-
-
-$openproxy = isopenproxy($ENV{'REMOTE_ADDR'}, $blackhole, $openproxyip);
-if (defined $openproxy) {
- if ($openproxy) {
- &prerror("$ENV{'REMOTE_ADDR'} is an open proxy server");
- }
-} else {
- $blackhole_err++;
-}
-
-# Build the PR.
-$pr = "To: $submission_address\n" .
- "From: " . param('originator') . " <" . param('email') . ">\n" .
- "Subject: " . param('synopsis') . "\n" .
- env2hdr(@ENV_captures);
-if ($blackhole_err) {
- $pr .= "X-REMOTE_ADDR-Is-Open-Proxy: Maybe\n";
-}
-
-$pr .= "X-Send-Pr-Version: www-3.1\n" .
- "X-GNATS-Notify: \n\n" .
- ">Submitter-Id:\t" . param('submitterid') . "\n" .
- ">Originator:\t" . param('originator') . "\n" .
- ">Organization:\t" . param('organization') . "\n" .
- ">Confidential:\t" . param('confidential') . "\n" .
- ">Synopsis:\t" . param('synopsis') . "\n" .
- ">Severity:\t" . param('severity') . "\n" .
- ">Priority:\t" . param('priority') . "\n" .
- ">Category:\t" . param('category') . "\n" .
- ">Class:\t\t" . param('class') . "\n" .
- ">Release:\t" . param('release') . "\n" .
- ">Environment:\t" . param('environment') . "\n" .
- ">Description:\n" . param('description') . "\n" .
- ">How-To-Repeat:\n" . param('howtorepeat') . "\n" .
- ">Fix:\n" . param('fix') . "\n";
-
-if (length($patchbuf) > 0) {
- $pr .= "\nPatch attached with submission follows:\n\n"
- . $patchbuf . "\n";
-}
-
-# remove any carriage returns that appear in the report.
-$pr =~ s/\r//g;
-
-if (open (SUBMIT, "|$submission_program")){
-
- print SUBMIT $pr;
- print SUBMIT "\n.\n";
- close (SUBMIT);
- print start_html("Thank you for the problem report");
- print "<h1>Thank You</h1>",
- "<p>Thank you for the problem report. You should receive confirmation",
- " of your report by electronic mail within a day.</p>";
-} else {
- print start_html("Error raising problem report");
- print "<h1>Error</h1><p>An error occured processing your problem report.</p>";
-}
-print end_html();
Index: htdocs/cgi/query-pr-lib.pl
===================================================================
--- htdocs/cgi/query-pr-lib.pl
+++ htdocs/cgi/query-pr-lib.pl
@@ -1,167 +0,0 @@
-#!/usr/bin/perl -Tw
-# $FreeBSD$
-
-sub get_categories {
- @categories = ();
-
- open(Q, 'query-pr.web --list-categories 2>/dev/null |') ||
- die "Cannot get categories\n";
-
- while(<Q>) {
- chop;
- local ($cat, $desc, $responsible, $notify) = split(/:/);
- push(@categories, $cat);
- $catdesc{$cat} = $desc;
- }
-}
-
-sub get_states {
- @states = ();
-
- open(Q, 'query-pr.web --list-states 2>/dev/null |') ||
- die "Cannot get states\n";
-
- while(<Q>) {
- chop;
- local ($state, $type, $desc) = split(/:/);
- push(@states, $state);
- $statedesc{$state} = $desc;
- }
-}
-
-sub get_classes {
- @classes = ();
-
- open(Q, 'query-pr.web --list-classes 2>/dev/null |') ||
- die "Cannot get classes\n";
-
- while(<Q>) {
- chop;
- local ($class, $type, $desc) = split(/:/);
- push(@classes, $class);
- $classdesc{$class} = $desc;
- }
-}
-
-sub displayform {
-print qq`
-<p>To query the GNATS Database for specific PR number, please fill in
-this form:</p>
-<form action='./query-pr.cgi' method='get'>
-<table cellspacing='0' cellpadding='3' class='headtable'>
-<tr><td width='130'><b>PR number:</b></td><td><input type='text'
- name='pr' maxlength='30' /></td></tr>
-<tr><td width='130'><b>Category:</b></td><td><input type='text'
- name='cat' maxlength='30' /> (optional)</td></tr>
-<tr><td colspan='2'><input type='submit' value='Submit' />
-<input type='reset' value='Reset Form' /></td></tr>
-</table>
-</form>
-
-<p>Alternatively, it is possible to select items you wish to search for.
-Multiple items are AND'ed together.<br />
-To generate current list of all open PRs in GNATS database, just press
-the "Query PRs" button.
-</p>
-<form method='get' action='./query-pr-summary.cgi'>
-
-<table cellspacing="0" cellpadding="3" class="headtable">
-<tr>
-<td><b>Category</b>:</td>
-<td><select name='category'>
-<option selected='selected' value=''>Any</option>`;
-
-&get_categories;
-foreach (sort @categories) {
- #print "<option value='$_'>$_ ($catdesc{$_})</option>\n";
- print "<option>$_</option>\n";
-}
-
-print qq`
-</select></td>
-<td><b>Severity</b>:</td>
-<td><select name='severity'>
-<option selected='selected' value=''>Any</option>
-<option>non-critical</option>
-<option>serious</option>
-<option>critical</option>
-</select></td>
-</tr><tr>
-<td><b>Priority</b>:</td>
-<td><select name='priority'>
-<option selected='selected' value=''>Any</option>
-<option>low</option>
-<option>medium</option>
-<option>high</option>
-</select></td>
-<td><b>Class</b>:</td>
-<td><select name='class'>
-<option selected='selected' value=''>Any</option>
-`;
-
-&get_classes;
-foreach (@classes) {
- #print "<option value='$_'>$_ ($classdesc{$_})</option>\n";
- print "<option>$_</option>\n";
-}
-
-print qq`</select></td>
-</tr><tr>
-<td><b>State</b>:</td>
-<td><select name='state'>
-<option selected='selected' value=''>Any</option>
-`;
-
-&get_states;
-foreach (@states) {
- ($us = $_) =~ s/^./\U$&/;
- print "<option value='$_'>";
- #print "$us ($statedesc{$_})</option>\n";
- print "$us</option>\n";
-}
-
-print qq`</select></td>
-<td><b>Sort by</b>:</td>
-<td><select name='sort'>
-<option value='none'>No Sort</option>
-<option value='lastmod'>Last-Modified</option>
-<option value='category'>Category</option>
-<option value='responsible'>Responsible Party</option>
-</select></td>
-</tr><tr>
-<!-- We don't use submitter Submitter: -->
-<td><b>Text in single-line fields</b>:</td>
-<td><input type='text' name='text' /></td>
-<td><b>Responsible</b>:</td>
-<td><input type='text' name='responsible' /></td>
-</tr><tr>
-<td><b>Text in multi-line fields</b>:</td>
-<td><input type='text' name='multitext' /></td>
-<td><b>Originator</b>:</td>
-<td><input type='text' name='originator' /></td>
-</tr><tr>
-<td><b>Closed reports too</b>:</td>
-<td><input name='closedtoo' value='on' type='checkbox' /></td>
-<td><b>Release</b>:</td>
-<td><select name='release'>
-<option selected='selected' value=''>Any</option>
-<option value='^FreeBSD [2345678]'>Pre-8.X</option>
-<option value='^FreeBSD 10'>10.X only</option>
-<option value='^FreeBSD 9'>9.X only</option>
-<option value='^FreeBSD 8'>8.X only</option>
-<option value='^FreeBSD 7'>7.X only</option>
-<option value='^FreeBSD 6'>6.X only</option>
-<option value='^FreeBSD 5'>5.X only</option>
-<option value='^FreeBSD 4'>4.X only</option>
-<option value='^FreeBSD 3'>3.X only</option>
-<option value='^FreeBSD 2'>2.X only</option>
-</select></td>
-</tr>
-<tr><td colspan="2"><input type='submit' value='Query PRs' />
-<input type='reset' value='Reset Form' /></td></tr>
-</table>
-</form>
-`;
-}
-
-1;
Index: htdocs/cgi/query-pr-summary.cgi
===================================================================
--- htdocs/cgi/query-pr-summary.cgi
+++ htdocs/cgi/query-pr-summary.cgi
@@ -1,473 +0,0 @@
-#!/usr/bin/perl -T
-# $FreeBSD$
-
-$html_mode = 1 if $ENV{'DOCUMENT_ROOT'};
-$self_ref = $ENV{'SCRIPT_NAME'};
-($query_pr_ref = $self_ref) =~ s/-summary//;
-
-$ENV{'PATH'} = '/bin:/usr/bin:/usr/sbin:/sbin:/usr/local/bin';
-
-$project = 'FreeBSD';
-$mail_prefix = 'freebsd-';
-$mail_unass = 'freebsd-bugs';
-$ports_unass = 'ports-bugs';
-$closed_too = 0;
-
-require './cgi-lib.pl';
-require './cgi-style.pl';
-require './query-pr-lib.pl';
-
-if (!$ENV{'QUERY_STRING'} or $ENV{'QUERY_STRING'} eq 'query') {
- print &html_header("Query $project problem reports");
- &displayform;
- print &html_footer;
- exit(0);
-}
-
-if ($html_mode) {
- $query_args = '--restricted ';
- &ReadParse(*input);
-} else {
- &Getopts('CcqRr:s:T:');
-
- $input{'responsible'} = 'summary' if $opt_R;
- if ($opt_r) {
- ($input{'responsible'}) = ($opt_r =~ m/^(\^?[-_a-zA-Z0-9@.]*\$?)$/);
- die 'Insecure args' if ($input{'responsible'} ne $opt_r)
- }
- if ($opt_s) {
- ($input{'state'}) = ($opt_s =~ m/^([a-zA-Z]*)$/);
- die 'Insecure args' if ($input{'state'} ne $opt_s)
- }
- $input{'quiet'} = 'yes' if $opt_q;
- if ($opt_C) {
- $query_args = '--confidential=yes ';
- } elsif (!$opt_c) {
- $query_args = '--restricted ';
- }
- if ($opt_T) {
- ($tag) = ($opt_T =~ m/^(\^?[-_a-zA-Z0-9@.]*\$?)$/);
- die 'Insecure args' if ($tag ne $opt_T);
- $input{'text'} = '\[' . $tag . '\]';
- }
-}
-
-$closed_too = 1 if $input{'state'} eq 'closed' ||
- ($input{'closedtoo'} && ($input{'multitext'} || $input{'text'} || $input{'responsible'} || $input{'originator'}));
-
-#------------------------------------------------------------------------
-
-%mons = ('Jan', '01', 'Feb', '02', 'Mar', '03',
- 'Apr', '04', 'May', '05', 'Jun', '06',
- 'Jul', '07', 'Aug', '08', 'Sep', '09',
- 'Oct', '10', 'Nov', '11', 'Dec', '12');
-
-
-if ($html_mode) {
-
- $pr = '<pre>'; $pr_e = '</pre>';
- $h1 = '<h1>'; $h1_e = '</h1>';
- $h3 = '<h3>'; $h3_e = '</h3>';
- $hr = '<hr/>';
-
- $table = "<table width='100%' border='0' cellspacing='1' cellpadding='0'>";
- $table_e = '</table>';
-
- # Customizations for the look and feel of the summary tables.
- $t_style = "<style type='text/css'><!--\n" .
- "table { background-color: #ccc; color: #000; }\n" .
- "tr { padding: 0; }\n" .
- "th { background-color: #cbd2ec; color: #000; padding: 2px;\n" .
- " text-align: left; font-weight: normal; font-style: italic; }\n" .
- "td { color: #000; padding: 2px; }\n" .
- "td a { text-decoration: none; }\n" .
- ".o { background-color: #fff; }\n" .
- ".a { background-color: #cffafd; }\n" .
- ".f { background-color: #ffc; }\n" .
- ".p { background-color: #d1fbd6; }\n" .
- ".s { background-color: #fcccd9; }\n" .
- ".c { background-color: #c1d5db; }\n" .
- "--></style>";
-
-} else {
-
- $pr = ''; $pr_e = '';
- $h1 = ''; $h1_e = '';
- $h3 = ''; $h3_e = '';
- $hr = "\n----------------------------------------" .
- "---------------------------------------\n";
-
- $table = '';
- $table_e = '';
-}
-
-sub cgiparam {
- local ($result) = @_;
-
- $result =~ s/[^A-Za-z0-9+.@-]/"%".sprintf("%02X", unpack("C", $&))/ge;
- $result;
-}
-
-sub header_info {
- if ($html_mode) {
- print &html_header("Current $project problem reports");
- }
- else {
- print "Current $project problem reports\n";
- }
- if (!$input{'quiet'}) {
- print "The following is an old and incomplete of current problems submitted by $project users. ";
- if ($html_mode) {
- print <<EOM;
-<h1>FreeBSD has migrated to <a href="https://bugs.FreeBSD.org/search/">Bugzilla</a>. Please update your bookmarks and try your search there.</h1>
-EOM
- }
- }
-
- if ($html_mode) {
-
-# These self references are attempts to only change a single variable at a time.
-# If someone does a multiple-variable query they will probably do weird things.
-
-$self_ref1 = $self_ref . '?';
-$self_ref1 .= 'sort=' . html_fixline($input{'sort'}) if $input{'sort'};
-print "<p>You may view summaries by <a href='$self_ref1'>Severity</a>, ";
-$self_ref1 .= '&amp;' if ($self_ref1 !~/\?$/);
-print "<a href='${self_ref1}state=summary'>State</a>, ";
-print "<a href='${self_ref1}category=summary'>Category</a>, or ";
-print "<a href='${self_ref1}responsible=summary'>Responsible Party</a>.\n";
-
-$self_ref2 = $self_ref . '?';
-foreach ('category', 'originator', 'priority', 'class', 'responsible',
- 'severity', 'state', 'submitter', 'text', 'multitext', 'closedtoo') {
- if ($input{$_}) {
- $self_ref2 .= '&amp;' if ($self_ref2 !~/\?$/);
- $self_ref2 .= $_ . '=' . cgiparam($input{$_});
- }
-}
-
-print 'You may also sort by ';
-print "<a href='$self_ref2&amp;sort=lastmod'>Last-Modified</a>, ";
-print "<a href='$self_ref2&amp;sort=category'>Category</a>, or ";
-print "<a href='$self_ref2&amp;sort=responsible'>Responsible Party</a>.\n";
-print "Or <a href='$self_ref?query'>formulate a specific query</a>.\n";
-
-$self_ref3 = $self_ref . '?';
-foreach ('category', 'originator', 'priority', 'class', 'responsible',
- 'severity', 'state', 'submitter', 'text', 'multitext', 'sort') {
- if ($input{$_}) {
- $self_ref3 .= '&amp;' if ($self_ref2 !~/\?$/);
- $self_ref3 .= $_ . '=' . cgiparam($input{$_});
- }
-}
-
-if ($input{'closedtoo'}) {
- print "<a href='$self_ref3'>Do not show closed reports</a>.";
-} else {
- print "<a href='$self_ref3&amp;closedtoo=on'>Include closed reports too</a>.";
-}
-
-print "</p>\n";
-
- }
-}
-
-&header_info;
-
-#Usage: query-pr [-FGhiPRqVx] [-C confidential] [-c category] [-d directory]
-# [-e severity] [-m mtext] [-O originator] [-o outfile] [-p priority]
-# [-L class] [-r responsible] [-S submitter] [-s state] [-t text]
-# [-b date] [-a date] [-B date] [-M date] [-z date] [-Z date]
-# [-y synopsis] [-A release] [--full] [--help] [--print-path] [--version]
-# [--summary] [--sql] [--skip-closed] [--category=category]
-# [--confidential=yes|no] [--directory=directory] [--output=outfile]
-# [--originator=name] [--priority=level] [--class=class]
-# [--responsible=person] [--release=release] [--restricted]
-# [--quarter=quarter] [--keywords=regexp]
-# [--required-before=date] [--required-after=date]
-# [--arrived-before=date] [--arrived-after=date]
-# [--modified-before=date] [--modified-after=date]
-# [--closed-before=date] [--closed-after=date]
-# [--severity=severity] [--state=state] [--submitter=submitter]
-# [--list-categories] [--list-classes] [--list-responsible]
-# [--list-states] [--list-submitters] [--list-config]
-# [--synopsis=synopsis] [--text=text] [--multitext=mtext] [PR] [PR]...
-
-$query_args .= ' --skip-closed' unless $closed_too;
-
-# Only read the appropriate PR's.
-foreach ('category', 'originator', 'priority', 'class', 'responsible',
- 'release', 'severity', 'state', 'submitter', 'text', 'multitext') {
- if ($input{$_} && $input{$_} ne 'summary') {
- # Check if the arguments provided by user are secure.
- # This is required to be able to run this script in
- # taint mode (perl -T)
- if ($input{$_} =~ /^([-^'\/\[\]\@\s\w.]+)$/) {
- $d = $1;
- $d =~ s/^"(.*)"$/$&/;
- $d =~ s/'/\\'/;
- $query_args .= " --${_}='$d'";
- } else {
- print "Insecure data in ${_}! Ignoring this filter.<br />".
- "Only alphanumeric characters and ', /, -, [, ], ^, @ are allowed.";
- }
- }
-}
-
-&read_gnats($query_args);
-
-if ($input{'sort'} eq 'lastmod') {
- @prs = sort {$lastmod{$b} cmp $lastmod{$a}} @prs;
-} elsif ($input{'sort'} eq 'category') {
- @prs = sort {($ca,$na)=split(m|/|,$a); ($cb,$nb)=split(m|/|,$b); $ca eq $cb ? $na <=> $nb : $ca cmp $cb} @prs;
-} elsif ($input{'sort'} eq 'responsible') {
- @prs = sort {$resp{$a} cmp $resp{$b}} @prs;
-} else {
- $input{'sort'} = 'none';
-}
-
-if ($#prs < $[) {
- print "${h1}Please try <a href='https://bugs.FreeBSD.org/search/'>bugzilla</a> for an up to date search mechanism.${h1_e}\n";
-
-} elsif ($input{'responsible'} eq 'summary') {
- &resp_summary;
-
-} elsif ($input{'state'} eq 'summary') {
- &state_summary;
-
-} elsif ($input{'category'} eq 'summary') {
- &cat_summary;
-
-} elsif ($input{'severity'} eq '') {
- &severity_summary;
-
-} else {
- &printcnt(&gnats_summary(1, $html_mode));
-
-}
-
-print &html_footer if $html_mode;
-
-exit(0);
-
-#------------------------------------------------------------------------
-
-sub getline {
- local($_) = @_;
- ($tag,$remainder) = split(/[ \t]+/, $_, 2);
- return $remainder;
-}
-
-sub html_fixline {
- local($line) = @_[0];
-
- $line =~ s/&/&amp;/g;
- $line =~ s/</&lt;/g;
- $line =~ s/>/&gt;/g;
-
- $line;
-}
-
-sub printcnt {
- local($cnt) = $_[0];
-
- if ($cnt) {
- printf("%d problem%s total.\n\n", $cnt, $cnt == 1 ? '' : 's');
- }
-}
-
-sub cat_summary {
- &get_categories;
- foreach (keys %status) {
- s|/\d+||;
- $cat{$_}++;
- }
- foreach (@categories) {
- next unless $cat{$_}; # skip categories with no bugs.
- print "${h3}Problems in category: $_ ($catdesc{$_})${h3_e}\n";
- if (/^(\w+)/) {
- &printcnt(&gnats_summary("\$cat eq \"$1\"", $html_mode));
- } else {
- print "\n??? weird category $_\n";
- }
- }
-}
-
-sub resp_query {
- local($resp) = @_[0];
- local($cnt);
-
- $cnt = &gnats_summary("\$resp eq \"$resp\"", $html_mode);
- print "${hr}${b}No problem reports assigned to $resp${b_e}\n"
- if (!$input{"quiet"} && $cnt == 0);
-}
-
-sub resp_summary {
- local($who, %who);
-
- foreach (keys %resp) {
- $who{$resp{$_}}++;
- }
- foreach $who (sort keys %who) {
- $cnt = &gnats_summary("\$resp eq \"$who\"", $html_mode);
- }
-}
-
-sub state_summary {
- &get_states;
- foreach (@states) {
- next if ($_ eq "closed" && !$input{"closedtoo"});
- print "${h3}Problems in state: $_${h3_e}\n";
- if (/^(\w)/) {
- &printcnt(&gnats_summary("\$state eq \"$1\" ", $html_mode));
- } else {
- print "\n??? bad state $state\n";
- }
- }
-}
-
-sub severity_summary {
- print "${h3}Critical problems${h3_e}\n";
- &printcnt(&gnats_summary('$severity eq "critical"', $html_mode));
-
- print "${h3}Serious problems${h3_e}\n";
- &printcnt(&gnats_summary('$severity eq "serious"', $html_mode));
-
- print "${h3}Non-critical problems${h3_e}\n";
- &printcnt(&gnats_summary('$severity eq "non-critical"', $html_mode));
-}
-
-sub read_gnats {
- local($report) = @_[0];
-
- open(Q, "query-pr.web $report 2>/dev/null |") || die "Cannot query the PR's\n";
-
- while(<Q>) {
- chop;
- if(/^>Number:/) {
- $number = &getline($_);
-
- } elsif (/Arrival-Date:/) {
- $date = &getline($_);
- # strip timezone if any (between HH:MM:SS and YYYY at end of line):
- $date =~ s/(\d\d:\d\d:\d\d)\D+(\d{4})$/\1 \2/;
- ($dow,$mon,$day,$time,$year,$xtra) = split(/[ \t]+/, $date);
- $day = "0$day" if $day =~ /^[0-9]$/;
- $date = "$year/$mons{$mon}/$day";
-
- } elsif (/>Last-Modified:/) {
- $lastmod = &getline($_);
- if ($lastmod =~ /^[ ]*$/) {
- $lastmod = $date;
- } else {
- # strip timezone if any (between HH:MM:SS and YYYY at end of line):
- $lastmod =~ s/(\d\d:\d\d:\d\d)\D+(\d{4})$/\1 \2/;
- ($dow,$mon,$day,$time,$year,$xtra) = split(/[ \t]+/, $lastmod);
- $day = "0$day" if $day =~ /^[0-9]$/;
- $lastmod = "$year/$mons{$mon}/$day";
- }
-
- } elsif (/>Category:/) {
- $cat = &getline($_);
-
- } elsif (/>Severity:/) {
- $sev = &getline($_);
-
- } elsif (/>Responsible:/) {
- $resp = &getline($_);
- $resp =~ s/@.*//;
- $resp =~ tr/A-Z/a-z/;
- $resp = "" if (($resp =~ /$mail_unass/o) or ($resp =~ /$ports_unass/o));
- $resp =~ s/^$mail_prefix//;
-
- } elsif (/>State:/) {
- $status = &getline($_);
- $status =~ s/(.).*/\1/;
-
- } elsif (/>Synopsis:/) {
- $syn = &getline($_);
- $syn =~ s/[\t]+/ /g;
-
-
- } elsif (/^$/) {
- $_ = sprintf("%s/%s", $cat, $number);
-
- $status{$_} = $status;
- $date{$_} = $date;
- $resp{$_} = $resp;
- $syn{$_} = $syn;
- $sev{$_} = $sev;
- $lastmod{$_} = $lastmod;
- push(@prs,$_);
- }
- }
- close(Q);
-}
-
-sub gnats_summary {
- local($report) = @_[0];
- local($htmlmode) = @_[1];
- local($counter) = 0;
-
- foreach (@prs) {
- $state = $status{$_};
- $date = $date{$_};
- $resp = $resp{$_};
- $syn = $syn{$_};
- $severity = $sev{$_};
- ($cat, $number) = m|^([^/]+)/(\d+)$|;
-
- next if (($report ne '') && (eval($report) == 0));
-
- if ($htmlmode) {
- $title = "<a href='$query_pr_ref?pr=$cat/$number'>$_</a>";
- $syn = &html_fixline($syn);
- gnats_summary_line_html($counter, $state, $date, $title, $resp, $syn);
- } else {
- $title = $_;
- gnats_summary_line_text($counter, $state, $date, $title, $resp, $syn);
- }
-
- $counter++;
- }
-
- if ($htmlmode) {
- print "${table_e}\n" if $counter;
- } else {
- print "${pr_e}\n" if $counter;
- }
-
- $counter;
-}
-
-sub gnats_summary_line_html {
- local($counter) = shift;
- local($state) = shift;
- local($date) = shift;
- local($title) = shift;
- local($resp) = shift;
- local($syn) = shift;
-
- if ($counter == 0) {
- print "$table<tr><th>S</th><th>Submitted</th><th>Tracker</th><th>Resp.</th><th>Description</th></tr>\n"
- }
-
- print "<tr class='$state'><td>$state</td><td>$date</td><td>$title</td><td>$resp</td><td>$syn</td></tr>\n";
-}
-
-sub gnats_summary_line_text {
- local($counter) = shift;
- local($state) = shift;
- local($date) = shift;
- local($title) = shift;
- local($resp) = shift;
- local($syn) = shift;
-
- # Print the banner line if this is the first iteration.
- print "${pr}\nS Submitted Tracker Resp. Description${hr}"
- if ($counter == 0);
- print "$state $date $title" .
- (' ' x (17 - length($_))) .
- $resp . (' ' x (10 - length($resp))) .
- substr($syn,0,39) . "\n";
-}
Index: htdocs/cgi/query-pr.cgi
===================================================================
--- htdocs/cgi/query-pr.cgi
+++ htdocs/cgi/query-pr.cgi
@@ -1,858 +0,0 @@
-#!/usr/bin/perl -Tw
-#------------------------------------------------------------------------------
-# GNATS query-pr Interface, Generation III
-#
-# Copyright (C) 2006-2011, Shaun Amott <shaun@FreeBSD.org>
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $FreeBSD$
-#
-# Useful PRs for testing:
-#
-# - ports/147261 - RFC 2047 words, attachments, interjected e-mail (inc.
-# malformed header)
-# - ports/138672 - Lots of attachments, multi-level MIME.
-# - ports/132344 - Base64-encoded attachment.
-#------------------------------------------------------------------------------
-
-BEGIN { push @INC, '.'; }
-
-use CGI;
-
-use GnatsPR;
-use GnatsPR::SectionIterator;
-use GnatsPR::MIMEIterator;
-
-#use MIME::EncWords (decode_mimewords); # mail/p5-MIME-EncWords
-sub decode_mimewords { wantarray ? @_ : join ' ', @_; } # Temp. substitute for the above
-
-require './cgi-style.pl';
-require './query-pr-lib.pl';
-
-use strict;
-
-
-#------------------------------------------------------------------------------
-# Constants
-#------------------------------------------------------------------------------
-
-use constant EXIT_NOPRS => 1;
-use constant EXIT_DBBUSY => 2;
-use constant EXIT_NOPATCH => 3;
-
-
-#------------------------------------------------------------------------------
-# Globals
-#------------------------------------------------------------------------------
-
-our $valid_category = '[a-z0-9][A-Za-z0-9-_]{1,25}';
-our $valid_pr = '\d{1,8}';
-
-our $stylesheet = "$main::hsty_base/layout/css/query-pr.css";
-
-our $iscgi = defined $ENV{'SCRIPT_NAME'};
-
-# Keep this ahead of CGI
-
-if (!$iscgi && !exists $ENV{'REQUEST_METHOD'}) {
- # Makes debugging easier
- $ENV{'REQUEST_METHOD'} = 'GET';
-}
-
-# Stuff from cgi-style.pl
-
-$main::hsty_base ||= '';
-$main::t_style ||= '';
-$main::hsty_charset ||= '';
-
-$main::hsty_charset = 'utf-8';
-
-$main::t_style =
-qq{<link href="$stylesheet" rel="stylesheet" type="text/css" />
-<link rel="search" type="application/opensearchdescription+xml"
- href="http://www.freebsd.org/search/opensearch/query-pr.xml"
- title="FreeBSD Bugs" />
-};
-
-# Global CGI accessor
-
-our $q = new CGI;
-
-
-#------------------------------------------------------------------------------
-# Environment vars
-#------------------------------------------------------------------------------
-
-$ENV{'PATH'} = '/bin:/usr/bin:/usr/sbin:/sbin:/usr/local/bin';
-
-$ENV{'SCRIPT_NAME'} ||= $0;
-
-
-#------------------------------------------------------------------------------
-# Begin Code
-#------------------------------------------------------------------------------
-
-main();
-
-
-#------------------------------------------------------------------------------
-# Main routine
-#------------------------------------------------------------------------------
-
-sub main
-{
- my ($PR, $category, $rawdata, $gnatspr);
-
- binmode STDOUT, ':utf8';
-
- if ($q->param('pr')) {
- $PR = $q->param('pr');
- } elsif ($q->param('q')) {
- $PR = $q->param('q');
- } elsif ($q->param('prp')) {
- # Legacy param format
- my $prp = $q->param('prp');
-
- if ($prp =~ /^(\d+)-(\d+)/) {
- my $get = $2;
- $PR = $1;
-
- $q->param(-name => 'pr', -value => $PR);
- $q->param(-name => 'getpatch', -value => $get);
- } else {
- ErrorExit();
- }
- } else {
- ErrorExit(EXIT_NOPRS);
- }
-
- if ($PR =~ /^($valid_category)\/($valid_pr)$/) {
- $category = $1;
- $PR = $2;
- }
-
- length $PR > 0
- or ErrorExit();
-
- # category may be undef
- $rawdata = DoQueryPR($PR, $category);
-
- # Dump the raw PR data if requested
- if ($q->param('f') && $q->param('f') eq 'raw') {
- print "Content-type: text/plain; charset=UTF-8\r\n\r\n";
- print $$rawdata;
- Exit();
- }
-
- # Run PR text through the parser
- $gnatspr = GnatsPR->new($rawdata);
-
- # User is requesting a patch extraction?
- if ($q->param('getpatch')) {
- my ($patch, $patchnum);
-
- $patchnum = $q->param('getpatch');
- $patchnum =~ s/[^0-9]+//g;
-
- $patch = $gnatspr->GetAttachment($patchnum);
-
- defined $patch
- or ErrorExit(EXIT_NOPATCH);
-
- printf 'Content-type: %s; charset=UTF-8'."\r\n",
- ($patch->isbinary ? 'application/octet-stream' : 'text/plain');
-
- printf 'Content-Length: %s'."\r\n"
- . 'Content-Disposition: inline; filename="%s"'."\r\n\r\n",
- $patch->size,
- $patch->filename;
-
- print $patch->data;
- print "\n";
-
- Exit();
- }
-
- # Otherwise, output PR
-
- PrintPR($gnatspr);
-
- Exit();
-}
-
-
-#------------------------------------------------------------------------------
-# Func: DoQueryPR()
-# Desc: Invoke the query-pr binary and return the results as a blob of text.
-# Exits gracefully on failure.
-#
-# Args: $PR - PR number
-# $cat - PR category (optional)
-#
-# Retn: \$data - Ref. to raw data.
-#------------------------------------------------------------------------------
-
-sub DoQueryPR
-{
- my ($PR, $cat) = @_;
- my ($data);
-
- $PR =~ s/[^0-9]+//g;
- $PR = quotemeta $PR;
-
- # Note: query-pr.web is just an anti DoS wrapper around query-pr which
- # makes sure we do not run too many query-pr instances at once.
- if (defined $cat) {
- $cat =~ s/[^0-9A-Za-z-]+//g;
- $cat = quotemeta $cat;
- $data = qx(query-pr.web --full --category=${cat} ${PR} 2>&1);
- } else {
- $data = qx(query-pr.web --full ${PR} 2>&1);
- }
-
- if (!$data or $data =~ /^query-pr(:?\.(:?real|web))?: /) {
- ErrorExit(EXIT_NOPRS);
- } elsif ($data =~ /^lockf: /) {
- ErrorExit(EXIT_DBBUSY);
- }
-
- return \$data;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: PrintPR()
-# Desc: Output the parsed PR.
-#
-# Args: $gnatspr - GnatsPR instance.
-#
-# Retn: n/a
-#------------------------------------------------------------------------------
-
-sub PrintPR
-{
- my ($gnatspr) = @_;
-
- # Page title
-
- print html_header(
- "FreeBSD has migrated to Bugzilla. Please check the current <a href='https://bugs.FreeBSD.org/"
- . $gnatspr->FieldSingle('Number') . "'/>Bugzilla version</a> of this PR."
- );
- print "<h3>The historical version shown below is likely out of date and is for debugging purposes only!</h3>\n";
-
- print "<h3>" .
- $q->escapeHTML(
- $gnatspr->FieldSingle('Category')
- . '/'
- . $gnatspr->FieldSingle('Number')
- . ': '
- . $gnatspr->FieldSingle('Synopsis')
- ) . "</h3>\n";
-
- # Header stuff of interest
-
- print $q->start_table({-class => 'headtable'});
-
- foreach my $field ('From', 'Date', 'Subject') {
- my $val = $q->escapeHTML(
- scalar decode_mimewords($gnatspr->Header($field))
- );
- print $q->Tr(
- $q->td({-class => 'key'}, $field . ':'),
- $q->td({-class => 'val'}, $val)
- )
- }
-
- print $q->Tr(
- $q->td({-class => 'key'}, 'Send-pr version:'),
- $q->td({-class => 'val'}, $q->escapeHTML($gnatspr->Header('x-send-pr-version')))
- );
-
- print $q->end_table;
-
- # Single fields
-
- print $q->start_table({-class => 'headtable'});
-
- foreach my $field (
- 'Number',
- 'Category',
- 'Synopsis',
- 'Severity',
- 'Priority',
- 'Responsible',
- 'State',
- 'Class',
- 'Arrival-Date',
- 'Closed-Date',
- 'Last-Modified',
- 'Originator',
- 'Release'
- ) {
- my $val = $q->escapeHTML($gnatspr->FieldSingle($field));
- print $q->Tr(
- $q->td({-class => 'key'}, $field . ":"),
- $q->td({-class => 'val'}, $val)
- );
- }
-
- print $q->end_table;
-
- # Sections
-
- my $iter = GnatsPR::SectionIterator->new(
- $gnatspr,
- # Fields we want sections from; this also
- # dictates the order they will come.
- 'Organization',
- 'Environment',
- 'Description',
- 'How-To-Repeat',
- 'Fix',
- 'Release-Note',
- 'Audit-Trail',
- 'Unformatted'
- );
-
- my $replynum = 0;
- my $patchnum = 0;
-
- while (my $item = $iter->next()) {
- # Start of new field
- if (ref $item eq 'GnatsPR::Section::FieldStart') {
- my $text = $item->string();
- $text = $q->escapeHTML($text);
- #print $q->h2($text);
- print $q->table({-class => 'mfieldtable'},
- $q->Tr($q->td({-class => 'blkhead'}, $text)));
- next;
- }
-
- # A chunk of text
- if (ref $item eq 'GnatsPR::Section::Text') {
- my $text = $item->string();
- $text = $q->escapeHTML($text);
- $text = Linkify($text);
- $text = AddBreaks($text);
-
- # Table used to ensure text CSS consistency (evil, I know)
- print $q->table($q->tbody($q->Tr($q->td({class => 'mfield'}, $text))))
- if $text;
- #print $q->p($text);
-
- next;
- }
-
- # Patch block
- if (ref $item eq 'GnatsPR::Section::Patch') {
- my $text = $item->string();
- $text = $q->escapeHTML($text);
- $text = ColourPatch($text)
- if ($item->type eq 'diff');
- $text = AddBreaks($text); # Unless binary
-
- print AttachmentHeader($item->{filename}, ++$patchnum);
- print $text;
- print AttachmentFooter();
-
- next;
- }
-
- # Audit-Trail state/responsible change block
- if (ref $item eq 'GnatsPR::Section::StateChange') {
- # This must be hard-coded - the old value will still
- # linger in PRs, even if the script moves.
- my $selfurl = "http://www.freebsd.org/cgi/query-pr.cgi?pr="
- . $gnatspr->FieldSingle('Number');
-
- # Remove the URL, as it is merely clutter
- my $why = $item->why;
- $why =~ s/[\n\s]*\Q$selfurl\E[\n\s]*$//i;
- $item->why($why);
-
- print $q->table({-class => 'auditblock', -cellspacing => '1'},
- $q->Tr(
- $q->th(
- {-colspan => 2, -class => 'info'},
- $q->escapeHTML($item->what) . " Changed"
- )
- ),
-
- $q->Tr(
- $q->td({-class => 'key'}, 'From-To:'),
- $q->td(
- $q->escapeHTML(
- $item->from . '->' . $item->to
- )
- )
- ),
-
- $q->Tr(
- $q->td({-class => 'key'}, 'By:'),
- $q->td($q->escapeHTML($item->by))
- ),
-
- $q->Tr(
- $q->td({-class => 'key'}, 'When:'),
- $q->td($q->escapeHTML($item->when))
- ),
-
- $q->Tr(
- $q->td({-class => 'key'}, 'Why:'),
- AddBreaks($q->td($q->escapeHTML($item->why)))
- )
- );
-
- next;
- }
-
- # Reply via E-mail
- if (ref $item eq 'GnatsPR::Section::Email') {
- print $q->start_table({-class => 'replyblock',
- -cellspacing => '1'});
-
- $replynum++;
-
- print $q->Tr($q->th(
- {-colspan => 2, -class => 'info'},
- 'Reply via E-mail '
- . $q->a({href => '#reply'.$replynum,
- name => 'reply'.$replynum}, '[Link]')
- ));
-
- # Try to determine if sender is submitter
-
- my $fromtag = FromSubmitter($item, $gnatspr)
- ? $q->b('&nbsp;[submitter]') : '';
-
- # Print header
-
- foreach my $f ('From', 'To', 'Date') {
- print $q->Tr(
- $q->td({-class => 'key'}, $f . ':'),
- $q->td({-class => 'val'},
- $q->escapeHTML(
- scalar decode_mimewords($item->Header($f))
- )
- .
- (($f eq 'From') ? $fromtag : '')
- )
- );
- }
-
- print $q->start_Tr;
- print $q->start_td({-colspan => 2});
-
- # MIME parts
-
- my $mime_iter = GnatsPR::MIMEIterator->new($item);
-
- while (my $part = $mime_iter->next()) {
- my $ctype = $part->header('content-type');
- my $elide = 0;
-
- print $q->hr({-class => 'mimeboundary'})
- unless ($mime_iter->isfirst);
-
- $part->isattachment
- and ++$patchnum;
-
- # Skip (inline) HTML parts -- but only if we have
- # a plaintext part. We could possibly be a bit more
- # rigorous in verifying the existence of the latter,
- # but testing for the MIME header or other part will
- # suffice, as it is unlikely a HTML-only e-mail will
- # have more than that single part.
- if ($ctype eq 'text/html' && !$part->isattachment &&
- !$mime_iter->isfirst) {
- $elide = 1;
-
- # S/MIME signatures - of questionable value here
- } elsif ($ctype eq 'application/pkcs7-signature') {
- $elide = 1;
- }
-
- if ($elide) {
- if ($part->isattachment) {
- my $url = $q->url(-full => 1, -query => 1);
-
- my $dlink =
- $q->a({-href => $url . '&getpatch=' . $patchnum},
- '[Download]');
-
- print $q->div(
- {-class => 'elidemsg'},
- 'Attachment of type "' . $q->escapeHTML($ctype)
- . '" ' . $dlink
- );
- } else {
- print $q->div(
- {-class => 'elidemsg'},
- 'MIME part of type "' . $q->escapeHTML($ctype)
- . '" elided'
- );
- }
-
- next;
- }
-
- $part->isattachment
- and print AttachmentHeader($part->filename, $patchnum);
-
- if ($part->isbinary) { # Implies isattachment
- print $q->escapeHTML($part->body);
- } else {
- my $text;
-
- if ($part->header('content-type') eq 'text/plain'
- && !$part->isattachment) {
- # ColourEmail escapes too
- $text = Linkify(ColourEmail($part->data));
- } else {
- $text = $q->escapeHTML($part->data);
- }
-
- if ($part->isattachment
- && $part->filename =~ /\.(?:diff|patch)\b/i) {
- $text = ColourPatch($text);
- }
-
- print AddBreaks($text);
- }
-
- $part->isattachment
- and print AttachmentFooter();
- }
-
- print $q->end_td;
- print $q->end_Tr;
- }
-
- print $q->end_table;
- }
-
- print FooterLinks($gnatspr);
-
- print html_footer();
-}
-
-
-#------------------------------------------------------------------------------
-# Func: AddBreaks()
-# Desc: Convert newlines to HTML break elements.
-#
-# Args: $text - Input
-#
-# Retn: $text - Output
-#------------------------------------------------------------------------------
-
-sub AddBreaks
-{
- my $text = shift;
-
- $text =~ s/\n/<br \/>/g;
-
- return $text;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: Linkify()
-# Desc: Perform any fancy formatting on the message (e.g. HTML-ify URLs) and
-# return the result.
-#
-# Args: $html - Input string
-#
-# Retn: $html - Output string
-#------------------------------------------------------------------------------
-
-sub Linkify
-{
- my ($html) = @_;
-
- # XXX: clean up
-
- $html or return '';
-
- my $iv = 'A-Za-z0-9\-_\/#@\$=\\\\';
-
- my $scriptname = $q->escapeHTML($ENV{'SCRIPT_NAME'});
-
- # PR references
- $html =~
- s/(?<![$iv])($valid_category)\/($valid_pr)(?![$iv])/<a href="${scriptname}?pr=$2&cat=$1">$1\/$2<\/a>/g;
-
- # URLs
- $html =~
- s/((?:https?|ftps?):\/\/[^\s\/]+\/[][\w=.,\'\(\)\~\?\!\&\/\%\$\{\}:;@#+-]*)/<a href="$1">$1<\/a>/g;
-
- return $html;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: ColourPatch()
-# Desc: Apply 'cdiff' style colours to a patch.
-#
-# Args: $html - Input string
-#
-# Retn: $html - Output string
-#------------------------------------------------------------------------------
-
-sub ColourPatch
-{
- my ($html) = @_;
- my $res = '';
-
- # XXX: clean up
-
- my $plus_s = $q->start_span({-class => 'patch_plusline'});
- my $minus_s = $q->start_span({-class => 'patch_minusline'});
- my $context_s = $q->start_span({-class => 'patch_contextline'});
- my $revinfo_s = $q->start_span({-class => 'patch_revinfo'});
- my $at_s = $q->start_span({-class => 'patch_hunkinfo'});
- my $all_e = $q->end_span;
-
- # Expand tabs
- while ($html =~ s/\t/" " x (8 - ((length($`)-1) % 8))/e) {};
-
- foreach my $line (split /\n/, $html) {
- $line =~ s/^(\+.*)$/${plus_s}$1${all_e}/o;
- $line =~ s/^(-.*)$/${minus_s}$1${all_e}/o
- if $line !~ s/^(--- \d+,\d+ ----.*)$/${revinfo_s}$1${all_e}/o;
- $line =~ s/^(\*\*\* \d+,\d+ *\*\*\*.*)$/${revinfo_s}$1${all_e}/o;
- $line =~ s/^(\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*)$/${revinfo_s}$1${all_e}/o;
- $line =~ s/^(!.*)$/${context_s}$1${all_e}/o;
- $line =~ s/^(@@.*$)/${at_s}$1${all_e}/o;
- $line =~ s/^ /&nbsp;/;
- $res .= "$line\n";
- }
-
- $res =~ s/\n$//;
-
- return $res;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: ColourEmail()
-# Desc: Colourise quoting levels in e-mails, and escape.
-#
-# Args: $email - Input string
-#
-# Retn: $email - Output string
-#------------------------------------------------------------------------------
-
-sub ColourEmail
-{
- my ($email) = @_;
-
- my $result = '';
-
- foreach my $line (split /\n/, $email) {
- if ($line =~ /^\s*((?:>\s*)+)(.*)$/) {
- my $levels = $1;
- my $text = $2;
- my $depth;
-
- $depth = $levels;
- $depth =~ s/[^>]+//g;
- $depth = length $depth;
-
- $levels =~ s/>/&gt;/g;
-
- # Vim style rather than mutt
-
- $result .= $q->span({
- -class => 'quote' . ($depth % 2 ? 0 : 1)
- }, $levels . $q->escapeHTML($text));
- } else {
- $result .= $q->escapeHTML($line);
- }
- $result .= "\n";
- }
-
- return $result;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: Exit()
-# Desc: Exit script.
-#
-# Args: n/a
-#
-# Retn: n/a
-#------------------------------------------------------------------------------
-
-sub Exit
-{
- # Introduce a short delay, as a DoS protection measure
- select undef, undef, undef, 0.35
- unless !$iscgi;
-
- exit;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: ErrorExit()
-# Desc: Print an error message and exit.
-#
-# Args: $code - EXIT_* code
-#
-# Retn: n/a
-#------------------------------------------------------------------------------
-
-sub ErrorExit
-{
- my ($code) = @_;
-
- my $url = $q->url(-full => 1, -query => 1);
-
- if ($code == EXIT_NOPRS) {
- print html_header("FreeBSD has migrated to <a href='https://bugs.FreeBSD.org/search/'>Bugzilla</a>. Try your search there.");
- print html_footer();
- } elsif ($code == EXIT_DBBUSY) {
- print html_header("PR Database Busy");
- print $q->p(
- 'Please '
- . $q->a({-href => $url}, 'try again')
- . ' later'
- );
- print html_footer();
- } elsif ($code == EXIT_NOPATCH) {
- print "Content-type: text/plain; charset=UTF-8\r\n\r\n";
- print "No such patch!\n";
- }
-
- Exit();
-}
-
-
-#------------------------------------------------------------------------------
-# Func: FromSubmitter()
-# Desc: Try determine if the sender of a reply is the sender of the PR.
-#
-# Args: $item - GnatsPR::Section::Email instance.
-# $gnatspr - GnatsPR instance
-#
-# Retn: $result - Is sender the submitter?
-#------------------------------------------------------------------------------
-
-sub FromSubmitter
-{
- my ($item, $gnatspr) = @_;
-
- my $from = lc $item->Header('From');
- my $submitter = lc $gnatspr->Header('From');
-
- $from =~ s/^.*<// and $from =~ s/>.*$//;
- $from =~ s/\s+//g;
- $submitter =~ s/^.*<// and $submitter =~ s/>.*$//;
- $submitter =~ s/\s+//g;
-
- return $from eq $submitter;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: AttachmentHeader()
-# Desc: Construct an attachment block header.
-#
-# Args: $filename - Name of attachment.
-# $patchnum - Patch index.
-#
-# Retn: $text - Header text.
-#------------------------------------------------------------------------------
-
-sub AttachmentHeader
-{
- my ($filename, $patchnum) = @_;
-
- my $text = '';
-
- my $url = $q->url(-full => 1, -query => 1);
-
- $text .= $q->start_table({-class => 'patchblock', -cellspacing => '1'});
- $text .=
- $q->Tr(
- $q->td({-class => 'info'}, $q->b(
- 'Download ' . $q->a({-href => $url . '&getpatch=' . $patchnum},
- $filename)
- ))
- );
-
- $text .= $q->start_tbody;
- $text .= $q->start_Tr;
- $text .= $q->start_td({-class => 'content'});
- $text .= $q->start_pre({-class => 'attachwin'});
-
- return $text;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: AttachmentFooter()
-# Desc: Construct an attachment block footer.
-#
-# Args: n/a
-#
-# Retn: $text - Footer text.
-#------------------------------------------------------------------------------
-
-sub AttachmentFooter
-{
- my $text = '';
-
- $text .= $q->end_pre;
- $text .= $q->end_td;
- $text .= $q->end_Tr;
- $text .= $q->end_tbody;
- $text .= $q->end_table;
-
- return $text;
-}
-
-
-#------------------------------------------------------------------------------
-# Func: FooterLinks()
-# Desc: Construct the page footer links (for a valid PR page)
-#
-# Args: $gnatspr - GnatsPR instance.
-#
-# Retn: $text - Footer text.
-#------------------------------------------------------------------------------
-
-sub FooterLinks
-{
- my ($gnatspr) = @_;
-
- my $url = $q->url(-full => 1, -query => 1);
-
- return $q->div({-class => 'footerlinks'},
- $q->a({-href => $url . '&f=raw'}, 'Raw PR')
- );
-}

File Metadata

Mime Type
text/plain
Expires
Wed, Aug 12, 8:07 PM (18 h, 58 m)
Storage Engine
blob
Storage Format
Raw Data
Storage Handle
29399899
Default Alt Text
D2355.1786565257.diff (104 KB)

Event Timeline