4 use Fcntl qw/O_RDONLY/;
8 $config_path = '/etc/debbugs';
9 $lib_path = '/usr/lib/debbugs';
10 require "$lib_path/errorlib";
12 use Debbugs::Versions;
14 $MLDBM::RemoveTaint = 1;
16 my $common_archive = 0;
17 my $common_repeatmerged = 1;
18 my %common_include = ();
19 my %common_exclude = ();
20 my $common_raw_sort = 0;
21 my $common_bug_reverse = 0;
22 my $common_pending_reverse = 0;
23 my $common_severity_reverse = 0;
25 my @common_pending_include = ();
26 my @common_pending_exclude = ();
27 my @common_severity_include = ();
28 my @common_severity_exclude = ();
38 if ($opt eq "archive") { $common_archive = $val; }
39 if ($opt eq "repeatmerged") { $common_repeatmerged = $val; }
40 if ($opt eq "exclude") {
42 @vals = ( $val ) if (ref($val) eq "" && $val );
43 @vals = ( $$val ) if (ref($val) eq "SCALAR" && $$val );
44 @vals = @{$val} if (ref($val) eq "ARRAY" );
45 %common_exclude = map {
46 if (/^(.*):(.*)$/) { ($1, $2) } else { ($_, 1) }
47 } split /[\s,]+/, join ',', @vals;
49 if ($opt eq "include") {
51 @vals = ( $val, ) if (ref($val) eq "" && $val );
52 @vals = ( $$val, ) if (ref($val) eq "SCALAR" && $$val );
53 @vals = @{$val} if (ref($val) eq "ARRAY" );
54 %common_include = map {
55 if (/^(.*):(.*)$/) { ($1, $2) } else { ($_, 1) }
56 } split /[\s,]+/, join ',', @vals;
58 if ($opt eq "raw") { $common_raw_sort = $val; }
59 if ($opt eq "bug-rev") { $common_bug_reverse = $val; }
60 if ($opt eq "pend-rev") { $common_pending_reverse = $val; }
61 if ($opt eq "sev-rev") { $common_severity_reverse = $val; }
62 if ($opt eq "pend-exc") {
64 @vals = ( $val ) if (ref($val) eq "" && $val );
65 @vals = ( $$val ) if (ref($val) eq "SCALAR" && $$val );
66 @vals = @{$val} if (ref($val) eq "ARRAY" );
67 @common_pending_exclude = @vals if (@vals);
69 if ($opt eq "pend-inc") {
71 @vals = ( $val, ) if (ref($val) eq "" && $val );
72 @vals = ( $$val, ) if (ref($val) eq "SCALAR" && $$val );
73 @vals = @{$val} if (ref($val) eq "ARRAY" );
74 @common_pending_include = @vals if (@vals);
76 if ($opt eq "sev-exc") {
78 @vals = ( $val ) if (ref($val) eq "" && $val );
79 @vals = ( $$val ) if (ref($val) eq "SCALAR" && $$val );
80 @vals = @{$val} if (ref($val) eq "ARRAY" );
81 @common_severity_exclude = @vals if (@vals);
83 if ($opt eq "sev-inc") {
85 @vals = ( $val ) if (ref($val) eq "" && $val );
86 @vals = ( $$val ) if (ref($val) eq "SCALAR" && $$val );
87 @vals = @{$val} if (ref($val) eq "ARRAY" );
88 @common_severity_include = @vals if (@vals);
90 if ($opt eq "version") { $common_version = $val; }
91 if ($opt eq "dist") { $common_dist = $val; }
92 if ($opt eq "arch") { $common_arch = $val; }
96 my ($in, $key, $val, %ret);
97 if (defined $ENV{"QUERY_STRING"} && $ENV{"QUERY_STRING"} ne "") {
98 $in=$ENV{QUERY_STRING};
99 } elsif(defined $ENV{"REQUEST_METHOD"}
100 && $ENV{"REQUEST_METHOD"} eq "POST")
102 read(STDIN,$in,$ENV{CONTENT_LENGTH});
106 foreach (split(/[&;]/,$in)) {
108 ($key, $val) = split(/=/,$_,2);
109 $key=~s/%(..)/pack("c",hex($1))/ge;
110 $val=~s/%(..)/pack("c",hex($1))/ge;
111 if ( exists $ret{$key} ) {
112 if ( !exists $ret{"&$key"} ) {
113 $ret{"&$key"} = [ $ret{$key} ];
115 push @{$ret{"&$key"}},$val;
119 $debug = 1 if (defined $ret{"debug"} && $ret{"debug"} eq "aj");
125 print "Content-Type: text/html\n\n";
126 print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
127 print "An error occurred. Dammit.\n";
128 print "Error was: $msg.\n";
129 print "</BODY></HTML>\n";
135 # my $Archive = $common_archive ? "archive" : "";
136 # print header . start_html("Sorry");
137 # print "Sorry bug #$msg doesn't seem to be in the $Archive database.\n";
142 # Split a package string from the status file into a list of package names.
145 return unless defined $pkgs;
146 return map lc, split /[ \t?,()]+/, $pkgs;
152 return () unless defined $addr;
153 return @{$_parsedaddrs{$addr}} if exists $_parsedaddrs{$addr};
154 @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
155 return @{$_parsedaddrs{$addr}};
158 # Generate a comma-separated list of HTML links to each package given in
159 # $pkgs. $pkgs may be empty, in which case an empty string is returned, or
160 # it may be a comma-separated list of package names.
161 sub htmlpackagelinks {
163 return unless defined $pkgs and $pkgs ne '';
165 my @pkglist = splitpackages($pkgs);
167 my $openstrong = $strong ? '<strong>' : '';
168 my $closestrong = $strong ? '</strong>' : '';
170 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
173 '<a href="' . pkgurl($_) . '">' .
174 $openstrong . htmlsanit($_) . $closestrong . '</a>'
179 # Generate a comma-separated list of HTML links to each maintainer given in
180 # $maints, which should be a comma-separated list of RFC822 addresses.
182 my ($prefixfunc, $maints) = @_;
183 if (defined $maints and $maints ne '') {
184 my @maintaddrs = getparsedaddrs($maints);
185 my $prefix = (ref $prefixfunc) ? $prefixfunc->(scalar @maintaddrs)
188 join ', ', map { sprintf '<a href="%s">%s</a>',
189 mainturl($_->address),
190 htmlsanit($_->format) || '(unknown)'
193 my $prefix = (ref $prefixfunc) ? $prefixfunc->(1) : $prefixfunc;
194 return sprintf '%s<a href="%s">(unknown)</a>', $prefix, mainturl('');
200 my %status = %{getbugstatus($ref)};
201 return htmlindexentrystatus(%status) if (%status);
205 sub htmlindexentrystatus {
211 if ($status{severity} eq 'normal') {
213 } elsif (isstrongseverity($status{severity})) {
214 $showseverity = "<strong>Severity: $status{severity}</strong>;\n";
216 $showseverity = "Severity: <em>$status{severity}</em>;\n";
219 $result .= htmlpackagelinks($status{"package"}, 1);
220 $result .= $showseverity;
221 $result .= "Reported by: <a href=\"" . submitterurl($status{originator})
222 . "\">" . htmlsanit($status{originator}) . "</a>";
223 $result .= ";\nTags: <strong>"
224 . htmlsanit(join(", ", sort(split(/\s+/, $status{tags}))))
226 if (length($status{tags}));
228 my @merged= split(/ /,$status{mergedwith});
229 my $mseparator= ";\nmerged with ";
230 for my $m (@merged) {
231 $result .= $mseparator."<A href=\"" . bugurl($m) . "\">#$m</A>";
235 if (@{$status{found_versions}}) {
236 $result .= ";\nfound in ";
237 $result .= (@{$status{found_versions}} == 1) ? 'version '
239 $result .= join ', ', map htmlsanit($_), @{$status{found_versions}};
242 if (@{$status{fixed_versions}}) {
243 $result .= ";\n<strong>fixed</strong> in ";
244 $result .= (@{$status{fixed_versions}} == 1) ? 'version '
246 $result .= join ', ', map htmlsanit($_), @{$status{fixed_versions}};
247 if (length($status{done})) {
248 $result .= ' by ' . htmlsanit($status{done});
250 } elsif (length($status{done})) {
251 $result .= ";\n<strong>Done:</strong> " . htmlsanit($status{done});
254 unless (length($status{done})) {
255 if (length($status{forwarded})) {
256 $result .= ";\n<strong>Forwarded</strong> to "
257 . maybelink($status{forwarded});
259 my $daysold = int((time - $status{date}) / 86400); # seconds to days
263 $font = "em" if ($daysold > 30);
264 $font = "strong" if ($daysold > 60);
265 $efont = "</$font>" if ($font);
266 $font = "<$font>" if ($font);
268 my $yearsold = int($daysold / 365);
269 $daysold -= $yearsold * 365;
271 $result .= ";\n $font";
273 push @age, "1 year" if ($yearsold == 1);
274 push @age, "$yearsold years" if ($yearsold > 1);
275 push @age, "1 day" if ($daysold == 1);
276 push @age, "$daysold days" if ($daysold > 1);
277 $result .= join(" and ", @age);
278 $result .= " old$efont";
289 $args .= "&archive=yes" if $common_archive;
290 $args .= "&repeatmerged=no" unless $common_repeatmerged;
291 $args .= "&version=$common_version" if defined $common_version;
292 $args .= "&dist=$common_dist" if defined $common_dist;
293 $args .= "&arch=$common_arch" if defined $common_arch;
298 my $ref = shift || "";
299 my $params = "submitter=" . emailfromrfc822($ref);
300 $params .= urlargs();
301 return urlsanit("pkgreport.cgi" . "?" . $params);
305 my $ref = shift || "";
306 my $params = "maint=" . emailfromrfc822($ref);
307 $params .= urlargs();
308 return urlsanit("pkgreport.cgi" . "?" . $params);
313 my $params = "pkg=$ref";
314 $params .= urlargs();
315 return urlsanit("pkgreport.cgi" . "?" . "$params");
320 my $params = "src=$ref";
321 $params .= urlargs();
322 return urlsanit("pkgreport.cgi" . "?" . "$params");
327 my $params = "tag=$ref";
328 $params .= urlargs();
329 return urlsanit("pkgreport.cgi" . "?" . "$params");
336 my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
337 $url =~ s/([<>&"])/\&$saniarray{$1};/g;
342 my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
343 my $in = shift || "";
344 $in =~ s/([<>&"])/\&$saniarray{$1};/g;
350 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
351 return qq{<a href="$in">} . htmlsanit($in) . '</a>';
353 return htmlsanit($in);
359 my $params = "bug=$ref";
360 foreach my $val (@_) {
361 $params .= "\&msg=$1" if ($val =~ /^msg=([0-9]+)/);
362 $params .= "\&archive=yes" if (!$common_archive && $val =~ /^archive.*$/);
364 $params .= "&archive=yes" if ($common_archive);
365 $params .= "&repeatmerged=no" unless ($common_repeatmerged);
367 return urlsanit("bugreport.cgi" . "?" . "$params");
372 my $params = "bug=$ref";
374 foreach my $val (@_) {
375 $params .= "\&$1=$2" if ($val =~ /^(msg|att)=([0-9]+)/);
376 $filename = $1 if ($val =~ /^filename=(.*)$/);
378 $params .= "&archive=yes" if ($common_archive);
380 $pathinfo = "/$filename" if $filename ne '';
382 return urlsanit("bugreport.cgi$pathinfo?$params");
387 return urlsanit("bugreport.cgi" . "?" . "bug=$ref&mbox=yes");
391 return @{getbugs(sub { 1 })};
401 my %displayshowpending = ("pending", "outstanding",
402 "pending-fixed", "pending upload",
403 "fixed", "fixed in NMU",
405 "forwarded", "forwarded to upstream software authors",
406 "absent", "not applicable to this version");
409 return "<HR><H2>No reports found!</H2></HR>\n";
412 if ( $common_bug_reverse ) {
413 @bugs = sort {$b<=>$a} @bugs;
415 @bugs = sort {$a<=>$b} @bugs;
418 foreach my $bug (@bugs) {
419 my %status = %{getbugstatus($bug)};
421 if (%common_include) {
423 foreach my $t (split /\s+/, $status{tags}) {
424 $okay = 1, last if (defined $common_include{$t});
426 if (defined $common_include{subj}) {
427 if (index($status{subject}, $common_include{subj}) > -1) {
433 if (%common_exclude) {
435 foreach my $t (split /\s+/, $status{tags}) {
436 $okay = 0, last if (defined $common_exclude{$t});
438 if (defined $common_exclude{subj}) {
439 if (index($status{subject}, $common_exclude{subj}) > -1) {
445 next if @common_pending_include and
446 not grep { $_ eq $status{pending} } @common_pending_include;
447 next if @common_severity_include and
448 not grep { $_ eq $status{severity} } @common_severity_include;
449 next if grep { $_ eq $status{pending} } @common_pending_exclude;
450 next if grep { $_ eq $status{severity} } @common_severity_exclude;
452 my @merged = sort {$a<=>$b} ($bug, split(/ /, $status{mergedwith}));
453 next unless ($common_repeatmerged || !$seenmerged{$merged[0]});
454 $seenmerged{$merged[0]} = 1;
456 my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
457 bugurl($bug), $bug, htmlsanit($status{subject});
458 $html .= htmlindexentrystatus(\%status) . "\n";
459 $section{$status{pending} . "_" . $status{severity}} .= $html;
460 push @rawsort, $html if $common_raw_sort;
465 if ($common_raw_sort) {
466 $result .= "<UL>\n" . join("", @rawsort ) . "</UL>\n";
468 my @pendingList = qw(pending forwarded pending-fixed fixed done absent);
469 @pendingList = reverse @pendingList if $common_pending_reverse;
470 #print STDERR join(",",@pendingList)."\n";
471 #print STDERR join(",",@common_pending_include).":$#common_pending_include\n";
472 foreach my $pending (@pendingList) {
473 my @severityList = @debbugs::gSeverityList;
474 @severityList = reverse @severityList if $common_severity_reverse;
475 #print STDERR join(",",@severityList)."\n";
477 # foreach my $severity(@debbugs::gSeverityList) {
478 foreach my $severity(@severityList) {
479 $severity = $debbugs::gDefaultSeverity if ($severity eq '');
480 next unless defined $section{${pending} . "_" . ${severity}};
481 $result .= "<HR><H2>$debbugs::gSeverityDisplay{$severity} - $displayshowpending{$pending}</H2>\n";
482 #$result .= "(A list of <a href=\"http://${debbugs::gWebDomain}/db/si/$pending$severity\">all such bugs</a> is available).\n";
483 #$result .= "(A list of all such bugs used to be available).\n";
485 $result .= $section{$pending . "_" . $severity};
486 $result .= "</UL>\n";
487 $anydone = 1 if ($pending eq "done");
492 $result .= $debbugs::gHTMLExpireNote if $gRemoveAge and $anydone;
498 if ($common_archive) {
499 open I, "<$debbugs::gSpoolDir/index.archive"
500 or &quitcgi("$debbugs::gSpoolDir/index.archive: $!");
502 open I, "<$debbugs::gSpoolDir/index.db"
503 or &quitcgi("$debbugs::gSpoolDir/index.db: $!");
509 if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
510 my @x = $bugfunc->(pkg => $1, bug => $2, status => $4,
511 submitter => $5, severity => $6, tags => $7);
513 $count{$_}++ foreach @x;
526 if (!$common_archive && defined $opt &&
527 -e "$debbugs::gSpoolDir/by-$opt.idx")
530 print STDERR "optimized\n" if ($debug);
531 tie %lookup, DB_File => "$debbugs::gSpoolDir/by-$opt.idx", O_RDONLY
532 or die "$0: can't open $debbugs::gSpoolDir/by-$opt.idx ($!)\n";
533 while ($key = shift) {
534 my $bugs = $lookup{$key};
536 push @result, (unpack 'N*', $bugs);
540 print STDERR "done optimized\n" if ($debug);
542 if ( $common_archive ) {
543 open I, "<$debbugs::gSpoolDir/index.archive"
544 or &quitcgi("$debbugs::gSpoolDir/index.archive: $!");
546 open I, "<$debbugs::gSpoolDir/index.db"
547 or &quitcgi("$debbugs::gSpoolDir/index.db: $!");
550 if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
551 if ($bugfunc->(pkg => $1, bug => $2, status => $4,
552 submitter => $5, severity => $6, tags => $7))
560 @result = sort {$a <=> $b} @result;
564 sub emailfromrfc822 {
566 $email =~ s/\s*\(.*\)\s*//;
567 $email = $1 if ($email =~ m/<(.*)>/);
575 while ($input =~ m/\W/) {
576 $encoded.=$`.sprintf("-%02x_",unpack("C",$&));
581 $encoded =~ s/-2e_/\./g;
582 $encoded =~ s/^([^,]+)-20_-3c_(.*)-40_(.*)-3e_/$1,$2,$3,/;
583 $encoded =~ s/^(.*)-40_(.*)-20_-28_([^,]+)-29_$/,$1,$2,$3/;
584 $encoded =~ s/-20_/_/g;
585 $encoded =~ s/-([^_]+)_-/-$1/g;
591 return $_maintainer if $_maintainer;
594 open(MM,"$gMaintainerFile") or &quitcgi("open $gMaintainerFile: $!");
596 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
602 if (defined $gMaintainerFileOverride) {
603 open(MM,"$gMaintainerFileOverride") or &quitcgi("open $gMaintainerFileOverride: $!");
605 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
612 $_maintainer = \%maintainer;
619 return $_pkgsrc if $_pkgsrc;
620 return {} unless defined $gPackageSource;
624 open(MM,"$gPackageSource") or &quitcgi("open $gPackageSource: $!");
626 next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
627 ($a,$b,$c)=($1,$2,$3);
630 $pkgcomponent{$a}= $b;
634 $_pkgcomponent = \%pkgcomponent;
638 sub getpkgcomponent {
639 return $_pkgcomponent if $_pkgcomponent;
641 return $_pkgcomponent;
646 return $_pseudodesc if $_pseudodesc;
649 open(PSEUDO, "< $gPseudoDescFile") or &quitcgi("open $gPseudoDescFile: $!");
651 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
652 $pseudodesc{lc $1} = $2;
655 $_pseudodesc = \%pseudodesc;
664 my $location = getbuglocation( $bugnum, 'summary' );
665 return {} if ( !$location );
666 %status = %{ readbug( $bugnum, $location ) };
668 $status{found_versions} = [];
669 $status{fixed_versions} = [];
670 if (defined $gVersionBugsDir and
671 (defined $common_version or defined $common_dist)) {
672 my $bughash = get_hashname($bugnum);
673 if (open BUGVER, "< $gVersionBugsDir/$bughash/$bugnum.versions") {
676 if (/^Found-in: (.*)/i) {
677 $status{found_versions} = [split ' ', $1];
678 } elsif (/^Fixed-in: (.*)/i) {
679 $status{fixed_versions} = [split ' ', $1];
686 $status{tags} = $status{keywords};
687 my %tags = map { $_ => 1 } split ' ', $status{tags};
689 $status{"package"} =~ s/\s*$//;
690 $status{"package"} = 'unknown' if ($status{"package"} eq '');
691 $status{"severity"} = 'normal' if ($status{"severity"} eq '');
693 $status{"pending"} = 'pending';
694 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
695 $status{"pending"} = 'pending-fixed' if ($tags{pending});
696 $status{"pending"} = 'fixed' if ($tags{fixed});
699 if (defined $common_version) {
700 $version = $common_version;
701 } elsif (defined $common_dist) {
702 $version = getversion($status{package}, $common_dist, $common_arch);
705 if (defined $version) {
706 my $buggy = buggyversion($bugnum, $version, \%status);
707 if ($buggy eq 'absent') {
708 $status{"pending"} = 'absent';
709 } elsif ($buggy eq 'fixed') {
710 $status{"pending"} = 'done';
714 if (length($status{done}) and
715 (not defined $version or not @{$status{fixed_versions}})) {
716 $status{"pending"} = 'done';
725 my %pkgsrc = %{getpkgsrc()};
727 foreach ( keys %pkgsrc ) {
728 push @pkgs, $_ if $pkgsrc{$_} eq $src;
735 my $location = getbuglocation($bugnum, 'log');
736 return undef unless defined $location;
737 return getbugcomponent($bugnum, 'log', $location);
742 my ($bug, $ver, $status) = @_;
743 return '' unless defined $gVersionPackagesDir;
744 my $src = getpkgsrc()->{$status->{package}};
745 $src = $status->{package} unless defined $src;
748 if (exists $_versionobj{$src}) {
749 $tree = $_versionobj{$src};
751 $tree = Debbugs::Versions->new(\&DpkgVer::vercmp);
752 if (open VERFILE, "< $gVersionPackagesDir/$src") {
753 $tree->load(\*VERFILE);
756 $_versionobj{$src} = $tree;
759 return $tree->buggy($ver, $status->{found_versions},
760 $status->{fixed_versions});
765 my ($pkg, $dist, $arch) = @_;
766 return undef unless defined $gVersionIndex;
767 $dist = 'unstable' unless defined $dist;
768 $arch = 'i386' unless defined $arch;
770 unless (tied %_versions) {
771 tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
772 or die "can't open versions index: $!";
775 return $_versions{$pkg}{$dist}{$arch};