#!/usr/bin/perl -wT package debbugs; use strict; use POSIX qw(strftime tzset); use MIME::Parser; use MIME::Decoder; use IO::Scalar; use IO::Lines; use IO::File; #require '/usr/lib/debbugs/errorlib'; require './common.pl'; require '/etc/debbugs/config'; require '/etc/debbugs/text'; use vars(qw($gEmailDomain $gHTMLTail $gSpoolDir $gWebDomain)); # for read_log_records use Debbugs::Log; use Debbugs::MIME qw(convert_to_utf8 decode_rfc1522); use Scalar::Util qw(looks_like_number); my %param = readparse(); my $tail_html; my $ref = $param{'bug'} || quitcgi("No bug number"); $ref =~ /(\d+)/ or quitcgi("Invalid bug number"); $ref = $1; my $short = "#$ref"; my $msg = $param{'msg'} || ""; my $att = $param{'att'}; my $boring = ($param{'boring'} || 'no') eq 'yes'; my $terse = ($param{'terse'} || 'no') eq 'yes'; my $reverse = ($param{'reverse'} || 'no') eq 'yes'; my $mbox = ($param{'mbox'} || 'no') eq 'yes'; my $mime = ($param{'mime'} || 'yes') eq 'yes'; my $trim_headers = ($param{trim} || ($msg?'no':'yes')) eq 'yes'; # Not used by this script directly, but fetch these so that pkgurl() and # friends can propagate them correctly. my $archive = ($param{'archive'} || 'no') eq 'yes'; my $repeatmerged = ($param{'repeatmerged'} || 'yes') eq 'yes'; set_option('archive', $archive); set_option('repeatmerged', $repeatmerged); my $buglog = buglog($ref); if ($ENV{REQUEST_METHOD} eq 'HEAD' and not defined($att) and not $mbox) { print "Content-Type: text/html; charset=utf-8\n"; my @stat = stat $buglog; if (@stat) { my $mtime = strftime '%a, %d %b %Y %T GMT', gmtime($stat[9]); print "Last-Modified: $mtime\n"; } print "\n"; exit 0; } sub display_entity ($$$$\$\@); sub display_entity ($$$$\$\@) { my $entity = shift; my $ref = shift; my $top = shift; my $xmessage = shift; my $this = shift; my $attachments = shift; my $head = $entity->head; my $disposition = $head->mime_attr('content-disposition'); $disposition = 'inline' if not defined $disposition or $disposition eq ''; my $type = $entity->effective_type; my $filename = $entity->head->recommended_filename; $filename = '' unless defined $filename; $filename = decode_rfc1522($filename); if ($top) { my $header = $entity->head; if ($trim_headers and not $terse) { my @headers; foreach (qw(From To Cc Subject Date)) { my $head_field = $head->get($_); next unless defined $head_field and $head_field ne ''; push @headers, qq($_: ) . htmlsanit(decode_rfc1522($head_field)); } $$this .= join(qq(), @headers) unless $terse; $$this .= qq(\n); } elsif (not $terse) { $$this .= htmlsanit(decode_rfc1522($entity->head->stringify)); $$this .= qq(\n); } } unless (($top and $type =~ m[^text(?:/plain)?(?:;|$)]) or ($type =~ m[^multipart/])) { push @$attachments, $entity; my @dlargs = ($ref, "msg=$xmessage", "att=$#$attachments"); push @dlargs, "filename=$filename" if $filename ne ''; my $printname = $filename; $printname = 'Message part ' . ($#$attachments + 1) if $filename eq ''; $$this .= '[$printname } . "($type, $disposition)]\n\n"; if ($msg and defined($att) and $att eq $#$attachments) { my $head = $entity->head; chomp(my $type = $entity->effective_type); my $body = $entity->stringify_body; print "Content-Type: $type\n"; if ($filename ne '') { my $qf = $filename; $qf =~ s/"/\\"/g; $qf =~ s[.*/][]; print qq{Content-Disposition: attachment; filename="$qf"\n}; } print "\n"; my $decoder = new MIME::Decoder($head->mime_encoding); $decoder->decode(new IO::Scalar(\$body), \*STDOUT); exit(0); } } return if not $top and $disposition eq 'attachment' and not defined($att); return unless ($type =~ m[^text/?] and $type !~ m[^text/(?:html|enriched)(?:;|$)]) or $type =~ m[^application/pgp(?:;|$)] or $entity->parts; if ($entity->is_multipart) { my @parts = $entity->parts; foreach my $part (@parts) { display_entity($part, $ref, 0, $xmessage, $$this, @$attachments); $$this .= "\n"; } } elsif ($entity->parts) { # We must be dealing with a nested message. $$this .= "
\n"; my @parts = $entity->parts; foreach my $part (@parts) { display_entity($part, $ref, 1, $xmessage, $$this, @$attachments); $$this .= "\n"; } $$this .= "\n"; } else { if (not $terse) { my $content_type = $entity->head->get('Content-Type:'); my ($charset) = $content_type =~ m/charset\s*=\s*\"?([\w-]+)\"?/i; my $body = $entity->bodyhandle->as_string; $body = convert_to_utf8($body,$charset) if defined $charset; $body = htmlsanit($body); $body =~ s,((ftp|http|https)://[\S~-]+?/?)((\>\;)?[)]?[']?[:.\,]?(\s|$)),$1$3,go; $$this .= $body; } } } my %maintainer = %{getmaintainers()}; my %pkgsrc = %{getpkgsrc()}; my $indexentry; my $descriptivehead; my $showseverity; my $tpack; my $tmain; $ENV{"TZ"} = 'UTC'; tzset(); my $dtime = strftime "%a, %e %b %Y %T UTC", localtime; $tail_html = $debbugs::gHTMLTail; $tail_html =~ s/SUBSTITUTE_DTIME/$dtime/; my %status = %{getbugstatus($ref)}; unless (%status) { print <
There is no record of $debbugs::gBug $short. Try the search page instead.
$tail_html EOF exit 0; } $|=1; $tpack = lc $status{'package'}; my @tpacks = splitpackages($tpack); if ($status{severity} eq 'normal') { $showseverity = ''; #} elsif (isstrongseverity($status{severity})) { # $showseverity = "Severity: $status{severity};\n"; } else { $showseverity = "Severity: $status{severity};\n"; } $indexentry .= "$showseverity";
$indexentry .= htmlpackagelinks($status{package}, 0) . ";\n";
$indexentry .= htmladdresslinks("Reported by: ", \&submitterurl,
$status{originator}) . ";\n";
$indexentry .= "Owned by: " . htmlsanit($status{owner}) . ";\n"
if length $status{owner};
my $dummy = strftime "%a, %e %b %Y %T UTC", localtime($status{date});
$indexentry .= "Date: ".$dummy.";\n
";
my @descstates;
push @descstates, "Tags: "
. htmlsanit(join(", ", sort(split(/\s+/, $status{tags}))))
. ""
if length($status{tags});
my @merged= split(/ /,$status{mergedwith});
if (@merged) {
my $descmerged = 'merged with ';
my $mseparator = '';
for my $m (@merged) {
$descmerged .= $mseparator."#$m";
$mseparator= ",\n";
}
push @descstates, $descmerged;
}
if (@{$status{found_versions}}) {
my $foundtext = 'Found in ';
$foundtext .= (@{$status{found_versions}} == 1) ? 'version ' : 'versions ';
$foundtext .= join ', ', map htmlsanit($_), @{$status{found_versions}};
push @descstates, $foundtext;
}
if (@{$status{fixed_versions}}) {
my $fixedtext = 'Fixed in ';
$fixedtext .= (@{$status{fixed_versions}} == 1) ? 'version ' : 'versions ';
$fixedtext .= join ', ', map htmlsanit($_), @{$status{fixed_versions}};
if (length($status{done})) {
$fixedtext .= ' by ' . htmlsanit(decode_rfc1522($status{done}));
}
push @descstates, $fixedtext;
} elsif (length($status{done})) {
push @descstates, "Done: ".htmlsanit(decode_rfc1522($status{done}));
} elsif (length($status{forwarded})) {
push @descstates, "Forwarded to ".maybelink($status{forwarded});
}
$indexentry .= join(";\n", @descstates) . ";\n
" if @descstates;
$descriptivehead = $indexentry;
foreach my $pkg (@tpacks) {
my $tmaint = defined($maintainer{$pkg}) ? $maintainer{$pkg} : '(unknown)';
my $tsrc = defined($pkgsrc{$pkg}) ? $pkgsrc{$pkg} : '(unknown)';
$descriptivehead .=
htmlmaintlinks(sub { $_[0] == 1 ? "Maintainer for $pkg is\n"
: "Maintainers for $pkg are\n" },
$tmaint);
$descriptivehead .= ";\nSource for $pkg is\n".
'$tsrc" if ($tsrc ne "(unknown)");
$descriptivehead .= ".\n
";
}
my $buglogfh;
if ($buglog =~ m/\.gz$/) {
my $oldpath = $ENV{'PATH'};
$ENV{'PATH'} = '/bin:/usr/bin';
$buglogfh = new IO::File "zcat $buglog |" or &quitcgi("open log for $ref: $!");
$ENV{'PATH'} = $oldpath;
} else {
$buglogfh = new IO::File "<$buglog" or &quitcgi("open log for $ref: $!");
}
if ($buglog !~ m#^\Q$gSpoolDir/db#) {
$descriptivehead .= "\n
Bug is archived. No further changes may be made.
"; } my @records = read_log_records($buglogfh); undef $buglogfh; =head2 handle_email_message handle_email_message($record->{text}, ref => $bug_number, msg_number => $msg_number, ); Returns a decoded e-mail message and displays entities/attachments as appropriate. =cut sub handle_email_message{ my ($email,%options) = @_; my $output = ''; my $parser = new MIME::Parser; $parser->tmp_to_core(1); $parser->output_to_core(1); # $parser->output_under("/tmp"); my $entity = $parser->parse_data( $email); # TODO: make local subdir, clean it ourselves # the following does NOT delete the msg dirs in /tmp END { if ( $entity ) { $entity->purge; } if ( $parser ) { $parser->filer->purge; } } my @attachments = (); display_entity($entity, $options{ref}, 1, $options{msg_number}, $output, @attachments); return $output; } =head2 bug_links bug_links($one_bug); bug_links($starting_bug,$stoping_bugs,); Creates a set of links to bugs, starting with bug number $starting_bug, and finishing with $stoping_bug; if only one bug is passed, makes a link to only a single bug. The content of the link is the bug number. =cut sub bug_links{ my ($start,$stop,$query_arguments) = @_; $stop = $stop || $start; $query_arguments ||= ''; my @output; for my $bug ($start..$stop) { push @output,'$bug); } return join(', ',@output); } =head2 handle_record push @log, handle_record($record,$ref,$msg_num); Deals with a record in a bug log as returned by LView this report as an mbox folder.
\n", mboxurl($ref); print "