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 .= ";\nOwned by: " . htmlsanit($status{owner})
224 if length $status{owner};
225 $result .= ";\nTags: <strong>"
226 . htmlsanit(join(", ", sort(split(/\s+/, $status{tags}))))
228 if (length($status{tags}));
230 my @merged= split(/ /,$status{mergedwith});
231 my $mseparator= ";\nmerged with ";
232 for my $m (@merged) {
233 $result .= $mseparator."<A href=\"" . bugurl($m) . "\">#$m</A>";
237 if (@{$status{found_versions}}) {
238 $result .= ";\nfound in ";
239 $result .= (@{$status{found_versions}} == 1) ? 'version '
241 $result .= join ', ', map htmlsanit($_), @{$status{found_versions}};
244 if (@{$status{fixed_versions}}) {
245 $result .= ";\n<strong>fixed</strong> in ";
246 $result .= (@{$status{fixed_versions}} == 1) ? 'version '
248 $result .= join ', ', map htmlsanit($_), @{$status{fixed_versions}};
249 if (length($status{done})) {
250 $result .= ' by ' . htmlsanit($status{done});
252 } elsif (length($status{done})) {
253 $result .= ";\n<strong>Done:</strong> " . htmlsanit($status{done});
256 unless (length($status{done})) {
257 if (length($status{forwarded})) {
258 $result .= ";\n<strong>Forwarded</strong> to "
259 . maybelink($status{forwarded});
261 my $daysold = int((time - $status{date}) / 86400); # seconds to days
265 $font = "em" if ($daysold > 30);
266 $font = "strong" if ($daysold > 60);
267 $efont = "</$font>" if ($font);
268 $font = "<$font>" if ($font);
270 my $yearsold = int($daysold / 365);
271 $daysold -= $yearsold * 365;
273 $result .= ";\n $font";
275 push @age, "1 year" if ($yearsold == 1);
276 push @age, "$yearsold years" if ($yearsold > 1);
277 push @age, "1 day" if ($daysold == 1);
278 push @age, "$daysold days" if ($daysold > 1);
279 $result .= join(" and ", @age);
280 $result .= " old$efont";
291 $args .= "&archive=yes" if $common_archive;
292 $args .= "&repeatmerged=no" unless $common_repeatmerged;
293 $args .= "&version=$common_version" if defined $common_version;
294 $args .= "&dist=$common_dist" if defined $common_dist;
295 $args .= "&arch=$common_arch" if defined $common_arch;
300 my $ref = shift || "";
301 my $params = "submitter=" . emailfromrfc822($ref);
302 $params .= urlargs();
303 return urlsanit("pkgreport.cgi" . "?" . $params);
307 my $ref = shift || "";
308 my $params = "maint=" . emailfromrfc822($ref);
309 $params .= urlargs();
310 return urlsanit("pkgreport.cgi" . "?" . $params);
315 my $params = "pkg=$ref";
316 $params .= urlargs();
317 return urlsanit("pkgreport.cgi" . "?" . "$params");
322 my $params = "src=$ref";
323 $params .= urlargs();
324 return urlsanit("pkgreport.cgi" . "?" . "$params");
329 my $params = "tag=$ref";
330 $params .= urlargs();
331 return urlsanit("pkgreport.cgi" . "?" . "$params");
338 my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
339 $url =~ s/([<>&"])/\&$saniarray{$1};/g;
344 my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
345 my $in = shift || "";
346 $in =~ s/([<>&"])/\&$saniarray{$1};/g;
352 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
353 return qq{<a href="$in">} . htmlsanit($in) . '</a>';
355 return htmlsanit($in);
361 my $params = "bug=$ref";
362 foreach my $val (@_) {
363 $params .= "\&msg=$1" if ($val =~ /^msg=([0-9]+)/);
364 $params .= "\&archive=yes" if (!$common_archive && $val =~ /^archive.*$/);
366 $params .= "&archive=yes" if ($common_archive);
367 $params .= "&repeatmerged=no" unless ($common_repeatmerged);
369 return urlsanit("bugreport.cgi" . "?" . "$params");
374 my $params = "bug=$ref";
376 foreach my $val (@_) {
377 $params .= "\&$1=$2" if ($val =~ /^(msg|att)=([0-9]+)/);
378 $filename = $1 if ($val =~ /^filename=(.*)$/);
380 $params .= "&archive=yes" if ($common_archive);
382 $pathinfo = "/$filename" if $filename ne '';
384 return urlsanit("bugreport.cgi$pathinfo?$params");
389 return urlsanit("bugreport.cgi" . "?" . "bug=$ref&mbox=yes");
393 return @{getbugs(sub { 1 })};
403 my %displayshowpending = ("pending", "outstanding",
404 "pending-fixed", "pending upload",
405 "fixed", "fixed in NMU",
407 "forwarded", "forwarded to upstream software authors",
408 "absent", "not applicable to this version");
411 return "<HR><H2>No reports found!</H2></HR>\n";
414 if ( $common_bug_reverse ) {
415 @bugs = sort {$b<=>$a} @bugs;
417 @bugs = sort {$a<=>$b} @bugs;
420 foreach my $bug (@bugs) {
421 my %status = %{getbugstatus($bug)};
423 if (%common_include) {
425 foreach my $t (split /\s+/, $status{tags}) {
426 $okay = 1, last if (defined $common_include{$t});
428 if (defined $common_include{subj}) {
429 if (index($status{subject}, $common_include{subj}) > -1) {
435 if (%common_exclude) {
437 foreach my $t (split /\s+/, $status{tags}) {
438 $okay = 0, last if (defined $common_exclude{$t});
440 if (defined $common_exclude{subj}) {
441 if (index($status{subject}, $common_exclude{subj}) > -1) {
447 next if @common_pending_include and
448 not grep { $_ eq $status{pending} } @common_pending_include;
449 next if @common_severity_include and
450 not grep { $_ eq $status{severity} } @common_severity_include;
451 next if grep { $_ eq $status{pending} } @common_pending_exclude;
452 next if grep { $_ eq $status{severity} } @common_severity_exclude;
454 my @merged = sort {$a<=>$b} ($bug, split(/ /, $status{mergedwith}));
455 next unless ($common_repeatmerged || !$seenmerged{$merged[0]});
456 $seenmerged{$merged[0]} = 1;
458 my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
459 bugurl($bug), $bug, htmlsanit($status{subject});
460 $html .= htmlindexentrystatus(\%status) . "\n";
461 $section{$status{pending} . "_" . $status{severity}} .= $html;
462 push @rawsort, $html if $common_raw_sort;
467 if ($common_raw_sort) {
468 $result .= "<UL>\n" . join("", @rawsort ) . "</UL>\n";
470 my @pendingList = qw(pending forwarded pending-fixed fixed done absent);
471 @pendingList = reverse @pendingList if $common_pending_reverse;
472 #print STDERR join(",",@pendingList)."\n";
473 #print STDERR join(",",@common_pending_include).":$#common_pending_include\n";
474 foreach my $pending (@pendingList) {
475 my @severityList = @debbugs::gSeverityList;
476 @severityList = reverse @severityList if $common_severity_reverse;
477 #print STDERR join(",",@severityList)."\n";
479 # foreach my $severity(@debbugs::gSeverityList) {
480 foreach my $severity(@severityList) {
481 $severity = $debbugs::gDefaultSeverity if ($severity eq '');
482 next unless defined $section{${pending} . "_" . ${severity}};
483 $result .= "<HR><H2>$debbugs::gSeverityDisplay{$severity} - $displayshowpending{$pending}</H2>\n";
484 #$result .= "(A list of <a href=\"http://${debbugs::gWebDomain}/db/si/$pending$severity\">all such bugs</a> is available).\n";
485 #$result .= "(A list of all such bugs used to be available).\n";
487 $result .= $section{$pending . "_" . $severity};
488 $result .= "</UL>\n";
489 $anydone = 1 if ($pending eq "done");
494 $result .= $debbugs::gHTMLExpireNote if $gRemoveAge and $anydone;
500 if ($common_archive) {
501 open I, "<$debbugs::gSpoolDir/index.archive"
502 or &quitcgi("$debbugs::gSpoolDir/index.archive: $!");
504 open I, "<$debbugs::gSpoolDir/index.db"
505 or &quitcgi("$debbugs::gSpoolDir/index.db: $!");
511 if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
512 my @x = $bugfunc->(pkg => $1, bug => $2, status => $4,
513 submitter => $5, severity => $6, tags => $7);
515 $count{$_}++ foreach @x;
528 if (!$common_archive && defined $opt &&
529 -e "$debbugs::gSpoolDir/by-$opt.idx")
532 print STDERR "optimized\n" if ($debug);
533 tie %lookup, DB_File => "$debbugs::gSpoolDir/by-$opt.idx", O_RDONLY
534 or die "$0: can't open $debbugs::gSpoolDir/by-$opt.idx ($!)\n";
535 while ($key = shift) {
536 my $bugs = $lookup{$key};
538 push @result, (unpack 'N*', $bugs);
542 print STDERR "done optimized\n" if ($debug);
544 if ( $common_archive ) {
545 open I, "<$debbugs::gSpoolDir/index.archive"
546 or &quitcgi("$debbugs::gSpoolDir/index.archive: $!");
548 open I, "<$debbugs::gSpoolDir/index.db"
549 or &quitcgi("$debbugs::gSpoolDir/index.db: $!");
552 if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
553 if ($bugfunc->(pkg => $1, bug => $2, status => $4,
554 submitter => $5, severity => $6, tags => $7))
562 @result = sort {$a <=> $b} @result;
566 sub emailfromrfc822 {
568 $email =~ s/\s*\(.*\)\s*//;
569 $email = $1 if ($email =~ m/<(.*)>/);
577 while ($input =~ m/\W/) {
578 $encoded.=$`.sprintf("-%02x_",unpack("C",$&));
583 $encoded =~ s/-2e_/\./g;
584 $encoded =~ s/^([^,]+)-20_-3c_(.*)-40_(.*)-3e_/$1,$2,$3,/;
585 $encoded =~ s/^(.*)-40_(.*)-20_-28_([^,]+)-29_$/,$1,$2,$3/;
586 $encoded =~ s/-20_/_/g;
587 $encoded =~ s/-([^_]+)_-/-$1/g;
593 return $_maintainer if $_maintainer;
596 open(MM,"$gMaintainerFile") or &quitcgi("open $gMaintainerFile: $!");
598 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
604 if (defined $gMaintainerFileOverride) {
605 open(MM,"$gMaintainerFileOverride") or &quitcgi("open $gMaintainerFileOverride: $!");
607 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
614 $_maintainer = \%maintainer;
621 return $_pkgsrc if $_pkgsrc;
622 return {} unless defined $gPackageSource;
626 open(MM,"$gPackageSource") or &quitcgi("open $gPackageSource: $!");
628 next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
629 ($a,$b,$c)=($1,$2,$3);
632 $pkgcomponent{$a}= $b;
636 $_pkgcomponent = \%pkgcomponent;
640 sub getpkgcomponent {
641 return $_pkgcomponent if $_pkgcomponent;
643 return $_pkgcomponent;
648 return $_pseudodesc if $_pseudodesc;
651 open(PSEUDO, "< $gPseudoDescFile") or &quitcgi("open $gPseudoDescFile: $!");
653 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
654 $pseudodesc{lc $1} = $2;
657 $_pseudodesc = \%pseudodesc;
666 my $location = getbuglocation( $bugnum, 'summary' );
667 return {} if ( !$location );
668 %status = %{ readbug( $bugnum, $location ) };
670 $status{found_versions} = [];
671 $status{fixed_versions} = [];
672 if (defined $gVersionBugsDir and
673 (defined $common_version or defined $common_dist)) {
674 my $bughash = get_hashname($bugnum);
675 if (open BUGVER, "< $gVersionBugsDir/$bughash/$bugnum.versions") {
678 if (/^Found-in: (.*)/i) {
679 $status{found_versions} = [split ' ', $1];
680 } elsif (/^Fixed-in: (.*)/i) {
681 $status{fixed_versions} = [split ' ', $1];
688 $status{tags} = $status{keywords};
689 my %tags = map { $_ => 1 } split ' ', $status{tags};
691 $status{"package"} =~ s/\s*$//;
692 $status{"package"} = 'unknown' if ($status{"package"} eq '');
693 $status{"severity"} = 'normal' if ($status{"severity"} eq '');
695 $status{"pending"} = 'pending';
696 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
697 $status{"pending"} = 'pending-fixed' if ($tags{pending});
698 $status{"pending"} = 'fixed' if ($tags{fixed});
701 if (defined $common_version) {
702 $version = $common_version;
703 } elsif (defined $common_dist) {
704 $version = getversion($status{package}, $common_dist, $common_arch);
707 if (defined $version) {
708 my $buggy = buggyversion($bugnum, $version, \%status);
709 if ($buggy eq 'absent') {
710 $status{"pending"} = 'absent';
711 } elsif ($buggy eq 'fixed') {
712 $status{"pending"} = 'done';
716 if (length($status{done}) and
717 (not defined $version or not @{$status{fixed_versions}})) {
718 $status{"pending"} = 'done';
727 my %pkgsrc = %{getpkgsrc()};
729 foreach ( keys %pkgsrc ) {
730 push @pkgs, $_ if $pkgsrc{$_} eq $src;
737 my $location = getbuglocation($bugnum, 'log');
738 return undef unless defined $location;
739 return getbugcomponent($bugnum, 'log', $location);
744 my ($bug, $ver, $status) = @_;
745 return '' unless defined $gVersionPackagesDir;
746 my $src = getpkgsrc()->{$status->{package}};
747 $src = $status->{package} unless defined $src;
750 if (exists $_versionobj{$src}) {
751 $tree = $_versionobj{$src};
753 $tree = Debbugs::Versions->new(\&DpkgVer::vercmp);
754 if (open VERFILE, "< $gVersionPackagesDir/$src") {
755 $tree->load(\*VERFILE);
758 $_versionobj{$src} = $tree;
761 return $tree->buggy($ver, $status->{found_versions},
762 $status->{fixed_versions});
767 my ($pkg, $dist, $arch) = @_;
768 return undef unless defined $gVersionIndex;
769 $dist = 'unstable' unless defined $dist;
770 $arch = 'i386' unless defined $arch;
772 unless (tied %_versions) {
773 tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
774 or die "can't open versions index: $!";
777 return $_versions{$pkg}{$dist}{$arch};