4 use Fcntl qw/O_RDONLY/;
5 $config_path = '/etc/debbugs';
6 $lib_path = '/usr/lib/debbugs';
7 require "$lib_path/errorlib";
9 my $common_archive = 0;
10 my $common_repeatmerged = 1;
11 my %common_include = ();
12 my %common_exclude = ();
13 my $common_raw_sort = 0;
14 my $common_bug_reverse = 0;
15 my $common_pending_reverse = 0;
16 my $common_severity_reverse = 0;
18 my @common_pending_include = ();
19 my @common_pending_exclude = ();
20 my @common_severity_include = ();
21 my @common_severity_exclude = ();
27 if ($opt eq "archive") { $common_archive = $val; }
28 if ($opt eq "repeatmerged") { $common_repeatmerged = $val; }
29 if ($opt eq "exclude") {
31 @vals = ( $val ) if (ref($val) eq "" && $val );
32 @vals = ( $$val ) if (ref($val) eq "SCALAR" && $$val );
33 @vals = @{$val} if (ref($val) eq "ARRAY" );
34 %common_exclude = map {
35 if (/^(.*):(.*)$/) { ($1, $2) } else { ($_, 1) }
36 } split /[\s,]+/, join ',', @vals;
38 if ($opt eq "include") {
40 @vals = ( $val, ) if (ref($val) eq "" && $val );
41 @vals = ( $$val, ) if (ref($val) eq "SCALAR" && $$val );
42 @vals = @{$val} if (ref($val) eq "ARRAY" );
43 %common_include = map {
44 if (/^(.*):(.*)$/) { ($1, $2) } else { ($_, 1) }
45 } split /[\s,]+/, join ',', @vals;
47 if ($opt eq "raw") { $common_raw_sort = $val; }
48 if ($opt eq "bug-rev") { $common_bug_reverse = $val; }
49 if ($opt eq "pend-rev") { $common_pending_reverse = $val; }
50 if ($opt eq "sev-rev") { $common_severity_reverse = $val; }
51 if ($opt eq "pend-exc") {
53 @vals = ( $val ) if (ref($val) eq "" && $val );
54 @vals = ( $$val ) if (ref($val) eq "SCALAR" && $$val );
55 @vals = @{$val} if (ref($val) eq "ARRAY" );
56 @common_pending_exclude = @vals if (@vals);
58 if ($opt eq "pend-inc") {
60 @vals = ( $val, ) if (ref($val) eq "" && $val );
61 @vals = ( $$val, ) if (ref($val) eq "SCALAR" && $$val );
62 @vals = @{$val} if (ref($val) eq "ARRAY" );
63 @common_pending_include = @vals if (@vals);
65 if ($opt eq "sev-exc") {
67 @vals = ( $val ) if (ref($val) eq "" && $val );
68 @vals = ( $$val ) if (ref($val) eq "SCALAR" && $$val );
69 @vals = @{$val} if (ref($val) eq "ARRAY" );
70 @common_severity_exclude = @vals if (@vals);
72 if ($opt eq "sev-inc") {
74 @vals = ( $val ) if (ref($val) eq "" && $val );
75 @vals = ( $$val ) if (ref($val) eq "SCALAR" && $$val );
76 @vals = @{$val} if (ref($val) eq "ARRAY" );
77 @common_severity_include = @vals if (@vals);
82 my ($in, $key, $val, %ret);
83 if (defined $ENV{"QUERY_STRING"} && $ENV{"QUERY_STRING"} ne "") {
84 $in=$ENV{QUERY_STRING};
85 } elsif(defined $ENV{"REQUEST_METHOD"}
86 && $ENV{"REQUEST_METHOD"} eq "POST")
88 read(STDIN,$in,$ENV{CONTENT_LENGTH});
92 foreach (split(/[&;]/,$in)) {
94 ($key, $val) = split(/=/,$_,2);
95 $key=~s/%(..)/pack("c",hex($1))/ge;
96 $val=~s/%(..)/pack("c",hex($1))/ge;
97 if ( exists $ret{$key} ) {
98 if ( !exists $ret{"&$key"} ) {
99 $ret{"&$key"} = [ $ret{$key} ];
101 push @{$ret{"&$key"}},$val;
105 $debug = 1 if (defined $ret{"debug"} && $ret{"debug"} eq "aj");
111 print "Content-Type: text/html\n\n";
112 print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
113 print "An error occurred. Dammit.\n";
114 print "Error was: $msg.\n";
115 print "</BODY></HTML>\n";
121 # my $Archive = $common_archive ? "archive" : "";
122 # print header . start_html("Sorry");
123 # print "Sorry bug #$msg doesn't seem to be in the $Archive database.\n";
128 # Split a package string from the status file into a list of package names.
131 return unless defined $pkgs;
132 return split /[ \t?,()]+/, $pkgs;
135 # Generate a comma-separated list of HTML links to each package given in
136 # $pkgs. $pkgs may be empty, in which case an empty string is returned, or
137 # it may be a comma-separated list of package names.
138 sub htmlpackagelinks {
140 return unless defined $pkgs and $pkgs ne '';
142 my @pkglist = splitpackages($pkgs);
144 my $openstrong = $strong ? '<strong>' : '';
145 my $closestrong = $strong ? '</strong>' : '';
147 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
150 '<a href="' . pkgurl($_) . '">' .
151 $openstrong . htmlsanit($_) . $closestrong . '</a>'
158 my %status = %{getbugstatus($ref)};
159 return htmlindexentrystatus(%status) if (%status);
163 sub htmlindexentrystatus {
169 if ($status{severity} eq 'normal') {
171 } elsif (grep($status{severity} eq $_, @debbugs::gStrongSeverities)) {
172 $showseverity = "<strong>Severity: $status{severity}</strong>;\n";
174 $showseverity = "Severity: <em>$status{severity}</em>;\n";
177 $result .= htmlpackagelinks($status{"package"}, 1);
178 $result .= $showseverity;
179 $result .= "Reported by: <a href=\"" . submitterurl($status{originator})
180 . "\">" . htmlsanit($status{originator}) . "</a>";
181 $result .= ";\nTags: <strong>"
182 . htmlsanit(join(", ", sort(split(/\s+/, $status{tags}))))
184 if (length($status{tags}));
186 my @merged= split(/ /,$status{mergedwith});
187 my $mseparator= ";\nmerged with ";
188 for my $m (@merged) {
189 $result .= $mseparator."<A href=\"" . bugurl($m) . "\">#$m</A>";
193 if (length($status{done})) {
194 $result .= ";\n<strong>Done:</strong> " . htmlsanit($status{done});
196 if (length($status{forwarded})) {
197 $result .= ";\n<strong>Forwarded</strong> to "
198 . maybelink($status{forwarded});
200 my $daysold = int((time - $status{date}) / 86400); # seconds to days
204 $font = "em" if ($daysold > 30);
205 $font = "strong" if ($daysold > 60);
206 $efont = "</$font>" if ($font);
207 $font = "<$font>" if ($font);
209 my $yearsold = int($daysold / 365);
210 $daysold -= $yearsold * 365;
212 $result .= ";\n $font";
214 push @age, "1 year" if ($yearsold == 1);
215 push @age, "$yearsold years" if ($yearsold > 1);
216 push @age, "1 day" if ($daysold == 1);
217 push @age, "$daysold days" if ($daysold > 1);
218 $result .= join(" and ", @age);
219 $result .= " old$efont";
229 my $ref = shift || "";
230 my $params = "submitter=" . emailfromrfc822($ref);
231 $params .= "&archive=yes" if ($common_archive);
232 $params .= "&repeatmerged=no" unless ($common_repeatmerged);
233 return urlsanit("pkgreport.cgi" . "?" . $params);
237 my $ref = shift || "";
238 my $params = "maint=" . emailfromrfc822($ref);
239 $params .= "&archive=yes" if ($common_archive);
240 $params .= "&repeatmerged=no" unless ($common_repeatmerged);
241 return urlsanit("pkgreport.cgi" . "?" . $params);
246 my $params = "pkg=$ref";
247 $params .= "&archive=yes" if ($common_archive);
248 $params .= "&repeatmerged=no" unless ($common_repeatmerged);
250 return urlsanit("pkgreport.cgi" . "?" . "$params");
255 my $params = "src=$ref";
256 $params .= "&archive=yes" if ($common_archive);
257 $params .= "&repeatmerged=no" unless ($common_repeatmerged);
258 return urlsanit("pkgreport.cgi" . "?" . "$params");
265 my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
266 $url =~ s/([<>&"])/\&$saniarray{$1};/g;
271 my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
272 my $in = shift || "";
273 $in =~ s/([<>&"])/\&$saniarray{$1};/g;
279 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
280 return qq{<a href="$in">} . htmlsanit($in) . '</a>';
282 return htmlsanit($in);
288 my $params = "bug=$ref";
289 foreach my $val (@_) {
290 $params .= "\&msg=$1" if ($val =~ /^msg=([0-9]+)/);
291 $params .= "\&archive=yes" if (!$common_archive && $val =~ /^archive.*$/);
293 $params .= "&archive=yes" if ($common_archive);
294 $params .= "&repeatmerged=no" unless ($common_repeatmerged);
296 return urlsanit("bugreport.cgi" . "?" . "$params");
301 my $params = "bug=$ref";
303 foreach my $val (@_) {
304 $params .= "\&$1=$2" if ($val =~ /^(msg|att)=([0-9]+)/);
305 $filename = $1 if ($val =~ /^filename=(.*)$/);
307 $params .= "&archive=yes" if ($common_archive);
309 $pathinfo = "/$filename" if $filename ne '';
311 return urlsanit("bugreport.cgi$pathinfo?$params");
316 return urlsanit("bugreport.cgi" . "?" . "bug=$ref&mbox=yes");
320 return @{getbugs(sub { 1 })};
330 my %displayshowpending = ("pending", "outstanding",
331 "pending-fixed", "pending upload",
332 "fixed", "fixed in NMU",
334 "forwarded", "forwarded to upstream software authors");
337 return "<HR><H2>No reports found!</H2></HR>\n";
340 if ( $common_bug_reverse ) {
341 @bugs = sort {$b<=>$a} @bugs;
343 @bugs = sort {$a<=>$b} @bugs;
346 foreach my $bug (@bugs) {
347 my %status = %{getbugstatus($bug)};
349 if (%common_include) {
351 foreach my $t (split /\s+/, $status{tags}) {
352 $okay = 1, last if (defined $common_include{$t});
354 if (defined $common_include{subj}) {
355 if (index($status{subject}, $common_include{subj}) > -1) {
361 if (%common_exclude) {
363 foreach my $t (split /\s+/, $status{tags}) {
364 $okay = 0, last if (defined $common_exclude{$t});
366 if (defined $common_exclude{subj}) {
367 if (index($status{subject}, $common_exclude{subj}) > -1) {
373 next if @common_pending_include and
374 not grep { $_ eq $status{pending} } @common_pending_include;
375 next if @common_severity_include and
376 not grep { $_ eq $status{severity} } @common_severity_include;
377 next if grep { $_ eq $status{pending} } @common_pending_exclude;
378 next if grep { $_ eq $status{severity} } @common_severity_exclude;
380 my @merged = sort {$a<=>$b} ($bug, split(/ /, $status{mergedwith}));
381 next unless ($common_repeatmerged || !$seenmerged{$merged[0]});
382 $seenmerged{$merged[0]} = 1;
384 my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
385 bugurl($bug), $bug, htmlsanit($status{subject});
386 $html .= htmlindexentrystatus(\%status) . "\n";
387 $section{$status{pending} . "_" . $status{severity}} .= $html;
388 push @rawsort, $html if $common_raw_sort;
393 if ($common_raw_sort) {
394 $result .= "<UL>\n" . join("", @rawsort ) . "</UL>\n";
396 my @pendingList = qw(pending forwarded pending-fixed fixed done);
397 @pendingList = reverse @pendingList if $common_pending_reverse;
398 #print STDERR join(",",@pendingList)."\n";
399 #print STDERR join(",",@common_pending_include).":$#common_pending_include\n";
400 foreach my $pending (@pendingList) {
401 my @severityList = @debbugs::gSeverityList;
402 @severityList = reverse @severityList if $common_severity_reverse;
403 #print STDERR join(",",@severityList)."\n";
405 # foreach my $severity(@debbugs::gSeverityList) {
406 foreach my $severity(@severityList) {
407 $severity = $debbugs::gDefaultSeverity if ($severity eq '');
408 next unless defined $section{${pending} . "_" . ${severity}};
409 $result .= "<HR><H2>$debbugs::gSeverityDisplay{$severity} - $displayshowpending{$pending}</H2>\n";
410 #$result .= "(A list of <a href=\"http://${debbugs::gWebDomain}/db/si/$pending$severity\">all such bugs</a> is available).\n";
411 #$result .= "(A list of all such bugs used to be available).\n";
413 $result .= $section{$pending . "_" . $severity};
414 $result .= "</UL>\n";
415 $anydone = 1 if ($pending eq "done");
420 $result .= $debbugs::gHTMLExpireNote if ($anydone);
426 if ($common_archive) {
427 open I, "<$debbugs::gSpoolDir/index.archive" or &quitcgi("bugindex: $!");
429 open I, "<$debbugs::gSpoolDir/index.db" or &quitcgi("bugindex: $!");
435 if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
436 my @x = $bugfunc->(pkg => $1, bug => $2, status => $4,
437 submitter => $5, severity => $6, tags => $7);
439 $count{$_}++ foreach @x;
452 if (!$common_archive && defined $opt &&
453 -e "$debbugs::gSpoolDir/by-$opt.idx")
456 print STDERR "optimized\n" if ($debug);
457 tie %lookup, DB_File => "$debbugs::gSpoolDir/by-$opt.idx", O_RDONLY
458 or die "$0: can't open $debbugs::gSpoolDir/by-$opt.idx ($!)\n";
459 while ($key = shift) {
460 my $bugs = $lookup{$key};
462 push @result, (unpack 'N*', $bugs);
466 print STDERR "done optimized\n" if ($debug);
468 if ( $common_archive ) {
469 open I, "<$debbugs::gSpoolDir/index.archive"
470 or &quitcgi("bugindex: $!");
472 open I, "<$debbugs::gSpoolDir/index.db"
473 or &quitcgi("bugindex: $!");
476 if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
477 if ($bugfunc->(pkg => $1, bug => $2, status => $4,
478 submitter => $5, severity => $6, tags => $7))
486 @result = sort {$a <=> $b} @result;
490 sub emailfromrfc822 {
492 $email =~ s/\s*\(.*\)\s*//;
493 $email = $1 if ($email =~ m/<(.*)>/);
501 while ($input =~ m/\W/) {
502 $encoded.=$`.sprintf("-%02x_",unpack("C",$&));
507 $encoded =~ s/-2e_/\./g;
508 $encoded =~ s/^([^,]+)-20_-3c_(.*)-40_(.*)-3e_/$1,$2,$3,/;
509 $encoded =~ s/^(.*)-40_(.*)-20_-28_([^,]+)-29_$/,$1,$2,$3/;
510 $encoded =~ s/-20_/_/g;
511 $encoded =~ s/-([^_]+)_-/-$1/g;
517 return $_maintainer if $_maintainer;
520 open(MM,"$gMaintainerFile") or &quitcgi("open $gMaintainerFile: $!");
522 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
528 open(MM,"$gMaintainerFileOverride") or &quitcgi("open $gMaintainerFileOverride: $!");
530 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
536 $_maintainer = \%maintainer;
543 return $_pkgsrc if $_pkgsrc;
547 open(MM,"$gPackageSource") or &quitcgi("open $gPackageSource: $!");
549 next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
550 ($a,$b,$c)=($1,$2,$3);
553 $pkgcomponent{$a}= $b;
557 $_pkgcomponent = \%pkgcomponent;
561 sub getpkgcomponent {
562 return $_pkgcomponent if $_pkgcomponent;
564 return $_pkgcomponent;
569 return $_pseudodesc if $_pseudodesc;
572 open(PSEUDO, "< $gPseudoDescFile") or &quitcgi("open $gPseudoDescFile: $!");
574 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
575 $pseudodesc{lc $1} = $2;
578 $_pseudodesc = \%pseudodesc;
587 my $location = getbuglocation( $bugnum, "status" );
588 return {} if ( !$location );
589 %status = %{ readbug( $bugnum, $location ) };
591 $status{tags} = $status{keywords};
593 $status{"package"} =~ s/\s*$//;
594 $status{"package"} = 'unknown' if ($status{"package"} eq '');
595 $status{"severity"} = 'normal' if ($status{"severity"} eq '');
597 $status{"pending"} = 'pending';
598 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
599 $status{"pending"} = 'pending-fixed' if ($status{"tags"} =~ /\bpending\b/);
600 $status{"pending"} = 'fixed' if ($status{"tags"} =~ /\bfixed\b/);
601 $status{"pending"} = 'done' if (length($status{"done"}));
609 my %pkgsrc = %{getpkgsrc()};
611 foreach ( keys %pkgsrc ) {
612 push @pkgs, $_ if $pkgsrc{$_} eq $src;
620 my $dir = getlocationpath( getbuglocation( $bugnum, "log" ) );
621 my $hash = get_hashname( $bugnum );
622 return "" if ( !$dir );
623 return "$dir/$hash/$bugnum.log";