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 -# 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 -# 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 -# 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 -# 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 -# 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 -# 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 -# 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 -# 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 -# 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 -# 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 "

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.
", - "Report $_[0].

"; - print end_html(); - exit (1); -} - -sub piloterror { - print start_html("Problem Report Error"); - print "

There is an error with your problem\n", - "report submission.\n", - "The problem was: $_[0].

"; - 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("

Patch file has wrong content type: got " . - uploadInfo($patchhandle)->{'Content-Type'} . - " but was expecting one matching text/.* or application/shar.

" . - "

Try renaming the file to have a .txt extension" . - " to convince your browser to do the right thing.

"); - } - 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 "

Bad Data

You need to specify at least your ", - "electronic mail address, your name and a synopsis ", - "of the problem.
Please return to the form and add the ", - "missing information. Thank you.

"; - print end_html(); - - exit(1); - } -} else { - print start_html("Problem Report Error"); - print "

Incorrect confirmation code

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.

"; - 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 "

Thank You

", - "

Thank you for the problem report. You should receive confirmation", - " of your report by electronic mail within a day.

"; -} else { - print start_html("Error raising problem report"); - print "

Error

An error occured processing your problem report.

"; -} -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() { - 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() { - 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() { - chop; - local ($class, $type, $desc) = split(/:/); - push(@classes, $class); - $classdesc{$class} = $desc; - } -} - -sub displayform { -print qq` -

To query the GNATS Database for specific PR number, please fill in -this form:

-
- - - - -
PR number:
Category: (optional)
-
-
- -

Alternatively, it is possible to select items you wish to search for. -Multiple items are AND'ed together.
-To generate current list of all open PRs in GNATS database, just press -the "Query PRs" button. -

-
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Category:Severity:
Priority:Class:
State:Sort by:
Text in single-line fields:Responsible:
Text in multi-line fields:Originator:
Closed reports too:Release:
-
-
-`; -} - -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 = '
';    $pr_e = '
'; - $h1 = '

'; $h1_e = '

'; - $h3 = '

'; $h3_e = '

'; - $hr = '
'; - - $table = ""; - $table_e = '
'; - - # Customizations for the look and feel of the summary tables. - $t_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 <FreeBSD has migrated to Bugzilla. Please update your bookmarks and try your search there. -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 "

You may view summaries by Severity, "; -$self_ref1 .= '&' if ($self_ref1 !~/\?$/); -print "State, "; -print "Category, or "; -print "Responsible Party.\n"; - -$self_ref2 = $self_ref . '?'; -foreach ('category', 'originator', 'priority', 'class', 'responsible', - 'severity', 'state', 'submitter', 'text', 'multitext', 'closedtoo') { - if ($input{$_}) { - $self_ref2 .= '&' if ($self_ref2 !~/\?$/); - $self_ref2 .= $_ . '=' . cgiparam($input{$_}); - } -} - -print 'You may also sort by '; -print "Last-Modified, "; -print "Category, or "; -print "Responsible Party.\n"; -print "Or formulate a specific query.\n"; - -$self_ref3 = $self_ref . '?'; -foreach ('category', 'originator', 'priority', 'class', 'responsible', - 'severity', 'state', 'submitter', 'text', 'multitext', 'sort') { - if ($input{$_}) { - $self_ref3 .= '&' if ($self_ref2 !~/\?$/); - $self_ref3 .= $_ . '=' . cgiparam($input{$_}); - } -} - -if ($input{'closedtoo'}) { - print "Do not show closed reports."; -} else { - print "Include closed reports too."; -} - -print "

\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.
". - "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 bugzilla 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/&/&/g; - $line =~ s//>/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() { - 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 = "$_"; - $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 "$tableSSubmittedTrackerResp.Description\n" - } - - print "$state$date$title$resp$syn\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 -# 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{ - -}; - -# 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 Bugzilla version of this PR." - ); - print "

The historical version shown below is likely out of date and is for debugging purposes only!

\n"; - - print "

" . - $q->escapeHTML( - $gnatspr->FieldSingle('Category') - . '/' - . $gnatspr->FieldSingle('Number') - . ': ' - . $gnatspr->FieldSingle('Synopsis') - ) . "

\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(' [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/
/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/(?$1\/$2<\/a>/g; - - # URLs - $html =~ - s/((?:https?|ftps?):\/\/[^\s\/]+\/[][\w=.,\'\(\)\~\?\!\&\/\%\$\{\}:;@#+-]*)/$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/^ / /; - $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/>/>/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 Bugzilla. 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/^.*.*$//; - $from =~ s/\s+//g; - $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') - ); -}