4 use Fcntl qw/O_RDONLY/;
6 my $common_archive = 0;
7 my $common_repeatmerged = 1;
8 my %common_include = ();
9 my %common_exclude = ();
10 my $common_raw_sort = 0;
11 my $common_bug_reverse = 0;
12 my $common_pending_reverse = 0;
13 my $common_severity_reverse = 0;
15 my @common_pending_include = ();
16 my @common_pending_exclude = ();
17 my @common_severity_include = ();
18 my @common_severity_exclude = ();
24 if ($opt eq "archive") { $common_archive = $val; }
25 if ($opt eq "repeatmerged") { $common_repeatmerged = $val; }
26 if ($opt eq "exclude") {
28 @vals = ( $val ) if (ref($val) eq "" && $val );
29 @vals = ( $$val ) if (ref($val) eq "SCALAR" && $$val );
30 @vals = @{$val} if (ref($val) eq "ARRAY" );
31 %common_exclude = map {
32 if (/^(.*):(.*)$/) { ($1, $2) } else { ($_, 1) }
33 } split /[\s,]+/, join ',', @vals;
35 if ($opt eq "include") {
37 @vals = ( $val, ) if (ref($val) eq "" && $val );
38 @vals = ( $$val, ) if (ref($val) eq "SCALAR" && $$val );
39 @vals = @{$val} if (ref($val) eq "ARRAY" );
40 %common_include = map {
41 if (/^(.*):(.*)$/) { ($1, $2) } else { ($_, 1) }
42 } split /[\s,]+/, join ',', @vals;
44 if ($opt eq "raw") { $common_raw_sort = $val; }
45 if ($opt eq "bug-rev") { $common_bug_reverse = $val; }
46 if ($opt eq "pend-rev") { $common_pending_reverse = $val; }
47 if ($opt eq "sev-rev") { $common_severity_reverse = $val; }
48 if ($opt eq "pend-exc") {
50 @vals = ( $val ) if (ref($val) eq "" && $val );
51 @vals = ( $$val ) if (ref($val) eq "SCALAR" && $$val );
52 @vals = @{$val} if (ref($val) eq "ARRAY" );
53 @common_pending_exclude = @vals if (@vals);
55 if ($opt eq "pend-inc") {
57 @vals = ( $val, ) if (ref($val) eq "" && $val );
58 @vals = ( $$val, ) if (ref($val) eq "SCALAR" && $$val );
59 @vals = @{$val} if (ref($val) eq "ARRAY" );
60 @common_pending_include = @vals if (@vals);
62 if ($opt eq "sev-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_severity_exclude = @vals if (@vals);
69 if ($opt eq "sev-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_severity_include = @vals if (@vals);
79 my ($in, $key, $val, %ret);
80 if (defined $ENV{"QUERY_STRING"} && $ENV{"QUERY_STRING"} ne "") {
81 $in=$ENV{QUERY_STRING};
82 } elsif(defined $ENV{"REQUEST_METHOD"}
83 && $ENV{"REQUEST_METHOD"} eq "POST")
85 read(STDIN,$in,$ENV{CONTENT_LENGTH});
89 foreach (split(/[&;]/,$in)) {
91 ($key, $val) = split(/=/,$_,2);
92 $key=~s/%(..)/pack("c",hex($1))/ge;
93 $val=~s/%(..)/pack("c",hex($1))/ge;
94 if ( exists $ret{$key} ) {
95 if ( !exists $ret{"&$key"} ) {
96 $ret{"&$key"} = [ $ret{$key} ];
98 push @{$ret{"&$key"}},$val;
102 $debug = 1 if (defined $ret{"debug"} && $ret{"debug"} eq "aj");
108 print "Content-Type: text/html\n\n";
109 print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
110 print "An error occurred. Dammit.\n";
111 print "Error was: $msg.\n";
112 print "</BODY></HTML>\n";
118 # my $Archive = $common_archive ? "archive" : "";
119 # print header . start_html("Sorry");
120 # print "Sorry bug #$msg doesn't seem to be in the $Archive database.\n";
125 # Split a package string from the status file into a list of package names.
128 return unless defined $pkgs;
129 return split /[ \t?,()]+/, $pkgs;
132 # Generate a comma-separated list of HTML links to each package given in
133 # $pkgs. $pkgs may be empty, in which case an empty string is returned, or
134 # it may be a comma-separated list of package names.
135 sub htmlpackagelinks {
137 return unless defined $pkgs and $pkgs ne '';
139 my @pkglist = splitpackages($pkgs);
141 my $openstrong = $strong ? '<strong>' : '';
142 my $closestrong = $strong ? '</strong>' : '';
144 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
147 '<a href="' . pkgurl($_) . '">' .
148 $openstrong . htmlsanit($_) . $closestrong . '</a>'
155 my %status = %{getbugstatus($ref)};
156 return htmlindexentrystatus(%status) if (%status);
160 sub htmlindexentrystatus {
166 if ($status{severity} eq 'normal') {
168 } elsif (grep($status{severity} eq $_, @debbugs::gStrongSeverities)) {
169 $showseverity = "<strong>Severity: $status{severity}</strong>;\n";
171 $showseverity = "Severity: <em>$status{severity}</em>;\n";
174 $result .= htmlpackagelinks($status{"package"}, 1);
175 $result .= $showseverity;
176 $result .= "Reported by: <a href=\"" . submitterurl($status{originator})
177 . "\">" . htmlsanit($status{originator}) . "</a>";
178 $result .= ";\nTags: <strong>"
179 . htmlsanit(join(", ", sort(split(/\s+/, $status{tags}))))
181 if (length($status{tags}));
183 my @merged= split(/ /,$status{mergedwith});
184 my $mseparator= ";\nmerged with ";
185 for my $m (@merged) {
186 $result .= $mseparator."<A href=\"" . bugurl($m) . "\">#$m</A>";
190 if (length($status{done})) {
191 $result .= ";\n<strong>Done:</strong> " . htmlsanit($status{done});
193 if (length($status{forwarded})) {
194 $result .= ";\n<strong>Forwarded</strong> to "
195 . maybelink($status{forwarded});
197 my $daysold = int((time - $status{date}) / 86400); # seconds to days
201 $font = "em" if ($daysold > 30);
202 $font = "strong" if ($daysold > 60);
203 $efont = "</$font>" if ($font);
204 $font = "<$font>" if ($font);
206 my $yearsold = int($daysold / 364);
207 $daysold = $daysold - $yearsold * 364;
209 $result .= ";\n $font";
211 push @age, "1 year" if ($yearsold == 1);
212 push @age, "$yearsold years" if ($yearsold > 1);
213 push @age, "1 day" if ($daysold == 1);
214 push @age, "$daysold days" if ($daysold > 1);
215 $result .= join(" and ", @age);
216 $result .= " old$efont";
226 my $ref = shift || "";
227 my $params = "submitter=" . emailfromrfc822($ref);
228 $params .= "&archive=yes" if ($common_archive);
229 $params .= "&repeatmerged=no" unless ($common_repeatmerged);
230 return urlsanit("pkgreport.cgi" . "?" . $params);
234 my $ref = shift || "";
235 my $params = "maint=" . emailfromrfc822($ref);
236 $params .= "&archive=yes" if ($common_archive);
237 $params .= "&repeatmerged=no" unless ($common_repeatmerged);
238 return urlsanit("pkgreport.cgi" . "?" . $params);
243 my $params = "pkg=$ref";
244 $params .= "&archive=yes" if ($common_archive);
245 $params .= "&repeatmerged=no" unless ($common_repeatmerged);
247 return urlsanit("pkgreport.cgi" . "?" . "$params");
252 my $params = "src=$ref";
253 $params .= "&archive=yes" if ($common_archive);
254 $params .= "&repeatmerged=no" unless ($common_repeatmerged);
255 return urlsanit("pkgreport.cgi" . "?" . "$params");
262 my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
263 $url =~ s/([<>&"])/\&$saniarray{$1};/g;
268 my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
269 my $in = shift || "";
270 $in =~ s/([<>&"])/\&$saniarray{$1};/g;
276 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
277 return qq{<a href="$in">} . htmlsanit($in) . '</a>';
279 return htmlsanit($in);
285 my $params = "bug=$ref";
286 foreach my $val (@_) {
287 $params .= "\&msg=$1" if ($val =~ /^msg=([0-9]+)/);
288 $params .= "\&archive=yes" if (!$common_archive && $val =~ /^archive.*$/);
290 $params .= "&archive=yes" if ($common_archive);
291 $params .= "&repeatmerged=no" unless ($common_repeatmerged);
293 return urlsanit("bugreport.cgi" . "?" . "$params");
298 my $params = "bug=$ref";
300 foreach my $val (@_) {
301 $params .= "\&$1=$2" if ($val =~ /^(msg|att)=([0-9]+)/);
302 $filename = $1 if ($val =~ /^filename=(.*)$/);
304 $params .= "&archive=yes" if ($common_archive);
306 return urlsanit("bugreport.cgi/$filename?$params");
311 return urlsanit("bugreport.cgi" . "?" . "bug=$ref&mbox=yes");
317 opendir(D, "$debbugs::gSpoolDir/db") or &quitcgi("opendir db: $!");
318 @bugs = sort {$a<=>$b} grep s/\.status$//,
319 (grep m/^[0-9]+\.status$/,
333 my %displayshowpending = ("pending", "outstanding",
334 "pending-fixed", "pending upload",
335 "fixed", "fixed in NMU",
337 "forwarded", "forwarded to upstream software authors");
340 return "<HR><H2>No reports found!</H2></HR>\n";
343 if ( $common_bug_reverse ) {
344 @bugs = sort {$b<=>$a} @bugs;
346 @bugs = sort {$a<=>$b} @bugs;
348 foreach my $bug (@bugs) {
349 my %status = %{getbugstatus($bug)};
351 my @merged = sort {$a<=>$b} ($bug, split(/ /, $status{mergedwith}));
352 next unless ($common_repeatmerged || $bug == $merged[0]);
353 if (%common_include) {
355 foreach my $t (split /\s+/, $status{tags}) {
356 $okay = 1, last if (defined $common_include{$t});
358 if (defined $common_include{subj}) {
359 if (index($status{subject}, $common_include{subj}) > -1) {
365 if (%common_exclude) {
367 foreach my $t (split /\s+/, $status{tags}) {
368 $okay = 0, last if (defined $common_exclude{$t});
370 if (defined $common_exclude{subj}) {
371 if (index($status{subject}, $common_exclude{subj}) > -1) {
377 next if @common_pending_include and
378 not grep { $_ eq $status{pending} } @common_pending_include;
379 next if @common_severity_include and
380 not grep { $_ eq $status{severity} } @common_severity_include;
381 next if grep { $_ eq $status{pending} } @common_pending_exclude;
382 next if grep { $_ eq $status{severity} } @common_severity_exclude;
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);
451 if (!$common_archive && defined $opt &&
452 -e "$debbugs::gSpoolDir/by-$opt.idx")
455 print STDERR "optimized\n" if ($debug);
456 tie %lookup, DB_File => "$debbugs::gSpoolDir/by-$opt.idx", O_RDONLY
457 or die "$0: can't open $debbugs::gSpoolDir/by-$opt.idx ($!)\n";
458 while ($key = shift) {
459 my $bugs = $lookup{$key};
461 push @result, (unpack 'N*', $bugs);
465 print STDERR "done optimized\n" if ($debug);
467 if ( $common_archive ) {
468 open I, "<$debbugs::gSpoolDir/index.archive"
469 or &quitcgi("bugindex: $!");
471 open I, "<$debbugs::gSpoolDir/index.db"
472 or &quitcgi("bugindex: $!");
475 if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
476 if ($bugfunc->(pkg => $1, bug => $2, status => $4,
477 submitter => $5, severity => $6, tags => $7))
485 @result = sort {$a <=> $b} @result;
489 sub emailfromrfc822 {
491 $email =~ s/\s*\(.*\)\s*//;
492 $email = $1 if ($email =~ m/<(.*)>/);
500 while ($input =~ m/\W/) {
501 $encoded.=$`.sprintf("-%02x_",unpack("C",$&));
506 $encoded =~ s/-2e_/\./g;
507 $encoded =~ s/^([^,]+)-20_-3c_(.*)-40_(.*)-3e_/$1,$2,$3,/;
508 $encoded =~ s/^(.*)-40_(.*)-20_-28_([^,]+)-29_$/,$1,$2,$3/;
509 $encoded =~ s/-20_/_/g;
510 $encoded =~ s/-([^_]+)_-/-$1/g;
516 return $_maintainer if $_maintainer;
519 open(MM,"$gMaintainerFile") or &quitcgi("open $gMaintainerFile: $!");
521 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
527 open(MM,"$gMaintainerFileOverride") or &quitcgi("open $gMaintainerFileOverride: $!");
529 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
535 $_maintainer = \%maintainer;
542 return $_pkgsrc if $_pkgsrc;
546 open(MM,"$gPackageSource") or &quitcgi("open $gPackageSource: $!");
548 next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
549 ($a,$b,$c)=($1,$2,$3);
552 $pkgcomponent{$a}= $b;
556 $_pkgcomponent = \%pkgcomponent;
560 sub getpkgcomponent {
561 return $_pkgcomponent if $_pkgcomponent;
563 return $_pkgcomponent;
568 return $_pseudodesc if $_pseudodesc;
571 open(PSEUDO, "< $gPseudoDescFile") or &quitcgi("open $gPseudoDescFile: $!");
573 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
574 $pseudodesc{lc $1} = $2;
577 $_pseudodesc = \%pseudodesc;
586 my $location = getbuglocation( $bugnum, "status" );
587 return {} if ( !$location );
588 %status = %{ readbug( $bugnum, $location ) };
590 $status{tags} = $status{keywords};
592 $status{"package"} =~ s/\s*$//;
593 $status{"package"} = 'unknown' if ($status{"package"} eq '');
594 $status{"severity"} = 'normal' if ($status{"severity"} eq '');
596 $status{"pending"} = 'pending';
597 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
598 $status{"pending"} = 'pending-fixed' if ($status{"tags"} =~ /\bpending\b/);
599 $status{"pending"} = 'fixed' if ($status{"tags"} =~ /\bfixed\b/);
600 $status{"pending"} = 'done' if (length($status{"done"}));
608 my %pkgsrc = %{getpkgsrc()};
610 foreach ( keys %pkgsrc ) {
611 push @pkgs, $_ if $pkgsrc{$_} eq $src;
619 my $dir = getlocationpath( getbuglocation( $bugnum, "log" ) );
620 my $hash = get_hashname( $bugnum );
621 return "" if ( !$dir );
622 return "$dir/$hash/$bugnum.log";