Tidy up some loose ends that no longer work after the apache-1.x server on
hub.freebsd.org and the supporting 15 year old binaries have gone away. Highlights: - Sync up the cgi scripts to be closer to the standard page look and feel and the canonical url locations. - Adjust the search controls to include the docs.freebsd.org doc set. - Replace the remaining wais search references. - Fix up the embedded paths that depended on a symlink and/or nfs jungle on hub. These aren't present in the jail this now runs in. - Fix a typo (stray backtick) in one of the header entities. - Remove the remaining no-longer-functional gnats components - they ran on hub and no longer exist. Build tested by: gjb Brought to you by: lots of coffee, profanity and confusion.
This commit is contained in:
Peter Wemm
parent
349ae4118b
commit
e984dc3473
Notes:
svn2git
2020-12-08 03:00:23 +00:00
svn path=/head/; revision=46874
37 changed files with 28 additions and 5136 deletions
|
|
@ -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;
|
||||
|
|
@ -1,641 +0,0 @@
|
|||
#!/usr/bin/perl -Tw
|
||||
#------------------------------------------------------------------------------
|
||||
# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
|
||||
# All rights reserved.
|
||||
#
|
||||
# Redistribution and use in source and binary forms, with or without
|
||||
# modification, are permitted provided that the following conditions
|
||||
# are met:
|
||||
# 1. Redistributions of source code must retain the above copyright
|
||||
# notice, this list of conditions and the following disclaimer.
|
||||
# 2. Redistributions in binary form must reproduce the above copyright
|
||||
# notice, this list of conditions and the following disclaimer in the
|
||||
# documentation and/or other materials provided with the distribution.
|
||||
#
|
||||
# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
|
||||
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
|
||||
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
||||
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||||
# SUCH DAMAGE.
|
||||
#
|
||||
# $FreeBSD$
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
package GnatsPR;
|
||||
|
||||
#use MIME::Base64; # ports/converters/p5-MIME-Base64
|
||||
#use MIME::QuotedPrint; #
|
||||
#use Convert::UU qw(uudecode uuencode); # ports/converters/p5-Convert-UU
|
||||
|
||||
use GnatsPR::Section::Text;
|
||||
use GnatsPR::Section::Patch;
|
||||
use GnatsPR::Section::Email;
|
||||
use GnatsPR::Section::StateChange;
|
||||
use GnatsPR::Section::FieldStart;
|
||||
|
||||
use GnatsPR::SectionIterator;
|
||||
|
||||
use strict;
|
||||
|
||||
require 5.006;
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Constants
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
use constant ENCODING_BASE64 => 1;
|
||||
use constant ENCODING_QP => 2;
|
||||
|
||||
use constant PATCH_ANY => 0x0001;
|
||||
use constant PATCH_DIFF => 0x0002;
|
||||
use constant PATCH_UUENC => 0x0004;
|
||||
use constant PATCH_UUENC_BIN => 0x0008;
|
||||
use constant PATCH_SHAR => 0x0010;
|
||||
use constant PATCH_BASE64 => 0x0020;
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: new()
|
||||
# Desc: Constructor - Parses data if provided.
|
||||
#
|
||||
# Args: [data] - Raw data (or ref. to) from query-pr (optional)
|
||||
#
|
||||
# Retn: $self
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my ($data) = @_;
|
||||
|
||||
my $self = {
|
||||
blobs_single => {}, # Raw text, single-line fields
|
||||
blobs_multi => {}, # Raw text, multi-line fields
|
||||
header => {}, # E-mail header bits
|
||||
sections => {}, # Hash of arrayrefs of sections
|
||||
fromwebform => 0, # PR came from the web form?
|
||||
numfields => 0 # Number of fields we have
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
if (defined $data) {
|
||||
ref $data
|
||||
? $self->Parse($data)
|
||||
: $self->Parse(\$data);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: Header()
|
||||
# Desc: Return a value from the header hash.
|
||||
#
|
||||
# Args: $key - Header name, case insensitive.
|
||||
#
|
||||
# Retn: $val - Value.
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub Header
|
||||
{
|
||||
my $self = shift;
|
||||
my ($key) = @_;
|
||||
|
||||
return $self->{header}->{lc $key};
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: FieldSingle()
|
||||
# Desc: Return a single line field value.
|
||||
#
|
||||
# Args: $key - Field name.
|
||||
#
|
||||
# Retn: $val - Value.
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub FieldSingle
|
||||
{
|
||||
my $self = shift;
|
||||
my ($key) = @_;
|
||||
|
||||
return $self->{blobs_single}->{$key};
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: Parse()
|
||||
# Desc: Parse a blob of text from query-pr into a structured unit for easy
|
||||
# manipulation.
|
||||
#
|
||||
# Args: \$data - Raw data from query-pr (non-ref scalar is acceptable too).
|
||||
#
|
||||
# Retn: n/a
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub Parse
|
||||
{
|
||||
my $self = shift;
|
||||
my ($data) = @_;
|
||||
|
||||
my $ismulti = 0;
|
||||
my $pastheader = 0;
|
||||
|
||||
# GNATS ensures that > isn't allowed as the first
|
||||
# character on a line, except for field headers.
|
||||
# Any lines beginning with > will be shunted into
|
||||
# 'Unformatted'
|
||||
my @fieldblobs = split /\n>(?!\s)/m, $$data;
|
||||
|
||||
# In the rare case the Unformatted field did
|
||||
# have some debris, be sure to assemble it back
|
||||
# into a complete section.
|
||||
while ($fieldblobs[$#fieldblobs] !~ /^Unformatted:/) {
|
||||
my $last = pop @fieldblobs;
|
||||
exists $fieldblobs[$#fieldblobs] or last;
|
||||
$fieldblobs[$#fieldblobs] .= $last;
|
||||
}
|
||||
|
||||
foreach my $blob (@fieldblobs) {
|
||||
my $key;
|
||||
|
||||
# Parse e-mail header; we only care about a few
|
||||
# fields, not the e-mail routing stuff.
|
||||
if (!$pastheader) {
|
||||
foreach my $line (split /\n/, $blob) {
|
||||
if ($line =~ /^(\S+):\s*(.*)$/) {
|
||||
my $val = $2;
|
||||
$key = lc $1;
|
||||
|
||||
# Ignore multiple defs (e.g. Received: headers)
|
||||
exists $self->{header}->{$key}
|
||||
and next;
|
||||
|
||||
$self->{header}->{$key} = $val;
|
||||
} elsif ($line =~ /^\s+(.*)$/) {
|
||||
my $val = $1;
|
||||
|
||||
defined $key
|
||||
or next;
|
||||
|
||||
# No field to append to
|
||||
exists $self->{header}->{$key}
|
||||
or next;
|
||||
|
||||
$self->{header}->{$key} .= "\n$val";
|
||||
}
|
||||
}
|
||||
|
||||
$pastheader = 1;
|
||||
next;
|
||||
}
|
||||
|
||||
if ($blob =~ s/^([^:]+):(\n|\s*)//) {
|
||||
$key = $1;
|
||||
#$ismulti = ($2 and $2 eq "\n");
|
||||
|
||||
# It's multi-liners from here on in
|
||||
$key eq 'Organization'
|
||||
and $ismulti = 1;
|
||||
} else {
|
||||
# Hmm...
|
||||
next;
|
||||
}
|
||||
|
||||
# Remove leading/trailing whitespace
|
||||
$blob =~ s/^[\n\s]+//;
|
||||
$blob =~ s/[\n\s]+$//;
|
||||
|
||||
if ($ismulti) {
|
||||
$self->{blobs_multi}->{$key} = $blob;
|
||||
} else {
|
||||
$self->{blobs_single}->{$key} = $blob;
|
||||
}
|
||||
}
|
||||
|
||||
$self->{numfields} = scalar @fieldblobs;
|
||||
|
||||
$self->{fromwebform} =
|
||||
$self->{header}->{'x-send-pr-version'} =~ /^www-/;
|
||||
|
||||
$self->ParseBlobs();
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: ParseBlobs()
|
||||
# Desc: Parse all the raw field "blobs" into section objects.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: n/a
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub ParseBlobs
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
foreach my $field (keys %{$self->{blobs_multi}}) {
|
||||
$self->{sections}->{$field} = [];
|
||||
|
||||
push @{$self->{sections}->{$field}},
|
||||
new GnatsPR::Section::FieldStart($field);
|
||||
|
||||
if ($field eq 'Fix') {
|
||||
$self->ParsePatches($field, \($self->{blobs_multi}->{$field}));
|
||||
next;
|
||||
}
|
||||
|
||||
if ($field eq 'Audit-Trail') {
|
||||
# We'll break up the Audit-Trail field by change events.
|
||||
# This is the most reliable way to split, although it's far
|
||||
# from perfect. We'll then look for e-mail responses inside
|
||||
# each chunk for further splitting later.
|
||||
#
|
||||
# Notes/Caveats:
|
||||
# - If someone happened to paste an audit trail event
|
||||
# inside another's "Why" field, it'd break this. I haven't
|
||||
# seen this yet and don't expect to.
|
||||
# - The From-To field has to come first. No reason it wouldn't
|
||||
# under normal circumstances.
|
||||
# - Pasted e-mails in the Why field will be promoted to
|
||||
# responses, although they often break the GNATS conventions
|
||||
# we (ab)use to find e-mails (e.g.: leading space on message
|
||||
# body lines), which makes this more difficult.
|
||||
my @auditevents =
|
||||
split /(?=^(?:[A-Za-z_]+)-Changed-From-To: (?:.*?)\s*$)/m,
|
||||
$self->{blobs_multi}->{$field};
|
||||
|
||||
foreach my $evt (@auditevents) {
|
||||
my $sect = new GnatsPR::Section::StateChange;
|
||||
my $gotwhat = 0;
|
||||
my $gotsect = 0;
|
||||
while ($evt =~ s/^([A-Za-z_]+)-Changed-([A-Za-z_-]+?): (.*?)\s*\n//) {
|
||||
my ($what, $key, $val) = ($1, $2, $3);
|
||||
|
||||
if (!$gotwhat) {
|
||||
$sect->what($what);
|
||||
$gotwhat = 1;
|
||||
}
|
||||
|
||||
$gotsect = 1;
|
||||
|
||||
if ($key eq 'From-To') {
|
||||
my $fromto = $val;
|
||||
if ($fromto =~ /^(.*)->(.*)$/) {
|
||||
$sect->from($1);
|
||||
$sect->to($2);
|
||||
}
|
||||
} elsif ($key eq 'When') {
|
||||
$sect->when($val);
|
||||
} elsif ($key eq 'By') {
|
||||
$sect->by($val);
|
||||
} elsif ($key eq 'Why') {
|
||||
# This is the last one; it's a multi-line
|
||||
# field (remainder of the text.)
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
push @{$self->{sections}->{$field}}, $sect
|
||||
if ($gotsect);
|
||||
|
||||
# Now look for blocks that appear to be e-mail replies
|
||||
# Note: these header fields are the only ones we allow
|
||||
# as the first header; we could feasibly back-
|
||||
# track to find the start of the block (in case
|
||||
# we're not there already), but the more headers
|
||||
# we accept the more likely this will break on
|
||||
# some unexpected content.
|
||||
my $next_email = qr/^(From|To|Cc|Subject|Date): (.*)$/m;
|
||||
my $gotwhy = 0;
|
||||
|
||||
while ($evt =~ /$next_email/) {
|
||||
my $match_start = $-[0];
|
||||
my ($header, $body, $indented);
|
||||
my $why;
|
||||
|
||||
$match_start > 0
|
||||
and $why = substr($evt, 0, $match_start, '');
|
||||
|
||||
if ($gotsect) {
|
||||
# We now know where "Why" terminates
|
||||
$sect->why($why) if $sect;
|
||||
} elsif ($why) {
|
||||
# If the first block was a date block,
|
||||
# we need to use a text section for the
|
||||
# intermediate text instead.
|
||||
push @{$self->{sections}->{$field}},
|
||||
new GnatsPR::Section::Text($why)
|
||||
unless ($why =~ /^[\n\s]+$/);
|
||||
}
|
||||
|
||||
$gotwhy = 1;
|
||||
$sect = undef;
|
||||
|
||||
# Chop leading blank lines
|
||||
$evt =~ s/^\n+//;
|
||||
|
||||
if ($evt =~ /^$/m) {
|
||||
# First blank line signals the end of the
|
||||
# e-mail header
|
||||
$header = substr($evt, 0, $+[0]+1, '');
|
||||
|
||||
# Deciding where the body ends is more
|
||||
# difficult...
|
||||
|
||||
# First, let's see if the message is
|
||||
# indented (per GNATS standards)
|
||||
$indented = ($evt =~ /^ /);
|
||||
|
||||
# If, so, find the next blank line, which
|
||||
# signals the body end.
|
||||
if ($indented) {
|
||||
if ($evt =~ /^$/m) {
|
||||
$body = substr($evt, 0, $-[0], '');
|
||||
} else {
|
||||
$body = $evt;
|
||||
}
|
||||
$body =~ s/^ //mg; # Remove indent char
|
||||
} else {
|
||||
# Look for another e-mail block
|
||||
if ($evt =~ /$next_email/) {
|
||||
$body = substr($evt, 0, $-[0], '');
|
||||
} else {
|
||||
# Otherwise, use the whole section
|
||||
$body = $evt;
|
||||
}
|
||||
}
|
||||
|
||||
push @{$self->{sections}->{$field}},
|
||||
new GnatsPR::Section::Email($header, $body);
|
||||
} else {
|
||||
# No end-of-header marker: no choice but to
|
||||
# dump the (possible) e-mail into the Why field
|
||||
|
||||
if ($gotsect && $sect) {
|
||||
$sect->why($evt);
|
||||
} elsif ($evt) {
|
||||
push @{$self->{sections}->{$field}},
|
||||
new GnatsPR::Section::Text($evt);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Check for dangling "Why" block
|
||||
if (!$gotwhy) {
|
||||
if ($gotsect && $sect) {
|
||||
$sect->why($evt);
|
||||
} elsif ($evt) {
|
||||
push @{$self->{sections}->{$field}},
|
||||
new GnatsPR::Section::Text($evt);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
next;
|
||||
}
|
||||
|
||||
# Everything else is just text
|
||||
push @{$self->{sections}->{$field}},
|
||||
new GnatsPR::Section::Text($self->{blobs_multi}->{$field});
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: ParsePatches()
|
||||
# Desc: Parse the patches out of the given blob of text, emitting Patch and
|
||||
# Text sections as appropriate.
|
||||
#
|
||||
# Args: $field - Field to push new sections to.
|
||||
# \$text - Raw text
|
||||
#
|
||||
# Retn: n/a
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub ParsePatches
|
||||
{
|
||||
my $self = shift;
|
||||
my ($field, $text) = @_;
|
||||
|
||||
while (my $pi = $self->FindPatchStart($text)) {
|
||||
# Everything up to this fragment can be
|
||||
# promoted to a text section
|
||||
push @{$self->{sections}->{$field}},
|
||||
new GnatsPR::Section::Text(substr(
|
||||
$$text,
|
||||
0,
|
||||
$pi->{start},
|
||||
''
|
||||
))
|
||||
unless $pi->{start} == 0;
|
||||
|
||||
$pi->{start} = 0;
|
||||
|
||||
$self->FindPatchEnd($text, $pi);
|
||||
|
||||
# Try to determine if a web/send-pr attachment
|
||||
# has another type of patch inside.
|
||||
if ($pi->{type} eq 'stdattach' or $pi->{type} eq 'webattach') {
|
||||
if (my $pi2 = $self->FindPatchStart($text)) {
|
||||
# Upgrade to more specific type
|
||||
$pi->{type} = $pi2->{type}
|
||||
if ($pi2->{start} == 0);
|
||||
}
|
||||
}
|
||||
|
||||
push @{$self->{sections}->{$field}},
|
||||
new GnatsPR::Section::Patch(substr(
|
||||
$$text,
|
||||
0,
|
||||
$pi->{size},
|
||||
''
|
||||
), $pi->{name}, $pi->{type});
|
||||
|
||||
$$text =~ s/^[\n\s]+//;
|
||||
}
|
||||
|
||||
# Rest of the field is text
|
||||
push @{$self->{sections}->{$field}},
|
||||
new GnatsPR::Section::Text($$text)
|
||||
if ($$text);
|
||||
|
||||
$text = '';
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: FindPatchStart()
|
||||
# Desc: Find the beginning of the first patch inside the given text blob,
|
||||
# if there is one.
|
||||
#
|
||||
# Args: \$text - Raw text
|
||||
#
|
||||
# Retn: \%pi - Hash of patch info (or undef):
|
||||
# - start - Start offset of patch
|
||||
# - type - Type of attachment found
|
||||
# - name - Filename, if available
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub FindPatchStart
|
||||
{
|
||||
my $self = shift;
|
||||
my ($text) = @_;
|
||||
|
||||
# Patch from web CGI script. Characteristics:
|
||||
# - Only ever one of them.
|
||||
# - Appended to the end of Fix:
|
||||
# - Blank line after header line
|
||||
# - Could contain other types of patch (e.g. shar(1) archive)
|
||||
if ($$text =~ /^Patch attached with submission follows:$/m && $self->{fromwebform}) {
|
||||
my $start = $+[0]; # The newline on the above
|
||||
|
||||
# Next non-blank line (i.e. start of patch)
|
||||
if ($$text =~ /\G^./m) {
|
||||
$start += $+[0]+1;
|
||||
return {start => $start, type => 'webattach'};
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
# Patch from send-pr(1). Characteristics:
|
||||
# - Has header and footer line.
|
||||
# - Appended to the end of Fix:
|
||||
# - User has an opportunity to edit/mangle.
|
||||
# - Could contain other types of patch (e.g. shar(1) archive)
|
||||
if ($$text =~ /^---{1,8}\s?([A-Za-z0-9-_.,:%]+) (begins|starts) here\s?---+\n/mi) {
|
||||
my $r = {start => $-[0], type => 'stdattach', name => $1};
|
||||
|
||||
# Chop header line
|
||||
substr($$text, $-[0], $+[0] - $-[0], '');
|
||||
|
||||
return $r;
|
||||
}
|
||||
|
||||
# Patch files from diff(1). Characteristics:
|
||||
# - Easy to find start.
|
||||
# - Difficult to find the end.
|
||||
$$text =~ /^((?:(?:---|\*\*\*)\ (?:\S+)\s*(?:Mon|Tue|Wed|Thu|Fri|Sat|Sun)\ .*)
|
||||
|(?:(?:---|\*\*\*)\ (?:\S+)\s*(?:\d\d\d\d-\d\d-\d\d\ \d\d:\d\d:\d\d\.\d+)\ .*)
|
||||
|(diff\ -.*?\ .*?\ .*)|(Index:\ \S+)
|
||||
|(\*{3}\ \d+,\d+\ \*{4}))$/mx
|
||||
and return {start => $-[0], type => 'diff'};
|
||||
|
||||
# Shell archive from shar(1)
|
||||
$$text =~ /^# This is a shell archive\. Save it in a file, remove anything before/m
|
||||
and return {start => $-[0], type => 'shar'};
|
||||
|
||||
# UUencoded file. Characteristics:
|
||||
# - Has header and footer.
|
||||
$$text =~ /^begin \d\d\d (.*)/m
|
||||
and return {start => $-[0], type => 'uuencoded', name => $1};
|
||||
|
||||
# Base64 encoded file. Characteristics:
|
||||
# - Has header and footer.
|
||||
$$text =~ /^begin-base64 \d\d\d (.*)/m
|
||||
and return {start => $-[0], type => 'base64', name => $1};
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: FindPatchEnd()
|
||||
# Desc: Find the end of the first patch inside the given text blob, if any.
|
||||
#
|
||||
# Args: \$text - Raw text
|
||||
# \%pi - Patch info hash from FindPatchStart(). We'll add more data:
|
||||
# - size - Length of the patch.
|
||||
#
|
||||
# Retn: \%pi - Same as above, except undef will be returned if no actual
|
||||
# endpoint was found (size in pi would extend to the end of the
|
||||
# text blob in this case.)
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub FindPatchEnd
|
||||
{
|
||||
my $self = shift;
|
||||
my ($text, $pi) = @_;
|
||||
|
||||
$pi->{size} = 0;
|
||||
|
||||
if ($pi->{type} eq 'webattach') {
|
||||
$$text =~ /$/
|
||||
and $pi->{size} = $+[0];
|
||||
} elsif ($pi->{type} eq 'stdattach') {
|
||||
$$text =~ /^---{1,8}\s?\Q$pi->{name}\E ends here\s?---+/mi
|
||||
and $pi->{size} = $-[0]-1;
|
||||
# Chop footer line
|
||||
substr($$text, $-[0], $+[0] - $-[0], '');
|
||||
} elsif ($pi->{type} eq 'diff') {
|
||||
# XXX: could do better
|
||||
$$text =~ /^$/m
|
||||
and $pi->{size} = $-[0]-1;
|
||||
} elsif ($pi->{type} eq 'shar') {
|
||||
$$text =~ /^exit$/m
|
||||
and $pi->{size} = $+[0];
|
||||
} elsif ($pi->{type} eq 'uuencoded') {
|
||||
$$text =~ /^end$/m
|
||||
and $pi->{size} = $+[0];
|
||||
} elsif ($pi->{type} eq 'base64') {
|
||||
$$text =~ /^====$/m
|
||||
and $pi->{size} = $+[0];
|
||||
}
|
||||
|
||||
if ($pi->{size} == 0) {
|
||||
$pi->{size} = length $$text;
|
||||
return undef;
|
||||
}
|
||||
|
||||
return $pi;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: GetAttachment()
|
||||
# Desc: Recursively search sections for a downloadable attachment.
|
||||
#
|
||||
# Args: $num - Attachment index (counts from 1)
|
||||
#
|
||||
# Retn: $sec - Attachment section (or undef)
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub GetAttachment
|
||||
{
|
||||
my $self = shift;
|
||||
my ($num) = @_;
|
||||
my $cur = 1;
|
||||
|
||||
my $iter = GnatsPR::SectionIterator->new($self, 'Fix', 'Audit-Trail');
|
||||
|
||||
while (my $item = $iter->next()) {
|
||||
if (ref $item eq 'GnatsPR::Section::Patch') {
|
||||
# Patch sections
|
||||
return $item if ($cur++ == $num);
|
||||
} elsif (ref $item eq 'GnatsPR::Section::Email') {
|
||||
# Attachments from MIME messages
|
||||
my $mime_iter = GnatsPR::MIMEIterator->new($item);
|
||||
while (my $part = $mime_iter->next()) {
|
||||
if ($part->isattachment) {
|
||||
return $part if ($cur++ == $num);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
|
@ -1,153 +0,0 @@
|
|||
#!/usr/bin/perl -Tw
|
||||
#------------------------------------------------------------------------------
|
||||
# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
|
||||
# All rights reserved.
|
||||
#
|
||||
# Redistribution and use in source and binary forms, with or without
|
||||
# modification, are permitted provided that the following conditions
|
||||
# are met:
|
||||
# 1. Redistributions of source code must retain the above copyright
|
||||
# notice, this list of conditions and the following disclaimer.
|
||||
# 2. Redistributions in binary form must reproduce the above copyright
|
||||
# notice, this list of conditions and the following disclaimer in the
|
||||
# documentation and/or other materials provided with the distribution.
|
||||
#
|
||||
# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
|
||||
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
|
||||
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
||||
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||||
# SUCH DAMAGE.
|
||||
#
|
||||
# $FreeBSD$
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
package GnatsPR::MIMEIterator;
|
||||
|
||||
use strict;
|
||||
|
||||
require 5.006;
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: new()
|
||||
# Desc: Constructor.
|
||||
#
|
||||
# Args: $email - GnatsPR::Section::Email instance.
|
||||
#
|
||||
# Retn: $self
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my $email = shift;
|
||||
|
||||
my $self = {
|
||||
idxlist => [ -1 ],
|
||||
email => undef
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
$self->{email} = $email;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: next()
|
||||
# Desc: Return next iterator element.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: $next
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub next
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my $curr = $self->_current();
|
||||
|
||||
while (1) {
|
||||
my $next = ++$self->{idxlist}->[$#{$self->{idxlist}}];
|
||||
|
||||
# Past last element?
|
||||
if ($next > $#{$curr->{mimeparts}}) {
|
||||
# Back out
|
||||
pop @{$self->{idxlist}};
|
||||
|
||||
# Reached the root
|
||||
$#{$self->{idxlist}} > -1
|
||||
or return undef;
|
||||
|
||||
$curr = $self->_current();
|
||||
next;
|
||||
}
|
||||
|
||||
last;
|
||||
}
|
||||
|
||||
my $rpart = $curr->{mimeparts}->[$self->{idxlist}->[$#{$self->{idxlist}}]];
|
||||
|
||||
# Container part? - find a leaf node
|
||||
while ($#{$rpart->{mimeparts}} > -1) {
|
||||
$rpart = $rpart->{mimeparts}->[0];
|
||||
push @{$self->{idxlist}}, 0;
|
||||
}
|
||||
|
||||
return $rpart;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: isfirst()
|
||||
# Desc: Determine if the iterator is at the first element.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: $isfirst - true/false
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub isfirst
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return (
|
||||
$#{$self->{idxlist}} == 0
|
||||
and $self->{idxlist}->[$#{$self->{idxlist}}] == 0
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: _current()
|
||||
# Desc: Traverse to, and return, the current container element.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: $curr
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub _current
|
||||
{
|
||||
my $self = shift;
|
||||
my $curr = $self->{email};
|
||||
|
||||
# Find current MIME part container
|
||||
for (my $depth = 0; $depth < $#{$self->{idxlist}}; $depth++) {
|
||||
$curr = $curr->{mimeparts}->[$self->{idxlist}->[$depth]];
|
||||
}
|
||||
|
||||
return $curr;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
|
@ -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"
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
# $FreeBSD$
|
||||
|
||||
WEBBASE?= /data/cgi/GnatsPR
|
||||
DOC_PREFIX?= ${.CURDIR}/../../../../..
|
||||
|
|
@ -1,58 +0,0 @@
|
|||
#!/usr/bin/perl -Tw
|
||||
#------------------------------------------------------------------------------
|
||||
# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
|
||||
# All rights reserved.
|
||||
#
|
||||
# Redistribution and use in source and binary forms, with or without
|
||||
# modification, are permitted provided that the following conditions
|
||||
# are met:
|
||||
# 1. Redistributions of source code must retain the above copyright
|
||||
# notice, this list of conditions and the following disclaimer.
|
||||
# 2. Redistributions in binary form must reproduce the above copyright
|
||||
# notice, this list of conditions and the following disclaimer in the
|
||||
# documentation and/or other materials provided with the distribution.
|
||||
#
|
||||
# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
|
||||
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
|
||||
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
||||
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||||
# SUCH DAMAGE.
|
||||
#
|
||||
# $FreeBSD$
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
package Section;
|
||||
|
||||
use strict;
|
||||
|
||||
require 5.006;
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: new()
|
||||
# Desc: Constructor.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: $self
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
my $self = {
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
|
@ -1,189 +0,0 @@
|
|||
#!/usr/bin/perl -Tw
|
||||
#------------------------------------------------------------------------------
|
||||
# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
|
||||
# All rights reserved.
|
||||
#
|
||||
# Redistribution and use in source and binary forms, with or without
|
||||
# modification, are permitted provided that the following conditions
|
||||
# are met:
|
||||
# 1. Redistributions of source code must retain the above copyright
|
||||
# notice, this list of conditions and the following disclaimer.
|
||||
# 2. Redistributions in binary form must reproduce the above copyright
|
||||
# notice, this list of conditions and the following disclaimer in the
|
||||
# documentation and/or other materials provided with the distribution.
|
||||
#
|
||||
# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
|
||||
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
|
||||
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
||||
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||||
# SUCH DAMAGE.
|
||||
#
|
||||
# $FreeBSD$
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
package GnatsPR::Section::Email;
|
||||
|
||||
use GnatsPR::Section::MIME;
|
||||
|
||||
use strict;
|
||||
|
||||
require 5.006;
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: new()
|
||||
# Desc: Constructor.
|
||||
#
|
||||
# Args: $header - Raw e-mail header.
|
||||
# $body - Raw message body.
|
||||
#
|
||||
# Retn: $self
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my ($header, $body) = @_;
|
||||
|
||||
my $self = {
|
||||
headerblob => '',
|
||||
bodyblob => '',
|
||||
|
||||
headers => {},
|
||||
|
||||
mimeparts => []
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
$self->{headerblob} = $header;
|
||||
$self->{bodyblob} = $body;
|
||||
|
||||
$self->ParseHeader() if ($header);
|
||||
$self->ParseBody() if ($body);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: ParseHeader()
|
||||
# Desc: Parse header blob into fields.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: n/a
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub ParseHeader
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my $key;
|
||||
|
||||
foreach my $line (split /\n/, $self->{headerblob}) {
|
||||
if ($line =~ /^(\S+):\s*(.*)$/) {
|
||||
my $val = $2;
|
||||
$key = lc $1;
|
||||
|
||||
# Ignore multiple defs (e.g. Received: headers)
|
||||
exists $self->{headers}->{$key}
|
||||
and next;
|
||||
|
||||
$self->{headers}->{$key} = $val;
|
||||
} elsif ($line =~ /^\s*(.*)$/) {
|
||||
my $val = $1;
|
||||
|
||||
defined $key
|
||||
or next;
|
||||
|
||||
# No field to append to
|
||||
exists $self->{headers}->{$key}
|
||||
or next;
|
||||
|
||||
$self->{headers}->{$key} .= ' '.$val;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: ParseBody()
|
||||
# Desc: Parse body blob.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: n/a
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub ParseBody
|
||||
{
|
||||
# XXX: recurse to second-level parts
|
||||
|
||||
my $self = shift;
|
||||
|
||||
$self->{mimeparts} = [];
|
||||
|
||||
# First of all - attempt to split into MIME parts
|
||||
# Note that since GNATS nukes a bunch of the headers
|
||||
# that we need, this is purely of a heuristic nature.
|
||||
|
||||
# Technically less permissive than RFC1341
|
||||
|
||||
my $nextbound = qr/^--([A-Za-z0-9'()+_,-.\/:=?]{6,70})$/m;
|
||||
my $first = 1;
|
||||
|
||||
while ($self->{bodyblob} =~ s/$nextbound//m) {
|
||||
my $last;
|
||||
|
||||
if ($first) {
|
||||
my $boundary = $1;
|
||||
$nextbound = qr/^--\Q$boundary\E(--)?$/m;
|
||||
$last = 0;
|
||||
$first = 0;
|
||||
} else {
|
||||
$last = ($2 and $2 eq '--');
|
||||
}
|
||||
|
||||
# Promote to MIME part
|
||||
|
||||
push @{$self->{mimeparts}},
|
||||
new GnatsPR::Section::MIME(
|
||||
substr($self->{bodyblob}, 0, $-[0], '')
|
||||
)
|
||||
unless ($-[0] == 0);
|
||||
}
|
||||
|
||||
if (!@{$self->{mimeparts}}) {
|
||||
# No parts - just plain text
|
||||
push @{$self->{mimeparts}},
|
||||
new GnatsPR::Section::MIME($self->{bodyblob});
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: Header()
|
||||
# Desc: Return a header field.
|
||||
#
|
||||
# Args: $key - Header name, case insensitive.
|
||||
#
|
||||
# Retn: $val - Value.
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub Header
|
||||
{
|
||||
my $self = shift;
|
||||
my ($key) = @_;
|
||||
|
||||
return $self->{headers}->{lc $key};
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
|
@ -1,80 +0,0 @@
|
|||
#!/usr/bin/perl -Tw
|
||||
#------------------------------------------------------------------------------
|
||||
# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
|
||||
# All rights reserved.
|
||||
#
|
||||
# Redistribution and use in source and binary forms, with or without
|
||||
# modification, are permitted provided that the following conditions
|
||||
# are met:
|
||||
# 1. Redistributions of source code must retain the above copyright
|
||||
# notice, this list of conditions and the following disclaimer.
|
||||
# 2. Redistributions in binary form must reproduce the above copyright
|
||||
# notice, this list of conditions and the following disclaimer in the
|
||||
# documentation and/or other materials provided with the distribution.
|
||||
#
|
||||
# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
|
||||
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
|
||||
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
||||
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||||
# SUCH DAMAGE.
|
||||
#
|
||||
# $FreeBSD$
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
package GnatsPR::Section::FieldStart;
|
||||
|
||||
use strict;
|
||||
|
||||
require 5.006;
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: new()
|
||||
# Desc: Constructor.
|
||||
#
|
||||
# Args: $name - Field name.
|
||||
#
|
||||
# Retn: $self
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my ($name) = @_;
|
||||
|
||||
my $self = {
|
||||
name => ''
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
$self->{name} = $name;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: string()
|
||||
# Desc: Return the field name.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: $string
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub string
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return $self->{name};
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
|
@ -1,334 +0,0 @@
|
|||
#!/usr/bin/perl -Tw
|
||||
#------------------------------------------------------------------------------
|
||||
# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
|
||||
# All rights reserved.
|
||||
#
|
||||
# Redistribution and use in source and binary forms, with or without
|
||||
# modification, are permitted provided that the following conditions
|
||||
# are met:
|
||||
# 1. Redistributions of source code must retain the above copyright
|
||||
# notice, this list of conditions and the following disclaimer.
|
||||
# 2. Redistributions in binary form must reproduce the above copyright
|
||||
# notice, this list of conditions and the following disclaimer in the
|
||||
# documentation and/or other materials provided with the distribution.
|
||||
#
|
||||
# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
|
||||
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
|
||||
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
||||
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||||
# SUCH DAMAGE.
|
||||
#
|
||||
# $FreeBSD$
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
package GnatsPR::Section::MIME;
|
||||
|
||||
use MIME::Base64; # ports/converters/p5-MIME-Base64
|
||||
use MIME::QuotedPrint; #
|
||||
use Convert::UU qw(uudecode uuencode); # ports/converters/p5-Convert-UU
|
||||
|
||||
use Encode;
|
||||
|
||||
use strict;
|
||||
|
||||
require 5.006;
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: new()
|
||||
# Desc: Constructor.
|
||||
#
|
||||
# Args: $blob - Raw MIME part, inc. any headers.
|
||||
#
|
||||
# Retn: $self
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my ($blob) = @_;
|
||||
|
||||
my $self = {
|
||||
body => '',
|
||||
decoded_body => '',
|
||||
headers => {},
|
||||
binary => 0,
|
||||
encoded => 0,
|
||||
attachment => 0,
|
||||
filename => '',
|
||||
mimeparts => [] # Sub parts (usually empty)
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
$self->{body} = $blob;
|
||||
|
||||
$self->Parse() if ($blob);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Accessors
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub body
|
||||
{
|
||||
my $self = shift;
|
||||
$self->{body} = $_[0] if @_;
|
||||
return $self->{body};
|
||||
}
|
||||
|
||||
sub isbinary
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{binary};
|
||||
}
|
||||
|
||||
sub isencoded
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{encoded};
|
||||
}
|
||||
|
||||
sub isattachment
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{attachment};
|
||||
}
|
||||
|
||||
sub filename
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{filename};
|
||||
}
|
||||
|
||||
sub data
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{encoded} ? $self->{decoded_body} : $self->{body};
|
||||
}
|
||||
|
||||
sub size
|
||||
{
|
||||
my $self = shift;
|
||||
return length($self->{encoded} ? $self->{decoded_body} : $self->{body});
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: Parse()
|
||||
# Desc: Parse and decode raw MIME part.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: n/a
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub Parse
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my $charset;
|
||||
|
||||
$self->{body} =~ s/^[\n\s]+//;
|
||||
$self->{body} =~ s/[\n\s]+$/\n/;
|
||||
|
||||
$self->ParseHeader();
|
||||
|
||||
# Determine if we're a multi-part container
|
||||
if (lc $self->header('content-type') =~ /multipart/
|
||||
and $self->header('content-type:boundary')) {
|
||||
my $bound = $self->header('content-type:boundary');
|
||||
@{$self->{mimeparts}} =
|
||||
map {
|
||||
new GnatsPR::Section::MIME($_);
|
||||
}
|
||||
grep !/^[\n\s]*$/,
|
||||
split /^--\Q$bound\E(?:--)?$/m, $self->{body};
|
||||
$self->{body} = undef;
|
||||
return;
|
||||
}
|
||||
|
||||
if ($self->header('content-type:charset')) {
|
||||
my $cs = $self->header('content-type:charset');
|
||||
|
||||
if ($cs =~ /utf.*8/i) {
|
||||
$cs = 'utf-8';
|
||||
} else {
|
||||
$cs = Encode::resolve_alias($cs);
|
||||
}
|
||||
|
||||
if ($cs and $cs ne 'ascii') {
|
||||
$charset = $cs;
|
||||
}
|
||||
}
|
||||
|
||||
# Look for Quoted-Printable (explicit or using a silly heuristic)
|
||||
if (lc $self->header('content-transfer-encoding') eq 'quoted-printable'
|
||||
or $self->{body} =~ /=[0-9A-Fa-f]{2}=[0-9A-Fa-f]{2}/) {
|
||||
$self->{body} = decode_qp($self->{body});
|
||||
$self->{body} = decode($charset, $self->{body})
|
||||
if ($charset);
|
||||
|
||||
# Base64 -- probably better not to decode
|
||||
} elsif (lc $self->header('content-transfer-encoding') eq 'base64') {
|
||||
$self->{decoded_body} = decode_base64($self->{body});
|
||||
$self->{decoded_body} = decode($charset, $self->{decoded_body})
|
||||
if ($charset);
|
||||
$self->{encoded} = 1;
|
||||
}
|
||||
|
||||
# Catches too much stuff that we can display
|
||||
#if ($self->header('content-type')
|
||||
# && $self->header('content-type') !~ 'text/') {
|
||||
# $self->{binary} = 1;
|
||||
#}
|
||||
|
||||
if (lc $self->header('content-disposition') eq 'attachment') {
|
||||
my $filename =
|
||||
$self->header('content-disposition:filename')
|
||||
|| $self->header('content-type:name')
|
||||
|| $self->header('x-attachment-id')
|
||||
|| 'attachment';
|
||||
|
||||
$filename =~ '(?:\.gz|\.bz2|\.zip|\.tar)$'
|
||||
and $self->{binary} = 1;
|
||||
|
||||
$self->{attachment} = 1;
|
||||
$self->{filename} = $filename;
|
||||
}
|
||||
|
||||
if ($self->{body} =~ /^begin \d\d\d (.*)/ && !$self->{encoded}) {
|
||||
$self->{decoded_body} = uudecode($self->{body});
|
||||
$self->{encoded} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: ParseHeader()
|
||||
# Desc: Parse out any MIME header fields.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: n/a
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub ParseHeader
|
||||
{
|
||||
my $self = shift;
|
||||
my $header = '';
|
||||
my $key;
|
||||
|
||||
# Start with some defaults
|
||||
$self->{headers}->{'content-type'} = 'text/plain';
|
||||
|
||||
# No header?
|
||||
$self->{body} =~ /^Content-/i
|
||||
or return;
|
||||
|
||||
# Ensure we have an end-of-header marker. Returning here
|
||||
# will result in some bodyless headers being dumped as
|
||||
# text (example in conf/138672) -- but I think this is
|
||||
# the safe option, in case such a header is in fact the
|
||||
# body of a malformed message.
|
||||
$self->{body} =~ /^$/m and $+[0] != length($self->{body}) or return;
|
||||
|
||||
$header = substr($self->{body}, 0, $+[0]+1, '');
|
||||
|
||||
$self->{body} =~ s/^[\n\s]+//;
|
||||
|
||||
foreach my $line (split /\n/, $header) {
|
||||
if ($line =~ /^(\S+): (.*)$/) {
|
||||
$key = lc $1;
|
||||
$self->{headers}->{$key} = $2;
|
||||
} elsif ($line =~ /^\s+(.*)$/) {
|
||||
$key or next;
|
||||
$self->{headers}->{$key} .= ' ' . $1;
|
||||
}
|
||||
}
|
||||
|
||||
# Split up aggregate headers into individual values
|
||||
|
||||
foreach my $key (keys %{$self->{headers}}) {
|
||||
$self->{headers}->{$key} =~ /;/ or next;
|
||||
|
||||
my @chars = split //, $self->{headers}->{$key};
|
||||
my $inquote = 0;
|
||||
my $gotkey = 0;
|
||||
my $k = '';
|
||||
my $v = '';
|
||||
|
||||
foreach my $char (@chars) {
|
||||
if ($char eq '"') {
|
||||
$inquote = !$inquote;
|
||||
next;
|
||||
} elsif ($char eq '=' && !$inquote) {
|
||||
$gotkey = 1;
|
||||
next;
|
||||
} elsif ($char eq ';' && !$inquote) {
|
||||
if ($k and $v) {
|
||||
$k = lc $k;
|
||||
$self->{headers}->{"$key:$k"} = $v;
|
||||
}
|
||||
$k = $v = '';
|
||||
$gotkey = 0;
|
||||
next;
|
||||
} elsif (($char eq ' ' or $char eq '\t') && !$inquote) {
|
||||
next;
|
||||
}
|
||||
|
||||
if ($gotkey) {
|
||||
$v .= $char;
|
||||
} else {
|
||||
$k .= $char;
|
||||
}
|
||||
}
|
||||
|
||||
if ($k and $v) {
|
||||
$k = lc $k;
|
||||
$self->{headers}->{"$key:$k"} = $v;
|
||||
}
|
||||
|
||||
$self->{headers}->{$key} =~ s/;.*$//;
|
||||
}
|
||||
|
||||
# Normalise
|
||||
|
||||
$self->{headers}->{'content-type'} =
|
||||
lc $self->{headers}->{'content-type'};
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: header()
|
||||
# Desc: Return header.
|
||||
#
|
||||
# Args: $key
|
||||
#
|
||||
# Retn: $val
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub header
|
||||
{
|
||||
my $self = shift;
|
||||
my ($key) = @_;
|
||||
|
||||
$key = lc $key;
|
||||
|
||||
return $self->{headers}->{$key}
|
||||
if (exists $self->{headers}->{$key});
|
||||
|
||||
return '';
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
|
@ -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"
|
||||
|
|
@ -1,188 +0,0 @@
|
|||
#!/usr/bin/perl -Tw
|
||||
#------------------------------------------------------------------------------
|
||||
# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
|
||||
# All rights reserved.
|
||||
#
|
||||
# Redistribution and use in source and binary forms, with or without
|
||||
# modification, are permitted provided that the following conditions
|
||||
# are met:
|
||||
# 1. Redistributions of source code must retain the above copyright
|
||||
# notice, this list of conditions and the following disclaimer.
|
||||
# 2. Redistributions in binary form must reproduce the above copyright
|
||||
# notice, this list of conditions and the following disclaimer in the
|
||||
# documentation and/or other materials provided with the distribution.
|
||||
#
|
||||
# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
|
||||
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
|
||||
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
||||
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||||
# SUCH DAMAGE.
|
||||
#
|
||||
# $FreeBSD$
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
package GnatsPR::Section::Patch;
|
||||
|
||||
use MIME::Base64; # ports/converters/p5-MIME-Base64
|
||||
use Convert::UU qw(uudecode uuencode); # ports/converters/p5-Convert-UU
|
||||
|
||||
use strict;
|
||||
|
||||
require 5.006;
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: new()
|
||||
# Desc: Constructor.
|
||||
#
|
||||
# Args: $text - Blob of text.
|
||||
# $filename - Filename of patch, if we have one.
|
||||
# $type - Patch type string (if known).
|
||||
#
|
||||
# Retn: $self
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my ($text, $filename, $type) = @_;
|
||||
|
||||
my $self = {
|
||||
text => '',
|
||||
filename => 'patch.txt',
|
||||
binary => 0,
|
||||
encoded => 0,
|
||||
type => 'unknown'
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
$self->{text} = $text;
|
||||
|
||||
$self->{filename} = $filename if $filename;
|
||||
$self->{type} = $type if $type;
|
||||
|
||||
$self->{filename} =~ '(?:\.gz|\.bz2|\.zip|\.tar)$'
|
||||
and $self->{binary} = 1;
|
||||
|
||||
if ($self->{type} eq 'uuencoded') {
|
||||
$self->{encoded} = 1;
|
||||
$self->{decoded_text} = uudecode($self->{text});
|
||||
} elsif ($self->{type} eq 'base64') {
|
||||
$self->{encoded} = 1;
|
||||
$self->{decoded_text} = decode_base64($self->{text});
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: string()
|
||||
# Desc: Return string contained within.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: $string
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub string
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return $self->{text};
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: size()
|
||||
# Desc: Return the length of the contained data.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: $string
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub size
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return length($self->{encoded} ? $self->{decoded_text} : $self->{text});
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: data()
|
||||
# Desc: Return the raw decoded (if possible/necessary) data.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: $string
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub data
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return $self->{encoded} ? $self->{decoded_text} : $self->{text};
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: filename()
|
||||
# Desc: Return the patch's filename.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: $filename
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub filename
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return $self->{filename};
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: type()
|
||||
# Desc: Return the patch's type.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: $type
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub type
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return $self->{type};
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: isbinary()
|
||||
# Desc: Is patch binary?
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: $type
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub isbinary
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return $self->{binary};
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
|
@ -1,117 +0,0 @@
|
|||
#!/usr/bin/perl -Tw
|
||||
#------------------------------------------------------------------------------
|
||||
# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
|
||||
# All rights reserved.
|
||||
#
|
||||
# Redistribution and use in source and binary forms, with or without
|
||||
# modification, are permitted provided that the following conditions
|
||||
# are met:
|
||||
# 1. Redistributions of source code must retain the above copyright
|
||||
# notice, this list of conditions and the following disclaimer.
|
||||
# 2. Redistributions in binary form must reproduce the above copyright
|
||||
# notice, this list of conditions and the following disclaimer in the
|
||||
# documentation and/or other materials provided with the distribution.
|
||||
#
|
||||
# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
|
||||
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
|
||||
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
||||
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||||
# SUCH DAMAGE.
|
||||
#
|
||||
# $FreeBSD$
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
package GnatsPR::Section::StateChange;
|
||||
|
||||
use strict;
|
||||
|
||||
require 5.006;
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: new()
|
||||
# Desc: Constructor.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: $self
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
my $self = {
|
||||
what => '', # State or Responsible
|
||||
from => '', # Change from
|
||||
to => '', # Change to
|
||||
why => '', # Reason for change
|
||||
when => '', # Date of change
|
||||
by => '' # Who changed it
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Accessors
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub what
|
||||
{
|
||||
my $self = shift;
|
||||
$self->{what} = $_[0] if @_;
|
||||
return $self->{what};
|
||||
}
|
||||
|
||||
sub from
|
||||
{
|
||||
my $self = shift;
|
||||
$self->{from} = $_[0] if @_;
|
||||
return $self->{from};
|
||||
}
|
||||
|
||||
sub to
|
||||
{
|
||||
my $self = shift;
|
||||
$self->{to} = $_[0] if @_;
|
||||
return $self->{to};
|
||||
}
|
||||
|
||||
sub why
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
if (scalar @_) {
|
||||
$self->{why} = $_[0];
|
||||
$self->{why} =~ s/^\s+//;
|
||||
$self->{why} =~ s/[\n\s]+$//;
|
||||
}
|
||||
return $self->{why};
|
||||
}
|
||||
|
||||
sub when
|
||||
{
|
||||
my $self = shift;
|
||||
$self->{when} = $_[0] if @_;
|
||||
return $self->{when};
|
||||
}
|
||||
|
||||
sub by
|
||||
{
|
||||
my $self = shift;
|
||||
$self->{by} = $_[0] if @_;
|
||||
return $self->{by};
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
|
@ -1,82 +0,0 @@
|
|||
#!/usr/bin/perl -Tw
|
||||
#------------------------------------------------------------------------------
|
||||
# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
|
||||
# All rights reserved.
|
||||
#
|
||||
# Redistribution and use in source and binary forms, with or without
|
||||
# modification, are permitted provided that the following conditions
|
||||
# are met:
|
||||
# 1. Redistributions of source code must retain the above copyright
|
||||
# notice, this list of conditions and the following disclaimer.
|
||||
# 2. Redistributions in binary form must reproduce the above copyright
|
||||
# notice, this list of conditions and the following disclaimer in the
|
||||
# documentation and/or other materials provided with the distribution.
|
||||
#
|
||||
# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
|
||||
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
|
||||
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
||||
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||||
# SUCH DAMAGE.
|
||||
#
|
||||
# $FreeBSD$
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
package GnatsPR::Section::Text;
|
||||
|
||||
use strict;
|
||||
|
||||
require 5.006;
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: new()
|
||||
# Desc: Constructor.
|
||||
#
|
||||
# Args: $text - Blob of text.
|
||||
#
|
||||
# Retn: $self
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my ($text) = @_;
|
||||
|
||||
my $self = {
|
||||
text => ''
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
$text =~ s/[\s\n]+$//s; # Tidy up trailing whitespace
|
||||
|
||||
$self->{text} = $text;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: string()
|
||||
# Desc: Return string contained within.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: $string
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub string
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return $self->{text};
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
|
@ -1,114 +0,0 @@
|
|||
#!/usr/bin/perl -Tw
|
||||
#------------------------------------------------------------------------------
|
||||
# Copyright (C) 2011, Shaun Amott <shaun@FreeBSD.org>
|
||||
# All rights reserved.
|
||||
#
|
||||
# Redistribution and use in source and binary forms, with or without
|
||||
# modification, are permitted provided that the following conditions
|
||||
# are met:
|
||||
# 1. Redistributions of source code must retain the above copyright
|
||||
# notice, this list of conditions and the following disclaimer.
|
||||
# 2. Redistributions in binary form must reproduce the above copyright
|
||||
# notice, this list of conditions and the following disclaimer in the
|
||||
# documentation and/or other materials provided with the distribution.
|
||||
#
|
||||
# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
|
||||
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
|
||||
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
||||
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||||
# SUCH DAMAGE.
|
||||
#
|
||||
# $FreeBSD$
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
package GnatsPR::SectionIterator;
|
||||
|
||||
use strict;
|
||||
|
||||
require 5.006;
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: new()
|
||||
# Desc: Constructor.
|
||||
#
|
||||
# Args: $gnatspr - GnatsPR instance.
|
||||
# @fields - Which fields we want sections from. The order determines
|
||||
# the order of the returned sections. Undefined behaviour if
|
||||
# no no fields specified.
|
||||
#
|
||||
# Retn: $self
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my $gnatspr = shift;
|
||||
|
||||
my $self = {
|
||||
gnatspr => $gnatspr,
|
||||
currfield => -1,
|
||||
currsection => -1,
|
||||
wantfields => []
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
while (my $f = shift) {
|
||||
push @{$self->{wantfields}}, $f;
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: next()
|
||||
# Desc: Return next iterator element.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: $next
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub next
|
||||
{
|
||||
my $self = shift;
|
||||
my ($fieldkey, $maxsection);
|
||||
|
||||
# Next section
|
||||
$self->{currsection}++;
|
||||
|
||||
# First field?
|
||||
$self->{currfield} == -1
|
||||
and $self->{currfield} = 0;
|
||||
|
||||
$fieldkey = $self->{wantfields}->[$self->{currfield}];
|
||||
$maxsection = $#{$self->{gnatspr}->{sections}->{$fieldkey}};
|
||||
|
||||
# We've passed the last section in this field
|
||||
while ($self->{currsection} > $maxsection) {
|
||||
# Next field, first section
|
||||
$self->{currfield}++;
|
||||
$self->{currsection} = 0;
|
||||
|
||||
# Run out of fields?
|
||||
$self->{currfield} > $#{$self->{wantfields}}
|
||||
and return undef;
|
||||
|
||||
# Update, and go back to check next field
|
||||
$fieldkey = $self->{wantfields}->[$self->{currfield}];
|
||||
$maxsection = $#{$self->{gnatspr}->{sections}->{$fieldkey}};
|
||||
}
|
||||
|
||||
return $self->{gnatspr}->{sections}->{$fieldkey}->[$self->{currsection}];
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
|
@ -8,28 +8,17 @@
|
|||
.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
|
||||
CGI+= mid.cgi
|
||||
CGI+= mirror.cgi
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ if (!defined($hsty_base)) {
|
|||
# However, if we aren't running as a cgi, or if we're
|
||||
# running on cgi, hub, docs or people, use the absolute home path.
|
||||
if (!defined($ENV{'HTTP_HOST'}) ||
|
||||
$ENV{'HTTP_HOST'} =~ /(cgi|hub|docs|people).freebsd.org/i) {
|
||||
$ENV{'HTTP_HOST'} =~ /(cgi|hub|docs|people|mailarchive.ysv).freebsd.org/i) {
|
||||
|
||||
$hsty_base = '//www.FreeBSD.org'
|
||||
} else {
|
||||
|
|
@ -22,7 +22,7 @@ if (!defined($hsty_base)) {
|
|||
}
|
||||
}
|
||||
if (!defined($hsty_email)) {
|
||||
$hsty_email = 'www@FreeBSD.org';
|
||||
$hsty_email = 'Contact';
|
||||
}
|
||||
if (!defined($hsty_author)) {
|
||||
$hsty_author = "<a href='$hsty_base/mailto.html'>$hsty_email</a>";
|
||||
|
|
@ -83,7 +83,7 @@ $i_topbar = qq`
|
|||
<div id="search">
|
||||
<form method="get" id="search" action="https://duckduckgo.com/">
|
||||
<h2 class="blockhide"><label for="words">Search</label></h2>
|
||||
<input type="hidden" name="sites" value="www.FreeBSD.org,lists.FreeBSD.org,wiki.FreeBSD.org,forums.FreeBSD.org" />
|
||||
<input type="hidden" name="sites" value="www.FreeBSD.org,docs.FreeBSD.org,lists.FreeBSD.org,wiki.FreeBSD.org,forums.FreeBSD.org" />
|
||||
<input type="hidden" name="ka" value="v" />
|
||||
<input type="hidden" name="kt" value="v" />
|
||||
<input type="hidden" name="kh" value="1" />
|
||||
|
|
@ -160,8 +160,8 @@ $i_topbar = qq`
|
|||
<ul>
|
||||
<li><a href="$hsty_base/commercial/commercial.html">Vendors</a></li>
|
||||
<li><a href="//security.FreeBSD.org/">Security Information</a></li>
|
||||
<li><a href="$hsty_base/cgi/query-pr-summary.cgi">Bug Reports</a></li>
|
||||
<li><a href="$hsty_base/send-pr.html">Submit Bug-report</a></li>
|
||||
<li><a href="https://bugs.freebsd.org/bugzilla/search/">Bug Reports</a></li>
|
||||
<li><a href="$hsty_base/support.html">Submit Bug-report</a></li>
|
||||
</ul>
|
||||
</li>
|
||||
</ul>
|
||||
|
|
|
|||
|
|
@ -1,117 +0,0 @@
|
|||
#!/usr/bin/perl -T
|
||||
#
|
||||
# $FreeBSD$
|
||||
#
|
||||
# Copyright (c) 2003 Eric Anderson
|
||||
# Copyright (c) 2005 Ceri Davies <ceri@FreeBSD.org>
|
||||
|
||||
use DB_File;
|
||||
use Fcntl qw(:DEFAULT :flock);
|
||||
use POSIX qw(strftime);
|
||||
use strict;
|
||||
|
||||
require './cgi-lib.pl';
|
||||
|
||||
$ENV{"PATH"} = "/bin:/usr/bin";
|
||||
$ENV{"TMPDIR"} = "/tmp";
|
||||
|
||||
my($fd, $db_obj, %db_hash, $currenttime, $randomcode, $pngbindata, $randompick, $pnmlist, $i);
|
||||
my(%db, $expiretime, $rfc1123_expiry, $pnmcat, $pnmtopng, $pnmdatadir, $dbpath, $FORM_db);
|
||||
# %in cannot be declared with 'my', or ReadParse fails.
|
||||
use vars qw/ %in /;
|
||||
|
||||
############################################
|
||||
# generate 8 character code from A-Z0-9 (no I,O,0,1 for clarity)
|
||||
my @availchars = qw(A B C D E F G H J K L M N P Q R S T U V W X Y Z
|
||||
2 3 4 5 6 7 8 9);
|
||||
|
||||
$pnmcat = "/usr/local/bin/pnmcat";
|
||||
$pnmtopng = "/usr/local/bin/pnmtopng";
|
||||
$pnmdatadir = "../gifs/";
|
||||
$expiretime = 0; # Default for the Expires: header
|
||||
############################################
|
||||
|
||||
# The code databases that we know about. If a query comes in for
|
||||
# anything else, we return a zero byte "image" (rather than an image
|
||||
# with a rude word in, which was tempting).
|
||||
|
||||
%db = (
|
||||
# The querypr one is not used, but stands as an example.
|
||||
# querypr => {
|
||||
# path => '/usr/local/www/var/confirm-code/querypr-code.db',
|
||||
# lifespan => 2700,
|
||||
# },
|
||||
sendpr => {
|
||||
path => '/usr/local/www/var/confirm-code/sendpr-code.db',
|
||||
lifespan => 2700,
|
||||
},
|
||||
);
|
||||
|
||||
&ReadParse(*in);
|
||||
$FORM_db = $in{"db"}; $FORM_db ||= "junk";
|
||||
|
||||
$currenttime = time();
|
||||
$rfc1123_expiry = strftime "%a, %b %d %H:%M:%S %Y %Z",
|
||||
gmtime($currenttime + $expiretime);
|
||||
|
||||
if (exists($db{$FORM_db})) {
|
||||
$dbpath = $db{$FORM_db}->{'path'};
|
||||
$expiretime = $db{$FORM_db}->{'lifespan'};
|
||||
|
||||
# DB stuff here
|
||||
$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: $!" }
|
||||
}
|
||||
|
||||
&gencode;
|
||||
|
||||
while ($db_hash{$randomcode}) {
|
||||
# it already exists so:
|
||||
# we check age (over x seconds old?)
|
||||
# if it is, override with new date
|
||||
# if not, generate a new code
|
||||
if ( ($currenttime - $expiretime) <= $db_hash{$randomcode}) {
|
||||
&gencode;
|
||||
} else {
|
||||
delete $db_hash{"$randomcode"};
|
||||
}
|
||||
}
|
||||
|
||||
$db_hash{$randomcode} = $currenttime;
|
||||
|
||||
$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;
|
||||
|
||||
$/ = "";
|
||||
|
||||
open(BUILDPNG, "$pnmcat -lr $pnmlist | $pnmtopng 2>/dev/null |");
|
||||
$pngbindata = <BUILDPNG>;
|
||||
close(BUILDPNG);
|
||||
} else {
|
||||
$pngbindata = undef;
|
||||
};
|
||||
|
||||
print "Pragma: no-cache\n";
|
||||
print "Expires: $rfc1123_expiry\n";
|
||||
print "Content-type: image/png\n\n";
|
||||
print "$pngbindata";
|
||||
|
||||
############################################
|
||||
sub gencode {
|
||||
srand( time() ^ ($$ + ($$ << 15)) );
|
||||
|
||||
for ($i = 0; $i < 8; $i++) {
|
||||
$randompick = $availchars[int(rand(@availchars))];
|
||||
$randomcode .= "$randompick";
|
||||
$pnmlist .= "$pnmdatadir$randompick\.pnm ";
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -1,226 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
#
|
||||
# Send-pr perl script to send a pr.
|
||||
#
|
||||
# Copyright (c) 1996 Free Range Media
|
||||
#
|
||||
# Copying and distribution permitted under the conditions of the
|
||||
# GNU General Public License Version 2.
|
||||
# (http://www.gnu.ai.mit.edu/copyleft/gpl.html)
|
||||
#
|
||||
# $FreeBSD$
|
||||
|
||||
use Socket;
|
||||
use CGI qw/:standard/;
|
||||
use DB_File;
|
||||
use Fcntl qw(:DEFAULT :flock);
|
||||
require "./Gnats.pm"; import Gnats;
|
||||
|
||||
my $blackhole = "dnsbl.njabl.org";
|
||||
my $openproxyip = "127.0.0.9";
|
||||
my $blackhole_err = 0;
|
||||
my $openproxy;
|
||||
|
||||
my $expiretime = 2700;
|
||||
$dbpath = "/usr/local/www/var/confirm-code/sendpr-code.db";
|
||||
|
||||
# Maximum size of patch that we'll accept from send-pr.html.
|
||||
$maxpatch = 102400;
|
||||
|
||||
my $patchbuf;
|
||||
my $patchhandle;
|
||||
|
||||
# Environment variables to stuff in the PR header.
|
||||
my @ENV_captures = qw/ REMOTE_HOST
|
||||
REMOTE_ADDR
|
||||
REMOTE_PORT
|
||||
HTTP_REFERER
|
||||
HTTP_CLIENT_IP
|
||||
HTTP_FORWARDED
|
||||
HTTP_VIA
|
||||
HTTP_X_FORWARDED_FOR /;
|
||||
|
||||
# env2hdr (@ENV_captures)
|
||||
# Returns X-header style headers for inclusion in the header of a PR
|
||||
sub env2hdr (@) {
|
||||
my $headers = "";
|
||||
foreach my $var (@_) {
|
||||
next unless $ENV{$var};
|
||||
$headers .= "X-$var: $ENV{$var}\n";
|
||||
}
|
||||
return $headers;
|
||||
}
|
||||
|
||||
# isopenproxy ($ip, $blackhole_zone, $positive_ip)
|
||||
# Returns undef on error, 0 if DNS lookup fails, $positive_ip if verified
|
||||
# proxy. A DNS lookup failing can either means that there was a network
|
||||
# problem, or that the IP is not listed in the blackhole zone.
|
||||
sub isopenproxy ($$$) {
|
||||
# If $? is already set, then a successful gethostbyname() leaves it set
|
||||
local $?;
|
||||
my ($ip, $zone, $proxyip) = @_;
|
||||
my ($reversed_ip, $packed);
|
||||
if (!defined $proxyip) { return undef };
|
||||
|
||||
$reversed_ip = join('.', reverse split(/\./, $ip));
|
||||
$packed = gethostbyname("${reversed_ip}.${blackhole}");
|
||||
return undef if $?;
|
||||
|
||||
if ($packed && (inet_ntoa($packed) eq $proxyip)) {
|
||||
return $proxyip;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
sub prerror {
|
||||
print start_html("Problem Report Error");
|
||||
print "<p>There is an error in the configuration of the problem\n",
|
||||
"report form generator. Please back up one page and report\n",
|
||||
"the problem to the owner of that page.<br />",
|
||||
"Report <span class=\"prerror\">$_[0]</span>.</p>";
|
||||
print end_html();
|
||||
exit (1);
|
||||
}
|
||||
|
||||
sub piloterror {
|
||||
print start_html("Problem Report Error");
|
||||
print "<p>There is an error with your problem\n",
|
||||
"report submission.\n",
|
||||
"The problem was: <span class=\"prerror\">$_[0]</span>.</p>";
|
||||
print end_html();
|
||||
exit (1);
|
||||
}
|
||||
|
||||
print header();
|
||||
|
||||
&prerror("request method problem") if $ENV{'REQUEST_METHOD'} eq 'GET';
|
||||
|
||||
if (!$submission_program) { &prerror("submit program problem"); }
|
||||
|
||||
if ($patchhandle = upload('patch')) {
|
||||
# use bytes;
|
||||
unless ((uploadInfo($patchhandle)->{'Content-Type'} =~ m!^text/.*!) ||
|
||||
(uploadInfo($patchhandle)->{'Content-Type'} =~ m!^application/shar$!)) {
|
||||
&piloterror("<p>Patch file has wrong content type: got " .
|
||||
uploadInfo($patchhandle)->{'Content-Type'} .
|
||||
" but was expecting one matching text/.* or application/shar.</p>" .
|
||||
"<p>Try renaming the file to have a .txt extension" .
|
||||
" to convince your browser to do the right thing.</p>");
|
||||
}
|
||||
read($patchhandle,$patchbuf,$maxpatch + 1);
|
||||
if (length($patchbuf) > $maxpatch) {
|
||||
&piloterror("Patch file too big (over ${maxpatch} bytes)");
|
||||
}
|
||||
}
|
||||
|
||||
# Verify the code...
|
||||
|
||||
$db_obj = tie(%db_hash, 'DB_File', $dbpath, O_CREAT|O_RDWR, 0644)
|
||||
or die "dbcreate $dbpath $!";
|
||||
$fd = $db_obj->fd;
|
||||
open(DB_FH, "+<&=$fd") or die "fdopen $!";
|
||||
|
||||
unless (flock (DB_FH, LOCK_EX | LOCK_NB)) {
|
||||
unless (flock (DB_FH, LOCK_EX)) { die "flock: $!" }
|
||||
}
|
||||
|
||||
$codeentered = param('code-confirm');
|
||||
$codeentered =~ s/.*/\U$&/; # Turn input uppercase
|
||||
$currenttime = time();
|
||||
if (defined($codeentered) && $codeentered && $db_hash{$codeentered} &&
|
||||
(($currenttime - $expiretime) <= $db_hash{$codeentered})) {
|
||||
if (!param('email') || !param('originator') ||
|
||||
!param('synopsis')) {
|
||||
print start_html("Problem Report Error");
|
||||
print "<h1>Bad Data</h1><p>You need to specify at least your ",
|
||||
"electronic mail address, your name and a synopsis ",
|
||||
"of the problem.<br /> Please return to the form and add the ",
|
||||
"missing information. Thank you.</p>";
|
||||
print end_html();
|
||||
|
||||
exit(1);
|
||||
}
|
||||
} else {
|
||||
print start_html("Problem Report Error");
|
||||
print "<h1>Incorrect confirmation code</h1><p>You need to enter the correct ",
|
||||
"code from the image displayed. Please return to the form and enter the ",
|
||||
"code exactly as shown. Thank you.</p>";
|
||||
print end_html();
|
||||
|
||||
exit(1);
|
||||
}
|
||||
|
||||
# This code has now been used, so remove it.
|
||||
delete $db_hash{"$codeentered"};
|
||||
|
||||
# Sweep for and remove expired codes.
|
||||
foreach $randomcode (keys %db_hash) {
|
||||
if ( ($currenttime - $expiretime) >= $db_hash{$randomcode}) {
|
||||
delete $db_hash{"$randomcode"};
|
||||
}
|
||||
}
|
||||
$db_obj->sync(); # to flush
|
||||
flock(DB_FH, LOCK_UN);
|
||||
undef $db_obj; # removing the last reference to the DB
|
||||
# closes it. Closing DB_FH is implicit.
|
||||
untie %db_hash;
|
||||
|
||||
|
||||
$openproxy = isopenproxy($ENV{'REMOTE_ADDR'}, $blackhole, $openproxyip);
|
||||
if (defined $openproxy) {
|
||||
if ($openproxy) {
|
||||
&prerror("$ENV{'REMOTE_ADDR'} is an open proxy server");
|
||||
}
|
||||
} else {
|
||||
$blackhole_err++;
|
||||
}
|
||||
|
||||
# Build the PR.
|
||||
$pr = "To: $submission_address\n" .
|
||||
"From: " . param('originator') . " <" . param('email') . ">\n" .
|
||||
"Subject: " . param('synopsis') . "\n" .
|
||||
env2hdr(@ENV_captures);
|
||||
if ($blackhole_err) {
|
||||
$pr .= "X-REMOTE_ADDR-Is-Open-Proxy: Maybe\n";
|
||||
}
|
||||
|
||||
$pr .= "X-Send-Pr-Version: www-3.1\n" .
|
||||
"X-GNATS-Notify: \n\n" .
|
||||
">Submitter-Id:\t" . param('submitterid') . "\n" .
|
||||
">Originator:\t" . param('originator') . "\n" .
|
||||
">Organization:\t" . param('organization') . "\n" .
|
||||
">Confidential:\t" . param('confidential') . "\n" .
|
||||
">Synopsis:\t" . param('synopsis') . "\n" .
|
||||
">Severity:\t" . param('severity') . "\n" .
|
||||
">Priority:\t" . param('priority') . "\n" .
|
||||
">Category:\t" . param('category') . "\n" .
|
||||
">Class:\t\t" . param('class') . "\n" .
|
||||
">Release:\t" . param('release') . "\n" .
|
||||
">Environment:\t" . param('environment') . "\n" .
|
||||
">Description:\n" . param('description') . "\n" .
|
||||
">How-To-Repeat:\n" . param('howtorepeat') . "\n" .
|
||||
">Fix:\n" . param('fix') . "\n";
|
||||
|
||||
if (length($patchbuf) > 0) {
|
||||
$pr .= "\nPatch attached with submission follows:\n\n"
|
||||
. $patchbuf . "\n";
|
||||
}
|
||||
|
||||
# remove any carriage returns that appear in the report.
|
||||
$pr =~ s/\r//g;
|
||||
|
||||
if (open (SUBMIT, "|$submission_program")){
|
||||
|
||||
print SUBMIT $pr;
|
||||
print SUBMIT "\n.\n";
|
||||
close (SUBMIT);
|
||||
print start_html("Thank you for the problem report");
|
||||
print "<h1>Thank You</h1>",
|
||||
"<p>Thank you for the problem report. You should receive confirmation",
|
||||
" of your report by electronic mail within a day.</p>";
|
||||
} else {
|
||||
print start_html("Error raising problem report");
|
||||
print "<h1>Error</h1><p>An error occured processing your problem report.</p>";
|
||||
}
|
||||
print end_html();
|
||||
|
|
@ -26,7 +26,7 @@ pre a:visited { color: #220000; }
|
|||
#
|
||||
# Files MUST be fully qualified and MUST start with this path.
|
||||
#
|
||||
$messagepath = "/usr/local/www/db/text/";
|
||||
$messagepath = "/usr/local/www/mailindex/archive/";
|
||||
$messagepathcurrent = "/usr/local/www/mid/archive/";
|
||||
$ftparchive = 'ftp://ftp.FreeBSD.org/pub/FreeBSD/doc/mailing-lists/archive';
|
||||
|
||||
|
|
|
|||
|
|
@ -42,10 +42,10 @@ my $up = 0;
|
|||
$| = 1;
|
||||
|
||||
# mail archive location
|
||||
$maildir = '/g/mail/archive';
|
||||
$maildir = '/home/mail/archive';
|
||||
|
||||
# mailindex program
|
||||
$mailindex = '/usr/local/www/mid/bin/mailindex';
|
||||
$mailindex = '/usr/local/www/mailindex/bin/mailindex';
|
||||
|
||||
|
||||
$query = new CGI();
|
||||
|
|
@ -82,7 +82,7 @@ sub file_not_exists {
|
|||
}
|
||||
|
||||
if ($file =~ s%^archive/%%) {
|
||||
$maildir = '/g/www/db/text';
|
||||
$maildir = '/usr/local/www/mailindex/archive';
|
||||
&file_not_exists("$maildir/$file") if (! -f "$maildir/$file");
|
||||
} elsif ($file =~ s%^current/%% && $file =~ /^freebsd-|^cvs-/) {
|
||||
&file_not_exists("$file") if (! -f "$maildir/$file");
|
||||
|
|
|
|||
|
|
@ -32,10 +32,9 @@ require "./cgi-lib.pl";
|
|||
require "./cgi-style.pl";
|
||||
|
||||
$home = '/usr/local/www/mailindex';
|
||||
$prefix= "/usr/local/www/db/text";
|
||||
$prefix= "/usr/local/www/mailindex/archive";
|
||||
$lookupdir = "$home/message-id"; # database(s) directory
|
||||
$databaseDefault = 'mid'; # default database
|
||||
$bindir = "$home/bin"; # where search scripts located
|
||||
$script = $ENV{'SCRIPT_NAME'};
|
||||
$shortid = 1;
|
||||
$lookCommand = "/usr/bin/look";
|
||||
|
|
@ -90,7 +89,7 @@ sub get_id {
|
|||
local($id, $file, $start) = split($", $idlist[0]);
|
||||
$location =~ s%/[^/]+$%%;
|
||||
local($host) = $ENV{'HTTP_HOST'};
|
||||
$location = 'http://' . $host . $location;
|
||||
$location = '//' . $host . $location;
|
||||
$start =~ s/\s+$//;
|
||||
|
||||
print "Location: $location/getmsg.cgi?fetch=$start+0+" .
|
||||
|
|
|
|||
|
|
@ -1,120 +0,0 @@
|
|||
#!/usr/bin/perl -T
|
||||
# Copyright (c) July 1997-2011. Wolfram Schneider <wosch@FreeBSD.org>
|
||||
# All rights reserved.
|
||||
#
|
||||
# Redistribution and use in source and binary forms, with or without
|
||||
# modification, are permitted provided that the following conditions
|
||||
# are met:
|
||||
# 1. Redistributions of source code must retain the above copyright
|
||||
# notice, this list of conditions and the following disclaimer.
|
||||
# 2. Redistributions in binary form must reproduce the above copyright
|
||||
# notice, this list of conditions and the following disclaimer in the
|
||||
# documentation and/or other materials provided with the distribution.
|
||||
#
|
||||
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR 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 AUTHOR 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.
|
||||
#
|
||||
# missing_handler.cgi - User friendly error response (Apache style)
|
||||
#
|
||||
#
|
||||
# default apache message:
|
||||
# ----------------------------------------------------------------------
|
||||
# File Not found
|
||||
# The requested URL /~wosch/test/bla was not found on this server.
|
||||
# ----------------------------------------------------------------------
|
||||
#
|
||||
#
|
||||
# missing_handler.cgi message:
|
||||
# ----------------------------------------------------------------------
|
||||
# FreeBSD.org - Document not found
|
||||
#
|
||||
# The file
|
||||
#
|
||||
# http://www.FreeBSD.org/~wosch/test/bla
|
||||
#
|
||||
# does not exist at this server. You are coming from
|
||||
#
|
||||
# http://www.FreeBSD.org/~wosch/test/error.html.
|
||||
#
|
||||
# The closest match to your request is http://www.FreeBSD.org.
|
||||
# Please contact the server administrator wosch@FreeBSD.org.
|
||||
#
|
||||
# Thank you very much!
|
||||
#
|
||||
# _________________________________________________________________
|
||||
#
|
||||
# $FreeBSD$
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
sub escape($) { $_ = $_[0]; s/&/&/g; s/</</g; s/>/>/g; $_; }
|
||||
sub escape2($) { $_ = $_[0]; s/</</g; s/>/>/g; $_; }
|
||||
|
||||
# output title
|
||||
$title = $ENV{'MISSING_HANDLER_TITLE'} ||
|
||||
'FreeBSD.org - Document not found';
|
||||
|
||||
# footer message
|
||||
$footer = $ENV{'MISSING_HANDLER_FOOT'} || '';
|
||||
|
||||
|
||||
# Server environment variables
|
||||
$http_referer=escape($ENV{'HTTP_REFERER'});
|
||||
$redirect_url=escape($ENV{'REDIRECT_URL'});
|
||||
$server_admin=escape($ENV{'SERVER_ADMIN'});
|
||||
$http_host=escape($ENV{'HTTP_HOST'});
|
||||
$server_name=escape($ENV{'SERVER_NAME'});
|
||||
|
||||
# rfc1738 says that ";"|"/"|"?"|":"|"@"|"&"|"=" may be reserved.
|
||||
$http_referer_url = escape2($ENV{'HTTP_REFERER'});
|
||||
$http_referer_url =~ s/([^a-zA-Z0-9;\/?:&=\.%])/sprintf("%%%02x",ord($1))/eg;
|
||||
$redirect_url_save = escape2($ENV{'REDIRECT_URL'});
|
||||
$redirect_url_save =~ s/([^a-zA-Z0-9;\/?:&=])/sprintf("%%%02x",ord($1))/eg;
|
||||
|
||||
|
||||
$hsty_base = 'http://www.FreeBSD.org';
|
||||
require './cgi-style.pl';
|
||||
print &html_header($title);
|
||||
|
||||
# HTML body
|
||||
print qq[<p>The file</p>
|
||||
<blockquote><b>
|
||||
http://$http_host$redirect_url
|
||||
</b></blockquote>
|
||||
<p>does not exist at this server.</p>\n];
|
||||
|
||||
if ($http_referer) {
|
||||
print qq{<p>You are coming from</p>
|
||||
<blockquote>
|
||||
<a href="$http_referer_url">$http_referer</a>.
|
||||
</blockquote>
|
||||
\n};
|
||||
}
|
||||
|
||||
print qq[<p>
|
||||
The closest match to your request is
|
||||
<a href="http://$server_name">http://$server_name</a>.
|
||||
|
||||
Please contact the members of the
|
||||
FreeBSD Documentation Project <<a href="mailto:freebsd-doc\@FreeBSD.org?subject=Document%20not%20found%20-%20http://$http_host$redirect_url_save&body=$http_referer_url">freebsd-doc\@FreeBSD.org</a>>
|
||||
or the server administrator
|
||||
<a href="mailto:$server_admin?subject=Document%20not%20found%20-%20http://$http_host$redirect_url_save&body=$http_referer_url">$server_admin</a>.</p>
|
||||
|
||||
<p>Please try our
|
||||
<a href="http://www.FreeBSD.org/search/index-site.html">Site Map</a> or
|
||||
<a href="http://www.FreeBSD.org/search/search.html">Search Page</a>
|
||||
</p>
|
||||
|
||||
<p>Thank you very much!</p>
|
||||
];
|
||||
|
||||
print&html_footer;
|
||||
exit;
|
||||
|
|
@ -458,10 +458,10 @@ Search for:
|
|||
%d = (
|
||||
'name', 'Package Name', 'all', 'All',
|
||||
'maintainer', 'Maintainer', 'text', 'Description',
|
||||
'pkgdescr', 'Long Description', 'requires', 'Requires',
|
||||
'requires', 'Requires',
|
||||
);
|
||||
|
||||
foreach ( 'all', 'name', 'text', 'pkgdescr', 'maintainer', 'requires' ) {
|
||||
foreach ( 'all', 'name', 'text', 'maintainer', 'requires' ) {
|
||||
print "<option"
|
||||
. ( ( $_ eq $stype ) ? ' selected="selected" ' : ' ' )
|
||||
. qq{value="$_">}
|
||||
|
|
@ -588,15 +588,6 @@ if ( $path_info eq "/source" ) {
|
|||
&exit;
|
||||
}
|
||||
|
||||
# Full text search in ports/<category>/port>/pkg-descr
|
||||
if ( $stype eq 'pkgdescr' ) {
|
||||
local ($url) =
|
||||
'http://www.FreeBSD.org/cgi/search.cgi?source=pkgdescr&max=25';
|
||||
$query =~ s/\s+/+/g;
|
||||
print "Location: $url&words=$query\n\n";
|
||||
&exit;
|
||||
}
|
||||
|
||||
if ( $stype eq "faq" ) {
|
||||
print &short_html_header( "FreeBSD Ports Search FAQ", 1 );
|
||||
&faq;
|
||||
|
|
|
|||
|
|
@ -1,167 +0,0 @@
|
|||
#!/usr/bin/perl -Tw
|
||||
# $FreeBSD$
|
||||
|
||||
sub get_categories {
|
||||
@categories = ();
|
||||
|
||||
open(Q, 'query-pr.web --list-categories 2>/dev/null |') ||
|
||||
die "Cannot get categories\n";
|
||||
|
||||
while(<Q>) {
|
||||
chop;
|
||||
local ($cat, $desc, $responsible, $notify) = split(/:/);
|
||||
push(@categories, $cat);
|
||||
$catdesc{$cat} = $desc;
|
||||
}
|
||||
}
|
||||
|
||||
sub get_states {
|
||||
@states = ();
|
||||
|
||||
open(Q, 'query-pr.web --list-states 2>/dev/null |') ||
|
||||
die "Cannot get states\n";
|
||||
|
||||
while(<Q>) {
|
||||
chop;
|
||||
local ($state, $type, $desc) = split(/:/);
|
||||
push(@states, $state);
|
||||
$statedesc{$state} = $desc;
|
||||
}
|
||||
}
|
||||
|
||||
sub get_classes {
|
||||
@classes = ();
|
||||
|
||||
open(Q, 'query-pr.web --list-classes 2>/dev/null |') ||
|
||||
die "Cannot get classes\n";
|
||||
|
||||
while(<Q>) {
|
||||
chop;
|
||||
local ($class, $type, $desc) = split(/:/);
|
||||
push(@classes, $class);
|
||||
$classdesc{$class} = $desc;
|
||||
}
|
||||
}
|
||||
|
||||
sub displayform {
|
||||
print qq`
|
||||
<p>To query the GNATS Database for specific PR number, please fill in
|
||||
this form:</p>
|
||||
<form action='./query-pr.cgi' method='get'>
|
||||
<table cellspacing='0' cellpadding='3' class='headtable'>
|
||||
<tr><td width='130'><b>PR number:</b></td><td><input type='text'
|
||||
name='pr' maxlength='30' /></td></tr>
|
||||
<tr><td width='130'><b>Category:</b></td><td><input type='text'
|
||||
name='cat' maxlength='30' /> (optional)</td></tr>
|
||||
<tr><td colspan='2'><input type='submit' value='Submit' />
|
||||
<input type='reset' value='Reset Form' /></td></tr>
|
||||
</table>
|
||||
</form>
|
||||
|
||||
<p>Alternatively, it is possible to select items you wish to search for.
|
||||
Multiple items are AND'ed together.<br />
|
||||
To generate current list of all open PRs in GNATS database, just press
|
||||
the "Query PRs" button.
|
||||
</p>
|
||||
<form method='get' action='./query-pr-summary.cgi'>
|
||||
|
||||
<table cellspacing="0" cellpadding="3" class="headtable">
|
||||
<tr>
|
||||
<td><b>Category</b>:</td>
|
||||
<td><select name='category'>
|
||||
<option selected='selected' value=''>Any</option>`;
|
||||
|
||||
&get_categories;
|
||||
foreach (sort @categories) {
|
||||
#print "<option value='$_'>$_ ($catdesc{$_})</option>\n";
|
||||
print "<option>$_</option>\n";
|
||||
}
|
||||
|
||||
print qq`
|
||||
</select></td>
|
||||
<td><b>Severity</b>:</td>
|
||||
<td><select name='severity'>
|
||||
<option selected='selected' value=''>Any</option>
|
||||
<option>non-critical</option>
|
||||
<option>serious</option>
|
||||
<option>critical</option>
|
||||
</select></td>
|
||||
</tr><tr>
|
||||
<td><b>Priority</b>:</td>
|
||||
<td><select name='priority'>
|
||||
<option selected='selected' value=''>Any</option>
|
||||
<option>low</option>
|
||||
<option>medium</option>
|
||||
<option>high</option>
|
||||
</select></td>
|
||||
<td><b>Class</b>:</td>
|
||||
<td><select name='class'>
|
||||
<option selected='selected' value=''>Any</option>
|
||||
`;
|
||||
|
||||
&get_classes;
|
||||
foreach (@classes) {
|
||||
#print "<option value='$_'>$_ ($classdesc{$_})</option>\n";
|
||||
print "<option>$_</option>\n";
|
||||
}
|
||||
|
||||
print qq`</select></td>
|
||||
</tr><tr>
|
||||
<td><b>State</b>:</td>
|
||||
<td><select name='state'>
|
||||
<option selected='selected' value=''>Any</option>
|
||||
`;
|
||||
|
||||
&get_states;
|
||||
foreach (@states) {
|
||||
($us = $_) =~ s/^./\U$&/;
|
||||
print "<option value='$_'>";
|
||||
#print "$us ($statedesc{$_})</option>\n";
|
||||
print "$us</option>\n";
|
||||
}
|
||||
|
||||
print qq`</select></td>
|
||||
<td><b>Sort by</b>:</td>
|
||||
<td><select name='sort'>
|
||||
<option value='none'>No Sort</option>
|
||||
<option value='lastmod'>Last-Modified</option>
|
||||
<option value='category'>Category</option>
|
||||
<option value='responsible'>Responsible Party</option>
|
||||
</select></td>
|
||||
</tr><tr>
|
||||
<!-- We don't use submitter Submitter: -->
|
||||
<td><b>Text in single-line fields</b>:</td>
|
||||
<td><input type='text' name='text' /></td>
|
||||
<td><b>Responsible</b>:</td>
|
||||
<td><input type='text' name='responsible' /></td>
|
||||
</tr><tr>
|
||||
<td><b>Text in multi-line fields</b>:</td>
|
||||
<td><input type='text' name='multitext' /></td>
|
||||
<td><b>Originator</b>:</td>
|
||||
<td><input type='text' name='originator' /></td>
|
||||
</tr><tr>
|
||||
<td><b>Closed reports too</b>:</td>
|
||||
<td><input name='closedtoo' value='on' type='checkbox' /></td>
|
||||
<td><b>Release</b>:</td>
|
||||
<td><select name='release'>
|
||||
<option selected='selected' value=''>Any</option>
|
||||
<option value='^FreeBSD [2345678]'>Pre-8.X</option>
|
||||
<option value='^FreeBSD 10'>10.X only</option>
|
||||
<option value='^FreeBSD 9'>9.X only</option>
|
||||
<option value='^FreeBSD 8'>8.X only</option>
|
||||
<option value='^FreeBSD 7'>7.X only</option>
|
||||
<option value='^FreeBSD 6'>6.X only</option>
|
||||
<option value='^FreeBSD 5'>5.X only</option>
|
||||
<option value='^FreeBSD 4'>4.X only</option>
|
||||
<option value='^FreeBSD 3'>3.X only</option>
|
||||
<option value='^FreeBSD 2'>2.X only</option>
|
||||
</select></td>
|
||||
</tr>
|
||||
<tr><td colspan="2"><input type='submit' value='Query PRs' />
|
||||
<input type='reset' value='Reset Form' /></td></tr>
|
||||
</table>
|
||||
</form>
|
||||
`;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,473 +0,0 @@
|
|||
#!/usr/bin/perl -T
|
||||
# $FreeBSD$
|
||||
|
||||
$html_mode = 1 if $ENV{'DOCUMENT_ROOT'};
|
||||
$self_ref = $ENV{'SCRIPT_NAME'};
|
||||
($query_pr_ref = $self_ref) =~ s/-summary//;
|
||||
|
||||
$ENV{'PATH'} = '/bin:/usr/bin:/usr/sbin:/sbin:/usr/local/bin';
|
||||
|
||||
$project = 'FreeBSD';
|
||||
$mail_prefix = 'freebsd-';
|
||||
$mail_unass = 'freebsd-bugs';
|
||||
$ports_unass = 'ports-bugs';
|
||||
$closed_too = 0;
|
||||
|
||||
require './cgi-lib.pl';
|
||||
require './cgi-style.pl';
|
||||
require './query-pr-lib.pl';
|
||||
|
||||
if (!$ENV{'QUERY_STRING'} or $ENV{'QUERY_STRING'} eq 'query') {
|
||||
print &html_header("Query $project problem reports");
|
||||
&displayform;
|
||||
print &html_footer;
|
||||
exit(0);
|
||||
}
|
||||
|
||||
if ($html_mode) {
|
||||
$query_args = '--restricted ';
|
||||
&ReadParse(*input);
|
||||
} else {
|
||||
&Getopts('CcqRr:s:T:');
|
||||
|
||||
$input{'responsible'} = 'summary' if $opt_R;
|
||||
if ($opt_r) {
|
||||
($input{'responsible'}) = ($opt_r =~ m/^(\^?[-_a-zA-Z0-9@.]*\$?)$/);
|
||||
die 'Insecure args' if ($input{'responsible'} ne $opt_r)
|
||||
}
|
||||
if ($opt_s) {
|
||||
($input{'state'}) = ($opt_s =~ m/^([a-zA-Z]*)$/);
|
||||
die 'Insecure args' if ($input{'state'} ne $opt_s)
|
||||
}
|
||||
$input{'quiet'} = 'yes' if $opt_q;
|
||||
if ($opt_C) {
|
||||
$query_args = '--confidential=yes ';
|
||||
} elsif (!$opt_c) {
|
||||
$query_args = '--restricted ';
|
||||
}
|
||||
if ($opt_T) {
|
||||
($tag) = ($opt_T =~ m/^(\^?[-_a-zA-Z0-9@.]*\$?)$/);
|
||||
die 'Insecure args' if ($tag ne $opt_T);
|
||||
$input{'text'} = '\[' . $tag . '\]';
|
||||
}
|
||||
}
|
||||
|
||||
$closed_too = 1 if $input{'state'} eq 'closed' ||
|
||||
($input{'closedtoo'} && ($input{'multitext'} || $input{'text'} || $input{'responsible'} || $input{'originator'}));
|
||||
|
||||
#------------------------------------------------------------------------
|
||||
|
||||
%mons = ('Jan', '01', 'Feb', '02', 'Mar', '03',
|
||||
'Apr', '04', 'May', '05', 'Jun', '06',
|
||||
'Jul', '07', 'Aug', '08', 'Sep', '09',
|
||||
'Oct', '10', 'Nov', '11', 'Dec', '12');
|
||||
|
||||
|
||||
if ($html_mode) {
|
||||
|
||||
$pr = '<pre>'; $pr_e = '</pre>';
|
||||
$h1 = '<h1>'; $h1_e = '</h1>';
|
||||
$h3 = '<h3>'; $h3_e = '</h3>';
|
||||
$hr = '<hr/>';
|
||||
|
||||
$table = "<table width='100%' border='0' cellspacing='1' cellpadding='0'>";
|
||||
$table_e = '</table>';
|
||||
|
||||
# Customizations for the look and feel of the summary tables.
|
||||
$t_style = "<style type='text/css'><!--\n" .
|
||||
"table { background-color: #ccc; color: #000; }\n" .
|
||||
"tr { padding: 0; }\n" .
|
||||
"th { background-color: #cbd2ec; color: #000; padding: 2px;\n" .
|
||||
" text-align: left; font-weight: normal; font-style: italic; }\n" .
|
||||
"td { color: #000; padding: 2px; }\n" .
|
||||
"td a { text-decoration: none; }\n" .
|
||||
".o { background-color: #fff; }\n" .
|
||||
".a { background-color: #cffafd; }\n" .
|
||||
".f { background-color: #ffc; }\n" .
|
||||
".p { background-color: #d1fbd6; }\n" .
|
||||
".s { background-color: #fcccd9; }\n" .
|
||||
".c { background-color: #c1d5db; }\n" .
|
||||
"--></style>";
|
||||
|
||||
} else {
|
||||
|
||||
$pr = ''; $pr_e = '';
|
||||
$h1 = ''; $h1_e = '';
|
||||
$h3 = ''; $h3_e = '';
|
||||
$hr = "\n----------------------------------------" .
|
||||
"---------------------------------------\n";
|
||||
|
||||
$table = '';
|
||||
$table_e = '';
|
||||
}
|
||||
|
||||
sub cgiparam {
|
||||
local ($result) = @_;
|
||||
|
||||
$result =~ s/[^A-Za-z0-9+.@-]/"%".sprintf("%02X", unpack("C", $&))/ge;
|
||||
$result;
|
||||
}
|
||||
|
||||
sub header_info {
|
||||
if ($html_mode) {
|
||||
print &html_header("Current $project problem reports");
|
||||
}
|
||||
else {
|
||||
print "Current $project problem reports\n";
|
||||
}
|
||||
if (!$input{'quiet'}) {
|
||||
print "The following is an old and incomplete of current problems submitted by $project users. ";
|
||||
if ($html_mode) {
|
||||
print <<EOM;
|
||||
<h1>FreeBSD has migrated to <a href="https://bugs.FreeBSD.org/search/">Bugzilla</a>. Please update your bookmarks and try your search there.</h1>
|
||||
EOM
|
||||
}
|
||||
}
|
||||
|
||||
if ($html_mode) {
|
||||
|
||||
# These self references are attempts to only change a single variable at a time.
|
||||
# If someone does a multiple-variable query they will probably do weird things.
|
||||
|
||||
$self_ref1 = $self_ref . '?';
|
||||
$self_ref1 .= 'sort=' . html_fixline($input{'sort'}) if $input{'sort'};
|
||||
print "<p>You may view summaries by <a href='$self_ref1'>Severity</a>, ";
|
||||
$self_ref1 .= '&' if ($self_ref1 !~/\?$/);
|
||||
print "<a href='${self_ref1}state=summary'>State</a>, ";
|
||||
print "<a href='${self_ref1}category=summary'>Category</a>, or ";
|
||||
print "<a href='${self_ref1}responsible=summary'>Responsible Party</a>.\n";
|
||||
|
||||
$self_ref2 = $self_ref . '?';
|
||||
foreach ('category', 'originator', 'priority', 'class', 'responsible',
|
||||
'severity', 'state', 'submitter', 'text', 'multitext', 'closedtoo') {
|
||||
if ($input{$_}) {
|
||||
$self_ref2 .= '&' if ($self_ref2 !~/\?$/);
|
||||
$self_ref2 .= $_ . '=' . cgiparam($input{$_});
|
||||
}
|
||||
}
|
||||
|
||||
print 'You may also sort by ';
|
||||
print "<a href='$self_ref2&sort=lastmod'>Last-Modified</a>, ";
|
||||
print "<a href='$self_ref2&sort=category'>Category</a>, or ";
|
||||
print "<a href='$self_ref2&sort=responsible'>Responsible Party</a>.\n";
|
||||
print "Or <a href='$self_ref?query'>formulate a specific query</a>.\n";
|
||||
|
||||
$self_ref3 = $self_ref . '?';
|
||||
foreach ('category', 'originator', 'priority', 'class', 'responsible',
|
||||
'severity', 'state', 'submitter', 'text', 'multitext', 'sort') {
|
||||
if ($input{$_}) {
|
||||
$self_ref3 .= '&' if ($self_ref2 !~/\?$/);
|
||||
$self_ref3 .= $_ . '=' . cgiparam($input{$_});
|
||||
}
|
||||
}
|
||||
|
||||
if ($input{'closedtoo'}) {
|
||||
print "<a href='$self_ref3'>Do not show closed reports</a>.";
|
||||
} else {
|
||||
print "<a href='$self_ref3&closedtoo=on'>Include closed reports too</a>.";
|
||||
}
|
||||
|
||||
print "</p>\n";
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
&header_info;
|
||||
|
||||
#Usage: query-pr [-FGhiPRqVx] [-C confidential] [-c category] [-d directory]
|
||||
# [-e severity] [-m mtext] [-O originator] [-o outfile] [-p priority]
|
||||
# [-L class] [-r responsible] [-S submitter] [-s state] [-t text]
|
||||
# [-b date] [-a date] [-B date] [-M date] [-z date] [-Z date]
|
||||
# [-y synopsis] [-A release] [--full] [--help] [--print-path] [--version]
|
||||
# [--summary] [--sql] [--skip-closed] [--category=category]
|
||||
# [--confidential=yes|no] [--directory=directory] [--output=outfile]
|
||||
# [--originator=name] [--priority=level] [--class=class]
|
||||
# [--responsible=person] [--release=release] [--restricted]
|
||||
# [--quarter=quarter] [--keywords=regexp]
|
||||
# [--required-before=date] [--required-after=date]
|
||||
# [--arrived-before=date] [--arrived-after=date]
|
||||
# [--modified-before=date] [--modified-after=date]
|
||||
# [--closed-before=date] [--closed-after=date]
|
||||
# [--severity=severity] [--state=state] [--submitter=submitter]
|
||||
# [--list-categories] [--list-classes] [--list-responsible]
|
||||
# [--list-states] [--list-submitters] [--list-config]
|
||||
# [--synopsis=synopsis] [--text=text] [--multitext=mtext] [PR] [PR]...
|
||||
|
||||
$query_args .= ' --skip-closed' unless $closed_too;
|
||||
|
||||
# Only read the appropriate PR's.
|
||||
foreach ('category', 'originator', 'priority', 'class', 'responsible',
|
||||
'release', 'severity', 'state', 'submitter', 'text', 'multitext') {
|
||||
if ($input{$_} && $input{$_} ne 'summary') {
|
||||
# Check if the arguments provided by user are secure.
|
||||
# This is required to be able to run this script in
|
||||
# taint mode (perl -T)
|
||||
if ($input{$_} =~ /^([-^'\/\[\]\@\s\w.]+)$/) {
|
||||
$d = $1;
|
||||
$d =~ s/^"(.*)"$/$&/;
|
||||
$d =~ s/'/\\'/;
|
||||
$query_args .= " --${_}='$d'";
|
||||
} else {
|
||||
print "Insecure data in ${_}! Ignoring this filter.<br />".
|
||||
"Only alphanumeric characters and ', /, -, [, ], ^, @ are allowed.";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
&read_gnats($query_args);
|
||||
|
||||
if ($input{'sort'} eq 'lastmod') {
|
||||
@prs = sort {$lastmod{$b} cmp $lastmod{$a}} @prs;
|
||||
} elsif ($input{'sort'} eq 'category') {
|
||||
@prs = sort {($ca,$na)=split(m|/|,$a); ($cb,$nb)=split(m|/|,$b); $ca eq $cb ? $na <=> $nb : $ca cmp $cb} @prs;
|
||||
} elsif ($input{'sort'} eq 'responsible') {
|
||||
@prs = sort {$resp{$a} cmp $resp{$b}} @prs;
|
||||
} else {
|
||||
$input{'sort'} = 'none';
|
||||
}
|
||||
|
||||
if ($#prs < $[) {
|
||||
print "${h1}Please try <a href='https://bugs.FreeBSD.org/search/'>bugzilla</a> for an up to date search mechanism.${h1_e}\n";
|
||||
|
||||
} elsif ($input{'responsible'} eq 'summary') {
|
||||
&resp_summary;
|
||||
|
||||
} elsif ($input{'state'} eq 'summary') {
|
||||
&state_summary;
|
||||
|
||||
} elsif ($input{'category'} eq 'summary') {
|
||||
&cat_summary;
|
||||
|
||||
} elsif ($input{'severity'} eq '') {
|
||||
&severity_summary;
|
||||
|
||||
} else {
|
||||
&printcnt(&gnats_summary(1, $html_mode));
|
||||
|
||||
}
|
||||
|
||||
print &html_footer if $html_mode;
|
||||
|
||||
exit(0);
|
||||
|
||||
#------------------------------------------------------------------------
|
||||
|
||||
sub getline {
|
||||
local($_) = @_;
|
||||
($tag,$remainder) = split(/[ \t]+/, $_, 2);
|
||||
return $remainder;
|
||||
}
|
||||
|
||||
sub html_fixline {
|
||||
local($line) = @_[0];
|
||||
|
||||
$line =~ s/&/&/g;
|
||||
$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(<Q>) {
|
||||
chop;
|
||||
if(/^>Number:/) {
|
||||
$number = &getline($_);
|
||||
|
||||
} elsif (/Arrival-Date:/) {
|
||||
$date = &getline($_);
|
||||
# strip timezone if any (between HH:MM:SS and YYYY at end of line):
|
||||
$date =~ s/(\d\d:\d\d:\d\d)\D+(\d{4})$/\1 \2/;
|
||||
($dow,$mon,$day,$time,$year,$xtra) = split(/[ \t]+/, $date);
|
||||
$day = "0$day" if $day =~ /^[0-9]$/;
|
||||
$date = "$year/$mons{$mon}/$day";
|
||||
|
||||
} elsif (/>Last-Modified:/) {
|
||||
$lastmod = &getline($_);
|
||||
if ($lastmod =~ /^[ ]*$/) {
|
||||
$lastmod = $date;
|
||||
} else {
|
||||
# strip timezone if any (between HH:MM:SS and YYYY at end of line):
|
||||
$lastmod =~ s/(\d\d:\d\d:\d\d)\D+(\d{4})$/\1 \2/;
|
||||
($dow,$mon,$day,$time,$year,$xtra) = split(/[ \t]+/, $lastmod);
|
||||
$day = "0$day" if $day =~ /^[0-9]$/;
|
||||
$lastmod = "$year/$mons{$mon}/$day";
|
||||
}
|
||||
|
||||
} elsif (/>Category:/) {
|
||||
$cat = &getline($_);
|
||||
|
||||
} elsif (/>Severity:/) {
|
||||
$sev = &getline($_);
|
||||
|
||||
} elsif (/>Responsible:/) {
|
||||
$resp = &getline($_);
|
||||
$resp =~ s/@.*//;
|
||||
$resp =~ tr/A-Z/a-z/;
|
||||
$resp = "" if (($resp =~ /$mail_unass/o) or ($resp =~ /$ports_unass/o));
|
||||
$resp =~ s/^$mail_prefix//;
|
||||
|
||||
} elsif (/>State:/) {
|
||||
$status = &getline($_);
|
||||
$status =~ s/(.).*/\1/;
|
||||
|
||||
} elsif (/>Synopsis:/) {
|
||||
$syn = &getline($_);
|
||||
$syn =~ s/[\t]+/ /g;
|
||||
|
||||
|
||||
} elsif (/^$/) {
|
||||
$_ = sprintf("%s/%s", $cat, $number);
|
||||
|
||||
$status{$_} = $status;
|
||||
$date{$_} = $date;
|
||||
$resp{$_} = $resp;
|
||||
$syn{$_} = $syn;
|
||||
$sev{$_} = $sev;
|
||||
$lastmod{$_} = $lastmod;
|
||||
push(@prs,$_);
|
||||
}
|
||||
}
|
||||
close(Q);
|
||||
}
|
||||
|
||||
sub gnats_summary {
|
||||
local($report) = @_[0];
|
||||
local($htmlmode) = @_[1];
|
||||
local($counter) = 0;
|
||||
|
||||
foreach (@prs) {
|
||||
$state = $status{$_};
|
||||
$date = $date{$_};
|
||||
$resp = $resp{$_};
|
||||
$syn = $syn{$_};
|
||||
$severity = $sev{$_};
|
||||
($cat, $number) = m|^([^/]+)/(\d+)$|;
|
||||
|
||||
next if (($report ne '') && (eval($report) == 0));
|
||||
|
||||
if ($htmlmode) {
|
||||
$title = "<a href='$query_pr_ref?pr=$cat/$number'>$_</a>";
|
||||
$syn = &html_fixline($syn);
|
||||
gnats_summary_line_html($counter, $state, $date, $title, $resp, $syn);
|
||||
} else {
|
||||
$title = $_;
|
||||
gnats_summary_line_text($counter, $state, $date, $title, $resp, $syn);
|
||||
}
|
||||
|
||||
$counter++;
|
||||
}
|
||||
|
||||
if ($htmlmode) {
|
||||
print "${table_e}\n" if $counter;
|
||||
} else {
|
||||
print "${pr_e}\n" if $counter;
|
||||
}
|
||||
|
||||
$counter;
|
||||
}
|
||||
|
||||
sub gnats_summary_line_html {
|
||||
local($counter) = shift;
|
||||
local($state) = shift;
|
||||
local($date) = shift;
|
||||
local($title) = shift;
|
||||
local($resp) = shift;
|
||||
local($syn) = shift;
|
||||
|
||||
if ($counter == 0) {
|
||||
print "$table<tr><th>S</th><th>Submitted</th><th>Tracker</th><th>Resp.</th><th>Description</th></tr>\n"
|
||||
}
|
||||
|
||||
print "<tr class='$state'><td>$state</td><td>$date</td><td>$title</td><td>$resp</td><td>$syn</td></tr>\n";
|
||||
}
|
||||
|
||||
sub gnats_summary_line_text {
|
||||
local($counter) = shift;
|
||||
local($state) = shift;
|
||||
local($date) = shift;
|
||||
local($title) = shift;
|
||||
local($resp) = shift;
|
||||
local($syn) = shift;
|
||||
|
||||
# Print the banner line if this is the first iteration.
|
||||
print "${pr}\nS Submitted Tracker Resp. Description${hr}"
|
||||
if ($counter == 0);
|
||||
print "$state $date $title" .
|
||||
(' ' x (17 - length($_))) .
|
||||
$resp . (' ' x (10 - length($resp))) .
|
||||
substr($syn,0,39) . "\n";
|
||||
}
|
||||
|
|
@ -1,858 +0,0 @@
|
|||
#!/usr/bin/perl -Tw
|
||||
#------------------------------------------------------------------------------
|
||||
# GNATS query-pr Interface, Generation III
|
||||
#
|
||||
# Copyright (C) 2006-2011, Shaun Amott <shaun@FreeBSD.org>
|
||||
# All rights reserved.
|
||||
#
|
||||
# Redistribution and use in source and binary forms, with or without
|
||||
# modification, are permitted provided that the following conditions
|
||||
# are met:
|
||||
# 1. Redistributions of source code must retain the above copyright
|
||||
# notice, this list of conditions and the following disclaimer.
|
||||
# 2. Redistributions in binary form must reproduce the above copyright
|
||||
# notice, this list of conditions and the following disclaimer in the
|
||||
# documentation and/or other materials provided with the distribution.
|
||||
#
|
||||
# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
|
||||
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
|
||||
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
||||
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||||
# SUCH DAMAGE.
|
||||
#
|
||||
# $FreeBSD$
|
||||
#
|
||||
# Useful PRs for testing:
|
||||
#
|
||||
# - ports/147261 - RFC 2047 words, attachments, interjected e-mail (inc.
|
||||
# malformed header)
|
||||
# - ports/138672 - Lots of attachments, multi-level MIME.
|
||||
# - ports/132344 - Base64-encoded attachment.
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
BEGIN { push @INC, '.'; }
|
||||
|
||||
use CGI;
|
||||
|
||||
use GnatsPR;
|
||||
use GnatsPR::SectionIterator;
|
||||
use GnatsPR::MIMEIterator;
|
||||
|
||||
#use MIME::EncWords (decode_mimewords); # mail/p5-MIME-EncWords
|
||||
sub decode_mimewords { wantarray ? @_ : join ' ', @_; } # Temp. substitute for the above
|
||||
|
||||
require './cgi-style.pl';
|
||||
require './query-pr-lib.pl';
|
||||
|
||||
use strict;
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Constants
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
use constant EXIT_NOPRS => 1;
|
||||
use constant EXIT_DBBUSY => 2;
|
||||
use constant EXIT_NOPATCH => 3;
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Globals
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
our $valid_category = '[a-z0-9][A-Za-z0-9-_]{1,25}';
|
||||
our $valid_pr = '\d{1,8}';
|
||||
|
||||
our $stylesheet = "$main::hsty_base/layout/css/query-pr.css";
|
||||
|
||||
our $iscgi = defined $ENV{'SCRIPT_NAME'};
|
||||
|
||||
# Keep this ahead of CGI
|
||||
|
||||
if (!$iscgi && !exists $ENV{'REQUEST_METHOD'}) {
|
||||
# Makes debugging easier
|
||||
$ENV{'REQUEST_METHOD'} = 'GET';
|
||||
}
|
||||
|
||||
# Stuff from cgi-style.pl
|
||||
|
||||
$main::hsty_base ||= '';
|
||||
$main::t_style ||= '';
|
||||
$main::hsty_charset ||= '';
|
||||
|
||||
$main::hsty_charset = 'utf-8';
|
||||
|
||||
$main::t_style =
|
||||
qq{<link href="$stylesheet" rel="stylesheet" type="text/css" />
|
||||
<link rel="search" type="application/opensearchdescription+xml"
|
||||
href="http://www.freebsd.org/search/opensearch/query-pr.xml"
|
||||
title="FreeBSD Bugs" />
|
||||
};
|
||||
|
||||
# Global CGI accessor
|
||||
|
||||
our $q = new CGI;
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Environment vars
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
$ENV{'PATH'} = '/bin:/usr/bin:/usr/sbin:/sbin:/usr/local/bin';
|
||||
|
||||
$ENV{'SCRIPT_NAME'} ||= $0;
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Begin Code
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
main();
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Main routine
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub main
|
||||
{
|
||||
my ($PR, $category, $rawdata, $gnatspr);
|
||||
|
||||
binmode STDOUT, ':utf8';
|
||||
|
||||
if ($q->param('pr')) {
|
||||
$PR = $q->param('pr');
|
||||
} elsif ($q->param('q')) {
|
||||
$PR = $q->param('q');
|
||||
} elsif ($q->param('prp')) {
|
||||
# Legacy param format
|
||||
my $prp = $q->param('prp');
|
||||
|
||||
if ($prp =~ /^(\d+)-(\d+)/) {
|
||||
my $get = $2;
|
||||
$PR = $1;
|
||||
|
||||
$q->param(-name => 'pr', -value => $PR);
|
||||
$q->param(-name => 'getpatch', -value => $get);
|
||||
} else {
|
||||
ErrorExit();
|
||||
}
|
||||
} else {
|
||||
ErrorExit(EXIT_NOPRS);
|
||||
}
|
||||
|
||||
if ($PR =~ /^($valid_category)\/($valid_pr)$/) {
|
||||
$category = $1;
|
||||
$PR = $2;
|
||||
}
|
||||
|
||||
length $PR > 0
|
||||
or ErrorExit();
|
||||
|
||||
# category may be undef
|
||||
$rawdata = DoQueryPR($PR, $category);
|
||||
|
||||
# Dump the raw PR data if requested
|
||||
if ($q->param('f') && $q->param('f') eq 'raw') {
|
||||
print "Content-type: text/plain; charset=UTF-8\r\n\r\n";
|
||||
print $$rawdata;
|
||||
Exit();
|
||||
}
|
||||
|
||||
# Run PR text through the parser
|
||||
$gnatspr = GnatsPR->new($rawdata);
|
||||
|
||||
# User is requesting a patch extraction?
|
||||
if ($q->param('getpatch')) {
|
||||
my ($patch, $patchnum);
|
||||
|
||||
$patchnum = $q->param('getpatch');
|
||||
$patchnum =~ s/[^0-9]+//g;
|
||||
|
||||
$patch = $gnatspr->GetAttachment($patchnum);
|
||||
|
||||
defined $patch
|
||||
or ErrorExit(EXIT_NOPATCH);
|
||||
|
||||
printf 'Content-type: %s; charset=UTF-8'."\r\n",
|
||||
($patch->isbinary ? 'application/octet-stream' : 'text/plain');
|
||||
|
||||
printf 'Content-Length: %s'."\r\n"
|
||||
. 'Content-Disposition: inline; filename="%s"'."\r\n\r\n",
|
||||
$patch->size,
|
||||
$patch->filename;
|
||||
|
||||
print $patch->data;
|
||||
print "\n";
|
||||
|
||||
Exit();
|
||||
}
|
||||
|
||||
# Otherwise, output PR
|
||||
|
||||
PrintPR($gnatspr);
|
||||
|
||||
Exit();
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: DoQueryPR()
|
||||
# Desc: Invoke the query-pr binary and return the results as a blob of text.
|
||||
# Exits gracefully on failure.
|
||||
#
|
||||
# Args: $PR - PR number
|
||||
# $cat - PR category (optional)
|
||||
#
|
||||
# Retn: \$data - Ref. to raw data.
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub DoQueryPR
|
||||
{
|
||||
my ($PR, $cat) = @_;
|
||||
my ($data);
|
||||
|
||||
$PR =~ s/[^0-9]+//g;
|
||||
$PR = quotemeta $PR;
|
||||
|
||||
# Note: query-pr.web is just an anti DoS wrapper around query-pr which
|
||||
# makes sure we do not run too many query-pr instances at once.
|
||||
if (defined $cat) {
|
||||
$cat =~ s/[^0-9A-Za-z-]+//g;
|
||||
$cat = quotemeta $cat;
|
||||
$data = qx(query-pr.web --full --category=${cat} ${PR} 2>&1);
|
||||
} else {
|
||||
$data = qx(query-pr.web --full ${PR} 2>&1);
|
||||
}
|
||||
|
||||
if (!$data or $data =~ /^query-pr(:?\.(:?real|web))?: /) {
|
||||
ErrorExit(EXIT_NOPRS);
|
||||
} elsif ($data =~ /^lockf: /) {
|
||||
ErrorExit(EXIT_DBBUSY);
|
||||
}
|
||||
|
||||
return \$data;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: PrintPR()
|
||||
# Desc: Output the parsed PR.
|
||||
#
|
||||
# Args: $gnatspr - GnatsPR instance.
|
||||
#
|
||||
# Retn: n/a
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub PrintPR
|
||||
{
|
||||
my ($gnatspr) = @_;
|
||||
|
||||
# Page title
|
||||
|
||||
print html_header(
|
||||
"FreeBSD has migrated to Bugzilla. Please check the current <a href='https://bugs.FreeBSD.org/"
|
||||
. $gnatspr->FieldSingle('Number') . "'/>Bugzilla version</a> of this PR."
|
||||
);
|
||||
print "<h3>The historical version shown below is likely out of date and is for debugging purposes only!</h3>\n";
|
||||
|
||||
print "<h3>" .
|
||||
$q->escapeHTML(
|
||||
$gnatspr->FieldSingle('Category')
|
||||
. '/'
|
||||
. $gnatspr->FieldSingle('Number')
|
||||
. ': '
|
||||
. $gnatspr->FieldSingle('Synopsis')
|
||||
) . "</h3>\n";
|
||||
|
||||
# Header stuff of interest
|
||||
|
||||
print $q->start_table({-class => 'headtable'});
|
||||
|
||||
foreach my $field ('From', 'Date', 'Subject') {
|
||||
my $val = $q->escapeHTML(
|
||||
scalar decode_mimewords($gnatspr->Header($field))
|
||||
);
|
||||
print $q->Tr(
|
||||
$q->td({-class => 'key'}, $field . ':'),
|
||||
$q->td({-class => 'val'}, $val)
|
||||
)
|
||||
}
|
||||
|
||||
print $q->Tr(
|
||||
$q->td({-class => 'key'}, 'Send-pr version:'),
|
||||
$q->td({-class => 'val'}, $q->escapeHTML($gnatspr->Header('x-send-pr-version')))
|
||||
);
|
||||
|
||||
print $q->end_table;
|
||||
|
||||
# Single fields
|
||||
|
||||
print $q->start_table({-class => 'headtable'});
|
||||
|
||||
foreach my $field (
|
||||
'Number',
|
||||
'Category',
|
||||
'Synopsis',
|
||||
'Severity',
|
||||
'Priority',
|
||||
'Responsible',
|
||||
'State',
|
||||
'Class',
|
||||
'Arrival-Date',
|
||||
'Closed-Date',
|
||||
'Last-Modified',
|
||||
'Originator',
|
||||
'Release'
|
||||
) {
|
||||
my $val = $q->escapeHTML($gnatspr->FieldSingle($field));
|
||||
print $q->Tr(
|
||||
$q->td({-class => 'key'}, $field . ":"),
|
||||
$q->td({-class => 'val'}, $val)
|
||||
);
|
||||
}
|
||||
|
||||
print $q->end_table;
|
||||
|
||||
# Sections
|
||||
|
||||
my $iter = GnatsPR::SectionIterator->new(
|
||||
$gnatspr,
|
||||
# Fields we want sections from; this also
|
||||
# dictates the order they will come.
|
||||
'Organization',
|
||||
'Environment',
|
||||
'Description',
|
||||
'How-To-Repeat',
|
||||
'Fix',
|
||||
'Release-Note',
|
||||
'Audit-Trail',
|
||||
'Unformatted'
|
||||
);
|
||||
|
||||
my $replynum = 0;
|
||||
my $patchnum = 0;
|
||||
|
||||
while (my $item = $iter->next()) {
|
||||
# Start of new field
|
||||
if (ref $item eq 'GnatsPR::Section::FieldStart') {
|
||||
my $text = $item->string();
|
||||
$text = $q->escapeHTML($text);
|
||||
#print $q->h2($text);
|
||||
print $q->table({-class => 'mfieldtable'},
|
||||
$q->Tr($q->td({-class => 'blkhead'}, $text)));
|
||||
next;
|
||||
}
|
||||
|
||||
# A chunk of text
|
||||
if (ref $item eq 'GnatsPR::Section::Text') {
|
||||
my $text = $item->string();
|
||||
$text = $q->escapeHTML($text);
|
||||
$text = Linkify($text);
|
||||
$text = AddBreaks($text);
|
||||
|
||||
# Table used to ensure text CSS consistency (evil, I know)
|
||||
print $q->table($q->tbody($q->Tr($q->td({class => 'mfield'}, $text))))
|
||||
if $text;
|
||||
#print $q->p($text);
|
||||
|
||||
next;
|
||||
}
|
||||
|
||||
# Patch block
|
||||
if (ref $item eq 'GnatsPR::Section::Patch') {
|
||||
my $text = $item->string();
|
||||
$text = $q->escapeHTML($text);
|
||||
$text = ColourPatch($text)
|
||||
if ($item->type eq 'diff');
|
||||
$text = AddBreaks($text); # Unless binary
|
||||
|
||||
print AttachmentHeader($item->{filename}, ++$patchnum);
|
||||
print $text;
|
||||
print AttachmentFooter();
|
||||
|
||||
next;
|
||||
}
|
||||
|
||||
# Audit-Trail state/responsible change block
|
||||
if (ref $item eq 'GnatsPR::Section::StateChange') {
|
||||
# This must be hard-coded - the old value will still
|
||||
# linger in PRs, even if the script moves.
|
||||
my $selfurl = "http://www.freebsd.org/cgi/query-pr.cgi?pr="
|
||||
. $gnatspr->FieldSingle('Number');
|
||||
|
||||
# Remove the URL, as it is merely clutter
|
||||
my $why = $item->why;
|
||||
$why =~ s/[\n\s]*\Q$selfurl\E[\n\s]*$//i;
|
||||
$item->why($why);
|
||||
|
||||
print $q->table({-class => 'auditblock', -cellspacing => '1'},
|
||||
$q->Tr(
|
||||
$q->th(
|
||||
{-colspan => 2, -class => 'info'},
|
||||
$q->escapeHTML($item->what) . " Changed"
|
||||
)
|
||||
),
|
||||
|
||||
$q->Tr(
|
||||
$q->td({-class => 'key'}, 'From-To:'),
|
||||
$q->td(
|
||||
$q->escapeHTML(
|
||||
$item->from . '->' . $item->to
|
||||
)
|
||||
)
|
||||
),
|
||||
|
||||
$q->Tr(
|
||||
$q->td({-class => 'key'}, 'By:'),
|
||||
$q->td($q->escapeHTML($item->by))
|
||||
),
|
||||
|
||||
$q->Tr(
|
||||
$q->td({-class => 'key'}, 'When:'),
|
||||
$q->td($q->escapeHTML($item->when))
|
||||
),
|
||||
|
||||
$q->Tr(
|
||||
$q->td({-class => 'key'}, 'Why:'),
|
||||
AddBreaks($q->td($q->escapeHTML($item->why)))
|
||||
)
|
||||
);
|
||||
|
||||
next;
|
||||
}
|
||||
|
||||
# Reply via E-mail
|
||||
if (ref $item eq 'GnatsPR::Section::Email') {
|
||||
print $q->start_table({-class => 'replyblock',
|
||||
-cellspacing => '1'});
|
||||
|
||||
$replynum++;
|
||||
|
||||
print $q->Tr($q->th(
|
||||
{-colspan => 2, -class => 'info'},
|
||||
'Reply via E-mail '
|
||||
. $q->a({href => '#reply'.$replynum,
|
||||
name => 'reply'.$replynum}, '[Link]')
|
||||
));
|
||||
|
||||
# Try to determine if sender is submitter
|
||||
|
||||
my $fromtag = FromSubmitter($item, $gnatspr)
|
||||
? $q->b(' [submitter]') : '';
|
||||
|
||||
# Print header
|
||||
|
||||
foreach my $f ('From', 'To', 'Date') {
|
||||
print $q->Tr(
|
||||
$q->td({-class => 'key'}, $f . ':'),
|
||||
$q->td({-class => 'val'},
|
||||
$q->escapeHTML(
|
||||
scalar decode_mimewords($item->Header($f))
|
||||
)
|
||||
.
|
||||
(($f eq 'From') ? $fromtag : '')
|
||||
)
|
||||
);
|
||||
}
|
||||
|
||||
print $q->start_Tr;
|
||||
print $q->start_td({-colspan => 2});
|
||||
|
||||
# MIME parts
|
||||
|
||||
my $mime_iter = GnatsPR::MIMEIterator->new($item);
|
||||
|
||||
while (my $part = $mime_iter->next()) {
|
||||
my $ctype = $part->header('content-type');
|
||||
my $elide = 0;
|
||||
|
||||
print $q->hr({-class => 'mimeboundary'})
|
||||
unless ($mime_iter->isfirst);
|
||||
|
||||
$part->isattachment
|
||||
and ++$patchnum;
|
||||
|
||||
# Skip (inline) HTML parts -- but only if we have
|
||||
# a plaintext part. We could possibly be a bit more
|
||||
# rigorous in verifying the existence of the latter,
|
||||
# but testing for the MIME header or other part will
|
||||
# suffice, as it is unlikely a HTML-only e-mail will
|
||||
# have more than that single part.
|
||||
if ($ctype eq 'text/html' && !$part->isattachment &&
|
||||
!$mime_iter->isfirst) {
|
||||
$elide = 1;
|
||||
|
||||
# S/MIME signatures - of questionable value here
|
||||
} elsif ($ctype eq 'application/pkcs7-signature') {
|
||||
$elide = 1;
|
||||
}
|
||||
|
||||
if ($elide) {
|
||||
if ($part->isattachment) {
|
||||
my $url = $q->url(-full => 1, -query => 1);
|
||||
|
||||
my $dlink =
|
||||
$q->a({-href => $url . '&getpatch=' . $patchnum},
|
||||
'[Download]');
|
||||
|
||||
print $q->div(
|
||||
{-class => 'elidemsg'},
|
||||
'Attachment of type "' . $q->escapeHTML($ctype)
|
||||
. '" ' . $dlink
|
||||
);
|
||||
} else {
|
||||
print $q->div(
|
||||
{-class => 'elidemsg'},
|
||||
'MIME part of type "' . $q->escapeHTML($ctype)
|
||||
. '" elided'
|
||||
);
|
||||
}
|
||||
|
||||
next;
|
||||
}
|
||||
|
||||
$part->isattachment
|
||||
and print AttachmentHeader($part->filename, $patchnum);
|
||||
|
||||
if ($part->isbinary) { # Implies isattachment
|
||||
print $q->escapeHTML($part->body);
|
||||
} else {
|
||||
my $text;
|
||||
|
||||
if ($part->header('content-type') eq 'text/plain'
|
||||
&& !$part->isattachment) {
|
||||
# ColourEmail escapes too
|
||||
$text = Linkify(ColourEmail($part->data));
|
||||
} else {
|
||||
$text = $q->escapeHTML($part->data);
|
||||
}
|
||||
|
||||
if ($part->isattachment
|
||||
&& $part->filename =~ /\.(?:diff|patch)\b/i) {
|
||||
$text = ColourPatch($text);
|
||||
}
|
||||
|
||||
print AddBreaks($text);
|
||||
}
|
||||
|
||||
$part->isattachment
|
||||
and print AttachmentFooter();
|
||||
}
|
||||
|
||||
print $q->end_td;
|
||||
print $q->end_Tr;
|
||||
}
|
||||
|
||||
print $q->end_table;
|
||||
}
|
||||
|
||||
print FooterLinks($gnatspr);
|
||||
|
||||
print html_footer();
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: AddBreaks()
|
||||
# Desc: Convert newlines to HTML break elements.
|
||||
#
|
||||
# Args: $text - Input
|
||||
#
|
||||
# Retn: $text - Output
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub AddBreaks
|
||||
{
|
||||
my $text = shift;
|
||||
|
||||
$text =~ s/\n/<br \/>/g;
|
||||
|
||||
return $text;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: Linkify()
|
||||
# Desc: Perform any fancy formatting on the message (e.g. HTML-ify URLs) and
|
||||
# return the result.
|
||||
#
|
||||
# Args: $html - Input string
|
||||
#
|
||||
# Retn: $html - Output string
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub Linkify
|
||||
{
|
||||
my ($html) = @_;
|
||||
|
||||
# XXX: clean up
|
||||
|
||||
$html or return '';
|
||||
|
||||
my $iv = 'A-Za-z0-9\-_\/#@\$=\\\\';
|
||||
|
||||
my $scriptname = $q->escapeHTML($ENV{'SCRIPT_NAME'});
|
||||
|
||||
# PR references
|
||||
$html =~
|
||||
s/(?<![$iv])($valid_category)\/($valid_pr)(?![$iv])/<a href="${scriptname}?pr=$2&cat=$1">$1\/$2<\/a>/g;
|
||||
|
||||
# URLs
|
||||
$html =~
|
||||
s/((?:https?|ftps?):\/\/[^\s\/]+\/[][\w=.,\'\(\)\~\?\!\&\/\%\$\{\}:;@#+-]*)/<a href="$1">$1<\/a>/g;
|
||||
|
||||
return $html;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: ColourPatch()
|
||||
# Desc: Apply 'cdiff' style colours to a patch.
|
||||
#
|
||||
# Args: $html - Input string
|
||||
#
|
||||
# Retn: $html - Output string
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub ColourPatch
|
||||
{
|
||||
my ($html) = @_;
|
||||
my $res = '';
|
||||
|
||||
# XXX: clean up
|
||||
|
||||
my $plus_s = $q->start_span({-class => 'patch_plusline'});
|
||||
my $minus_s = $q->start_span({-class => 'patch_minusline'});
|
||||
my $context_s = $q->start_span({-class => 'patch_contextline'});
|
||||
my $revinfo_s = $q->start_span({-class => 'patch_revinfo'});
|
||||
my $at_s = $q->start_span({-class => 'patch_hunkinfo'});
|
||||
my $all_e = $q->end_span;
|
||||
|
||||
# Expand tabs
|
||||
while ($html =~ s/\t/" " x (8 - ((length($`)-1) % 8))/e) {};
|
||||
|
||||
foreach my $line (split /\n/, $html) {
|
||||
$line =~ s/^(\+.*)$/${plus_s}$1${all_e}/o;
|
||||
$line =~ s/^(-.*)$/${minus_s}$1${all_e}/o
|
||||
if $line !~ s/^(--- \d+,\d+ ----.*)$/${revinfo_s}$1${all_e}/o;
|
||||
$line =~ s/^(\*\*\* \d+,\d+ *\*\*\*.*)$/${revinfo_s}$1${all_e}/o;
|
||||
$line =~ s/^(\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*)$/${revinfo_s}$1${all_e}/o;
|
||||
$line =~ s/^(!.*)$/${context_s}$1${all_e}/o;
|
||||
$line =~ s/^(@@.*$)/${at_s}$1${all_e}/o;
|
||||
$line =~ s/^ / /;
|
||||
$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 <a href='https://bugs.FreeBSD.org/search/'>Bugzilla</a>. Try your search there.");
|
||||
print html_footer();
|
||||
} elsif ($code == EXIT_DBBUSY) {
|
||||
print html_header("PR Database Busy");
|
||||
print $q->p(
|
||||
'Please '
|
||||
. $q->a({-href => $url}, 'try again')
|
||||
. ' later'
|
||||
);
|
||||
print html_footer();
|
||||
} elsif ($code == EXIT_NOPATCH) {
|
||||
print "Content-type: text/plain; charset=UTF-8\r\n\r\n";
|
||||
print "No such patch!\n";
|
||||
}
|
||||
|
||||
Exit();
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: FromSubmitter()
|
||||
# Desc: Try determine if the sender of a reply is the sender of the PR.
|
||||
#
|
||||
# Args: $item - GnatsPR::Section::Email instance.
|
||||
# $gnatspr - GnatsPR instance
|
||||
#
|
||||
# Retn: $result - Is sender the submitter?
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub FromSubmitter
|
||||
{
|
||||
my ($item, $gnatspr) = @_;
|
||||
|
||||
my $from = lc $item->Header('From');
|
||||
my $submitter = lc $gnatspr->Header('From');
|
||||
|
||||
$from =~ s/^.*<// and $from =~ s/>.*$//;
|
||||
$from =~ s/\s+//g;
|
||||
$submitter =~ s/^.*<// and $submitter =~ s/>.*$//;
|
||||
$submitter =~ s/\s+//g;
|
||||
|
||||
return $from eq $submitter;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: AttachmentHeader()
|
||||
# Desc: Construct an attachment block header.
|
||||
#
|
||||
# Args: $filename - Name of attachment.
|
||||
# $patchnum - Patch index.
|
||||
#
|
||||
# Retn: $text - Header text.
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub AttachmentHeader
|
||||
{
|
||||
my ($filename, $patchnum) = @_;
|
||||
|
||||
my $text = '';
|
||||
|
||||
my $url = $q->url(-full => 1, -query => 1);
|
||||
|
||||
$text .= $q->start_table({-class => 'patchblock', -cellspacing => '1'});
|
||||
$text .=
|
||||
$q->Tr(
|
||||
$q->td({-class => 'info'}, $q->b(
|
||||
'Download ' . $q->a({-href => $url . '&getpatch=' . $patchnum},
|
||||
$filename)
|
||||
))
|
||||
);
|
||||
|
||||
$text .= $q->start_tbody;
|
||||
$text .= $q->start_Tr;
|
||||
$text .= $q->start_td({-class => 'content'});
|
||||
$text .= $q->start_pre({-class => 'attachwin'});
|
||||
|
||||
return $text;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: AttachmentFooter()
|
||||
# Desc: Construct an attachment block footer.
|
||||
#
|
||||
# Args: n/a
|
||||
#
|
||||
# Retn: $text - Footer text.
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub AttachmentFooter
|
||||
{
|
||||
my $text = '';
|
||||
|
||||
$text .= $q->end_pre;
|
||||
$text .= $q->end_td;
|
||||
$text .= $q->end_Tr;
|
||||
$text .= $q->end_tbody;
|
||||
$text .= $q->end_table;
|
||||
|
||||
return $text;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
# Func: FooterLinks()
|
||||
# Desc: Construct the page footer links (for a valid PR page)
|
||||
#
|
||||
# Args: $gnatspr - GnatsPR instance.
|
||||
#
|
||||
# Retn: $text - Footer text.
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub FooterLinks
|
||||
{
|
||||
my ($gnatspr) = @_;
|
||||
|
||||
my $url = $q->url(-full => 1, -query => 1);
|
||||
|
||||
return $q->div({-class => 'footerlinks'},
|
||||
$q->a({-href => $url . '&f=raw'}, 'Raw PR')
|
||||
);
|
||||
}
|
||||
|
|
@ -1,267 +0,0 @@
|
|||
#!/usr/bin/perl -T
|
||||
#
|
||||
# mail-archive.pl -- a CGI interface to a wais indexed maling list archive.
|
||||
#
|
||||
# Origin:
|
||||
# Tony Sanders <sanders@bsdi.com>, Nov 1993
|
||||
#
|
||||
# Hacked beyond recognition by:
|
||||
# John Fieber <jfieber@cs.smith.edu>, Nov 1994
|
||||
#
|
||||
# Format the mail messages a little nicer.
|
||||
# Add code to check database status before searching.
|
||||
# John Fieber <jfieber@indiana.edu>, Aug 1996
|
||||
#
|
||||
# Disclaimer:
|
||||
# This is pretty ugly in places.
|
||||
#
|
||||
# $FreeBSD$
|
||||
|
||||
|
||||
$server_root = '/usr/local/www';
|
||||
$waisq = "/usr/local/www/bin/waisq";
|
||||
$sourcepath = "$server_root/db/index";
|
||||
$hints = "/search/searchhints.html";
|
||||
$searchpage = '/search/search.html';
|
||||
$myurl = $ENV{'SCRIPT_NAME'};
|
||||
$ENV{PATH} = "/bin:/usr/bin:/usr/local/bin";
|
||||
|
||||
use IPC::Open2 'open2';
|
||||
require "./cgi-lib.pl";
|
||||
require "./cgi-style.pl";
|
||||
|
||||
@months = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
|
||||
|
||||
sub escape($) { $_ = $_[0]; s/&/&/g; s/</</g; s/>/>/g; $_; }
|
||||
|
||||
sub do_wais {
|
||||
&ReadParse;
|
||||
|
||||
@FORM_words = map { s|"||g; $_ } split(/ /, escape($in{"words"}));
|
||||
@FORM_source = split(/\0/, escape($in{"source"}));
|
||||
($FORM_max) = $in{"max"} =~ m|^(\d+)$|;
|
||||
$FORM_docnum = $in{"docnum"};
|
||||
$FORM_index = $in{"index"};
|
||||
|
||||
if ($FORM_index =~ /^re[sc]ent$/) {
|
||||
$sourcepath = "$server_root/db/index-recent";
|
||||
}
|
||||
|
||||
if ($#FORM_words < 0) {
|
||||
print &html_header("Mail Archive Search") .
|
||||
"<p>No search term given.";
|
||||
print "<p>\nPlease return to the " .
|
||||
"search page and fill out the 'Search for' field!\n";
|
||||
print &html_footer;
|
||||
exit 0;
|
||||
}
|
||||
|
||||
@AVAIL_source = &checksource(@FORM_source);
|
||||
if ($#FORM_source != $#AVAIL_source) {
|
||||
$j = 0;
|
||||
$k = 0;
|
||||
foreach $i (0 .. $#FORM_source) {
|
||||
if ($FORM_source[$i] ne $AVAIL_source[$j]) {
|
||||
$badsource[$k] = $FORM_source[$i];
|
||||
$k++;
|
||||
} else {
|
||||
$j++;
|
||||
}
|
||||
}
|
||||
$badsource = join("</em>, <em>", @badsource);
|
||||
$badsource =~ s/,([^,]*)$/ and $1/;
|
||||
if ($#FORM_source - $#AVAIL_source > 1) {
|
||||
$availmsg = "<p>[The <em>$badsource</em> archives are currently unavailable.]</p>";
|
||||
} else {
|
||||
$availmsg = "<p>[The <em>$badsource</em> archive is currently unavailable.]</p>";
|
||||
}
|
||||
}
|
||||
if ($#AVAIL_source < 0) {
|
||||
$i = join("</em>, <em>", @FORM_source);
|
||||
$i =~ s/,([^,]*)$/ and $1/;
|
||||
print &html_header("Mail Archive Search") .
|
||||
"<p>None of the archives you requested (<em>$i</em>) are " .
|
||||
" available at this time.</p>\n";
|
||||
print "<p>Please try again later, or return to the " .
|
||||
"search page and select a different archive.</p>\n";
|
||||
print &html_footer;
|
||||
exit 0;
|
||||
}
|
||||
|
||||
# Now we formulate the question to ask the server
|
||||
foreach $i (@AVAIL_source) {
|
||||
$w_sources .= "(:source-id\n :filename \"$i.src\"\n ) ";
|
||||
}
|
||||
$w_question = "\n (:question
|
||||
:version 2
|
||||
:seed-words \"@FORM_words\"
|
||||
:relevant-documents
|
||||
( )
|
||||
:sourcepath \"$sourcepath/:\"
|
||||
:sources
|
||||
( $w_sources )
|
||||
:maximum-results $FORM_max
|
||||
:result-documents
|
||||
( )
|
||||
)\n";
|
||||
|
||||
|
||||
#
|
||||
# First case, no document number so this is a regular search
|
||||
#
|
||||
print &html_header("Search Results");
|
||||
print $availmsg;
|
||||
if ($#AVAIL_source > 0) {
|
||||
$src = join("</em>, <em>", @AVAIL_source);
|
||||
$src =~ s/,([^,]*)$/ and $1/;
|
||||
print "<p>The archives <em>$src</em> contain ";
|
||||
}
|
||||
else {
|
||||
print "The archive <em>@AVAIL_source</em> contains ";
|
||||
}
|
||||
print " the following items relevant to \`@FORM_words\':\n";
|
||||
print "<ol>\n";
|
||||
|
||||
&open2(WAISOUT, WAISIN, $waisq, "-g");
|
||||
print WAISIN $w_question;
|
||||
|
||||
local(@mylist) = ();
|
||||
local($hits, $score, $headline, $lines, $bytes, $docid, $date, $file);
|
||||
|
||||
while (<WAISOUT>) {
|
||||
/:original-local-id.*#\(\s+([^\)]*)/ &&
|
||||
($docid = pack("C*", split(/\s+/, $1)),
|
||||
$docid =~ s/\s+/+/g);
|
||||
/:score\s+(\d+)/ && ($score = $1);
|
||||
/:filename "(.*)"/ && ($file = $1);
|
||||
/:number-of-lines\s+(\d+)/ && ($lines = $1);
|
||||
/:number-of-bytes\s+(\d+)/ && ($bytes = $1);
|
||||
/:headline "(.*)"/ && ($headline = $1,
|
||||
$headline =~ s/[Rr]e://); # XXX
|
||||
/:date "(\d+)"/ && $docid !~ /\.src$/ && ($date = $1, $hits++,
|
||||
push(@mylist, join("\t", $date, $headline, $docid,
|
||||
$bytes, $lines, $file, $score, $hits)));
|
||||
}
|
||||
|
||||
if ($in{'sort'} eq "date") {
|
||||
foreach (reverse sort {$a <=> $b} @mylist) {
|
||||
($date, $headline, $docid, $bytes, $lines,
|
||||
$file, $score, $hits) = split("\t");
|
||||
&docdone;
|
||||
}
|
||||
} elsif ($in{'sort'} eq "subject") {
|
||||
local(@a, @c, $b, $d);
|
||||
foreach (@mylist) {
|
||||
@a = split("\t");
|
||||
$b = $a[0];
|
||||
# swap date and subject
|
||||
if ($a[1] =~ /(^[^:]+)(Re:.*)/) {
|
||||
$a[0] = "$2\t$1";
|
||||
} else {
|
||||
$a[0] = "$a[1]\t.";
|
||||
}
|
||||
$a[1] = $b;
|
||||
push(@c, join("\t", @a));
|
||||
}
|
||||
local($subject, $author);
|
||||
foreach (sort {$a cmp $b} @c) {
|
||||
($subject, $author, $date, $docid, $bytes,
|
||||
$lines, $file, $score, $hits) = split("\t");
|
||||
$headline = $author . $subject;
|
||||
&docdone;
|
||||
}
|
||||
|
||||
} elsif ($in{'sort'} eq "author") {
|
||||
local(@a, @c, $b);
|
||||
foreach (@mylist) {
|
||||
@a = split("\t");
|
||||
# swap date and subject
|
||||
$b = $a[0]; $a[0] = $a[1]; $a[1] = $b;
|
||||
push(@c, join("\t", @a));
|
||||
}
|
||||
foreach (sort {$a cmp $b} @c) {
|
||||
($headline, $date, $docid, $bytes,
|
||||
$lines, $file, $score, $hits) = split("\t");
|
||||
&docdone;
|
||||
}
|
||||
|
||||
} else {
|
||||
foreach (@mylist) {
|
||||
($date, $headline, $docid, $bytes,
|
||||
$lines, $file, $score, $hits) = split("\t");
|
||||
&docdone;
|
||||
}
|
||||
}
|
||||
#print qq[in: $in{'sort'}\n];
|
||||
|
||||
print "</ol>\n";
|
||||
|
||||
print "<p>Didn't get what you expected? ";
|
||||
print "<a href=\"$hints\">Look here for searching hints</a>.</p>";
|
||||
|
||||
print qq{<p><a href="$searchpage">Return to the search page</a></p>\n};
|
||||
|
||||
if ($hits == 0) {
|
||||
print "Nothing found.\n";
|
||||
}
|
||||
|
||||
print &html_footer;
|
||||
close(WAISOUT);
|
||||
close(WAISIN);
|
||||
|
||||
}
|
||||
|
||||
# Given an array of sources (sans .src extension), this routine
|
||||
# checks to see if they actually exist, and if they do, if they
|
||||
# are currently available (ie, not being updated). It returns
|
||||
# an array of sources that are actually available.
|
||||
|
||||
sub checksource {
|
||||
local (@sources) = @_;
|
||||
|
||||
$j = 0;
|
||||
foreach $i (@sources) {
|
||||
($i) = $i =~ m|^([-a-z0-9]*)|;
|
||||
if (stat("$sourcepath/$i.src")) {
|
||||
if (!stat("$sourcepath/$i.update.lock")) {
|
||||
$goodsources[$j] = $i;
|
||||
$j++;
|
||||
}
|
||||
}
|
||||
}
|
||||
return(@goodsources);
|
||||
}
|
||||
|
||||
sub docdone {
|
||||
$file =~ s/\.src$//;
|
||||
if ($headline =~ /Search produced no result/) {
|
||||
print "<p>The archive <em>$file</em> contains no relevant documents.</p>"
|
||||
} else {
|
||||
$headline = escape($headline);
|
||||
$headline =~ s/\\"/\"/g;
|
||||
if ($file eq "www" || $file =~ /^www-[a-z][a-z]$/ || $file eq 'pkgdescr' || $file eq "manpages") {
|
||||
print "<li><a href=\"$headline\">$headline</a>\n";
|
||||
} else {
|
||||
print "<li><a href=\"getmsg.cgi?fetch=${docid}\">$headline</a>\n";
|
||||
}
|
||||
print "<br/>";
|
||||
# print "<input type=\"checkbox\" name=\"rf\" value=\"$docnum\"/>";
|
||||
print "Score: <em>$score</em>; ";
|
||||
$_ = $date;
|
||||
/^(..?)(..)(..)$/ && ($yr = $1 + ($1 > 69 ? 1900 : 2000), $mo = $months[$2 - 1], $dy = $3);
|
||||
print "Lines: <em>$lines</em>; ";
|
||||
print "${dy}-${mo}-${yr}; ";
|
||||
print "Archive: <em>$file</em>";
|
||||
print "<p></p></li>\n";
|
||||
}
|
||||
$score = $headline = $lines = $bytes = $docid = $date = $file = '';
|
||||
$yr = $mo = $dy = '';
|
||||
}
|
||||
|
||||
$| = 1;
|
||||
open (STDERR,"> /dev/null");
|
||||
#open (STDERR,">> /tmp/search");
|
||||
eval '&do_wais';
|
||||
if ($@) {
|
||||
warn "eval failed: $@";
|
||||
}
|
||||
Loading…
Add table
Add a link
Reference in a new issue