cgi/common.pl

   1 #!/usr/bin/perl -w
   2
   3 use DB_File;
   4 use Fcntl qw/O_RDONLY/;
   5 use Mail::Address;
   6 use MLDBM qw/DB_File/;
   7 use POSIX qw/ceil/;
   8
   9 use URI::Escape;
  10
  11 $config_path = '/etc/debbugs';
  12 $lib_path = '/usr/lib/debbugs';
  13 require "$lib_path/errorlib";
  14
  15 use Debbugs::Packages;
  16 use Debbugs::Versions;
  17 use Debbugs::MIME qw(decode_rfc1522);
  18
  19 $MLDBM::RemoveTaint = 1;
  20
  21 my $common_archive = 0;
  22 my $common_repeatmerged = 1;
  23 my %common_include = ();
  24 my %common_exclude = ();
  25 my $common_raw_sort = 0;
  26 my $common_bug_reverse = 0;
  27
  28 my $common_leet_urls = 0;
  29
  30 my %common_reverse = (
  31     'pending' => 0,
  32     'severity' => 0,
  33 );
  34 my %common = (
  35     'show_list_header' => 1,
  36     'show_list_footer' => 1,
  37 );
  38
  39 sub exact_field_match {
  40     my ($field, $values, $status) = @_;
  41     my @values = @$values;
  42     my @ret = grep {$_ eq $status->{$field} } @values;
  43     $#ret != -1;
  44 }
  45 sub contains_field_match {
  46     my ($field, $values, $status) = @_;
  47     foreach my $data (@$values) {
  48         return 1 if (index($status->{$field}, $data) > -1);
  49     }
  50     return 0;
  51 }
  52
  53 sub detect_user_agent {
  54     my $userAgent = $ENV{HTTP_USER_AGENT};
  55     return { 'name' => 'unknown' } unless defined $userAgent;
  56     return { 'name' => 'links' } if ( $userAgent =~ m,^ELinks,);
  57     return { 'name' => 'lynx' } if ( $userAgent =~ m,^Lynx,);
  58     return { 'name' => 'wget' } if ( $userAgent =~ m,^Wget,);
  59     return { 'name' => 'gecko' } if ( $userAgent =~ m,^Mozilla.* Gecko/,);
  60     return { 'name' => 'ie' } if ( $userAgent =~ m,^.*MSIE.*,);
  61     return { 'name' => 'unknown' };
  62 }
  63
  64 my %field_match = (
  65     'subject' => \&contains_field_match,
  66     'tags' => sub {
  67         my ($field, $values, $status) = @_;
  68         my %values = map {$_=>1} @$values;
  69         foreach my $t (split /\s+/, $status->{$field}) {
  70             return 1 if (defined $values{$t});
  71         }
  72         return 0;
  73     },
  74     'severity' => \&exact_field_match,
  75     'pending' => \&exact_field_match,
  76     'originator' => \%contains_field_match,
  77     'forwarded' => \%contains_field_match,
  78     'owner' => \%contains_field_match,
  79 );
  80 my @common_grouping = ( 'severity', 'pending' );
  81 my %common_grouping_order = (
  82     'pending' => [ qw( pending forwarded pending-fixed fixed done absent ) ],
  83     'severity' => \@debbugs::gSeverityList,
  84 );
  85 my %common_grouping_display = (
  86     'pending' => 'Status',
  87     'severity' => 'Severity',
  88 );
  89 my %common_headers = (
  90     'pending' => {
  91         "pending"       => "outstanding",
  92         "pending-fixed" => "pending upload",
  93         "fixed"         => "fixed in NMU",
  94         "done"          => "resolved",
  95         "forwarded"     => "forwarded to upstream software authors",
  96         "absent"        => "not applicable to this version",
  97     },
  98     'severity' => \%debbugs::gSeverityDisplay,
  99 );
 100
 101 my $common_version;
 102 my $common_dist;
 103 my $common_arch;
 104
 105 my $debug = 0;
 106 my $use_bug_idx = 0;
 107 my %bugidx;
 108
 109 sub array_option($) {
 110     my ($val) = @_;
 111     my @vals;
 112     @vals = ( $val ) if (ref($val) eq "" && $val );
 113     @vals = ( $$val ) if (ref($val) eq "SCALAR" && $$val );
 114     @vals = @{$val} if (ref($val) eq "ARRAY" );
 115     return @vals;
 116 }
 117
 118 sub filter_include_exclude($\%) {
 119     my ($val, $filter_map) = @_;
 120     my @vals = array_option($val);
 121     my @data = map {
 122         if (/^([^:]*):(.*)$/) { if ($1 eq 'subj') { ['subject', $2]; } else { [$1, $2] } } else { ['tags', $_] }
 123     } split /[\s,]+/, join ',', @vals;
 124     foreach my $data (@data) {
 125         &quitcgi("Invalid filter key: '$data->[0]'") if (!exists($field_match{$data->[0]}));
 126         push @{$filter_map->{$data->[0]}}, $data->[1];
 127     }
 128 }
 129
 130 sub filter_option($$\%) {
 131     my ($key, $val, $filter_map) = @_;
 132     my @vals = array_option($val);
 133     foreach $val (@vals) {
 134         push @{$filter_map->{$key}}, $val;
 135     }
 136 }
 137
 138 sub set_option {
 139     my ($opt, $val) = @_;
 140     if ($opt eq "use-bug-idx") {
 141         $use_bug_idx = $val;
 142         if ( $val ) {
 143             $common_headers{pending}{open} = $common_headers{pending}{pending};
 144             my $bugidx = tie %bugidx, MLDBM => "$debbugs::gSpoolDir/realtime/bug.idx", O_RDONLY
 145                 or quitcgi( "$0: can't open $debbugs::gSpoolDir/realtime/bug.idx ($!)\n" );
 146             $bugidx->RemoveTaint(1);
 147         } else {
 148             untie %bugidx;
 149         }
 150     }
 151     if ($opt =~ m/^show_list_(foot|head)er$/) { $common{$opt} = $val; }
 152     if ($opt eq "archive") { $common_archive = $val; }
 153     if ($opt eq "repeatmerged") { $common_repeatmerged = $val; }
 154     if ($opt eq "exclude") {
 155         filter_include_exclude($val, %common_exclude);
 156     }
 157     if ($opt eq "include") {
 158         filter_include_exclude($val, %common_include);
 159     }
 160     if ($opt eq "raw") { $common_raw_sort = $val; }
 161     if ($opt eq "bug-rev") { $common_bug_reverse = $val; }
 162     if ($opt eq "pend-rev") { $common_reverse{pending} = $val; }
 163     if ($opt eq "sev-rev") { $common_reverse{severity} = $val; }
 164     if ($opt eq "pend-exc") {
 165         filter_option('pending', $val, %common_exclude);
 166     }
 167     if ($opt eq "pend-inc") {
 168         filter_option('pending', $val, %common_include);
 169     }
 170     if ($opt eq "sev-exc") {
 171         filter_option('severity', $val, %common_exclude);
 172     }
 173     if ($opt eq "sev-inc") {
 174         filter_option('severity', $val, %common_include);
 175     }
 176     if ($opt eq "version") { $common_version = $val; }
 177     if ($opt eq "dist") { $common_dist = $val; }
 178     if ($opt eq "arch") { $common_arch = $val; }
 179 }
 180
 181 sub readparse {
 182     my ($in, $key, $val, %ret);
 183     if ($#ARGV >= 0) {
 184         $in = join("&", map { s/&/%26/g; s/;/%3b/g; $_ } @ARGV);
 185     } elsif (defined $ENV{"QUERY_STRING"} && $ENV{"QUERY_STRING"} ne "") {
 186         $in=$ENV{QUERY_STRING};
 187     } elsif(defined $ENV{"REQUEST_METHOD"}
 188         && $ENV{"REQUEST_METHOD"} eq "POST")
 189     {
 190         read(STDIN,$in,$ENV{CONTENT_LENGTH});
 191     } else {
 192         return;
 193     }
 194     if (defined $ENV{"HTTP_COOKIE"}) {
 195         my $x = $ENV{"HTTP_COOKIE"};
 196         $x =~ s/;\s+/;/g;
 197         $in = "$x;$in";
 198     }
 199     foreach (split(/[&;]/,$in)) {
 200         s/\+/ /g;
 201         ($key, $val) = split(/=/,$_,2);
 202         $key=~s/%(..)/pack("c",hex($1))/ge;
 203         $val=~s/%(..)/pack("c",hex($1))/ge;
 204         if ( exists $ret{$key} ) {
 205             if ( !exists $ret{"&$key"} ) {
 206                 $ret{"&$key"} = [ $ret{$key} ];
 207             }
 208             push @{$ret{"&$key"}},$val;
 209         }
 210         $ret{$key}=$val;
 211     }
 212
 213 $debug = 1 if (defined $ret{"debug"} && $ret{"debug"} eq "aj");
 214
 215     $common_leet_urls = 1
 216        if (defined $ret{"leeturls"} && $ret{"leeturls"} eq "yes");
 217
 218     return %ret;
 219 }
 220
 221 sub quitcgi {
 222     my $msg = shift;
 223     print "Content-Type: text/html\n\n";
 224     print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
 225     print "An error occurred. Dammit.\n";
 226     print "Error was: $msg.\n";
 227     print "</BODY></HTML>\n";
 228     exit 0;
 229 }
 230
 231 #sub abort {
 232 #    my $msg = shift;
 233 #    my $Archive = $common_archive ? "archive" : "";
 234 #    print header . start_html("Sorry");
 235 #    print "Sorry bug #$msg doesn't seem to be in the $Archive database.\n";
 236 #    print end_html;
 237 #    exit 0;
 238 #}
 239
 240 # Split a package string from the status file into a list of package names.
 241 sub splitpackages {
 242     my $pkgs = shift;
 243     return unless defined $pkgs;
 244     return map lc, split /[ \t?,()]+/, $pkgs;
 245 }
 246
 247 my %_parsedaddrs;
 248 sub getparsedaddrs {
 249     my $addr = shift;
 250     return () unless defined $addr;
 251     return @{$_parsedaddrs{$addr}} if exists $_parsedaddrs{$addr};
 252     @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
 253     return @{$_parsedaddrs{$addr}};
 254 }
 255
 256 # Generate a comma-separated list of HTML links to each package given in
 257 # $pkgs. $pkgs may be empty, in which case an empty string is returned, or
 258 # it may be a comma-separated list of package names.
 259 sub htmlpackagelinks {
 260     my $pkgs = shift;
 261     return unless defined $pkgs and $pkgs ne '';
 262     my $strong = shift;
 263     my @pkglist = splitpackages($pkgs);
 264
 265     my $openstrong  = $strong ? '<strong>' : '';
 266     my $closestrong = $strong ? '</strong>' : '';
 267
 268     return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
 269            join(', ',
 270                 map {
 271                     '<a href="' . pkgurl($_) . '">' .
 272                     $openstrong . htmlsanit($_) . $closestrong . '</a>'
 273                 } @pkglist
 274            );
 275 }
 276
 277 # Generate a comma-separated list of HTML links to each address given in
 278 # $addresses, which should be a comma-separated list of RFC822 addresses.
 279 # $urlfunc should be a reference to a function like mainturl or submitterurl
 280 # which returns the URL for each individual address.
 281 sub htmladdresslinks {
 282     my ($prefixfunc, $urlfunc, $addresses) = @_;
 283     if (defined $addresses and $addresses ne '') {
 284         my @addrs = getparsedaddrs($addresses);
 285         my $prefix = (ref $prefixfunc) ? $prefixfunc->(scalar @addrs)
 286                                        : $prefixfunc;
 287         return $prefix .
 288                join ', ', map { sprintf '<a href="%s">%s</a>',
 289                                         $urlfunc->($_->address),
 290                                         htmlsanit($_->format) || '(unknown)'
 291                               } @addrs;
 292     } else {
 293         my $prefix = (ref $prefixfunc) ? $prefixfunc->(1) : $prefixfunc;
 294         return sprintf '%s<a href="%s">(unknown)</a>', $prefix, $urlfunc->('');
 295     }
 296 }
 297
 298 # Generate a comma-separated list of HTML links to each maintainer given in
 299 # $maints, which should be a comma-separated list of RFC822 addresses.
 300 sub htmlmaintlinks {
 301     my ($prefixfunc, $maints) = @_;
 302     return htmladdresslinks($prefixfunc, \&mainturl, $maints);
 303 }
 304
 305 sub htmlindexentry {
 306     my $ref = shift;
 307     my %status = %{getbugstatus($ref)};
 308     return htmlindexentrystatus(%status) if (%status);
 309     return "";
 310 }
 311
 312 sub htmlindexentrystatus {
 313     my $s = shift;
 314     my %status = %{$s};
 315
 316     my $result = "";
 317
 318     if  ($status{severity} eq 'normal') {
 319         $showseverity = '';
 320     } elsif (isstrongseverity($status{severity})) {
 321         $showseverity = "<strong>Severity: $status{severity}</strong>;\n";
 322     } else {
 323         $showseverity = "Severity: <em>$status{severity}</em>;\n";
 324     }
 325
 326     $result .= htmlpackagelinks($status{"package"}, 1);
 327
 328     my $showversions = '';
 329     if (@{$status{found_versions}}) {
 330         my @found = @{$status{found_versions}};
 331         local $_;
 332         s{/}{ } foreach @found;
 333         $showversions .= join ', ', map htmlsanit($_), @found;
 334     }
 335     if (@{$status{fixed_versions}}) {
 336         $showversions .= '; ' if length $showversions;
 337         $showversions .= '<strong>fixed</strong>: ';
 338         my @fixed = @{$status{fixed_versions}};
 339         local $_;
 340         s{/}{ } foreach @fixed;
 341         $showversions .= join ', ', map htmlsanit($_), @fixed;
 342     }
 343     $result .= " ($showversions)" if length $showversions;
 344     $result .= ";\n";
 345
 346     $result .= $showseverity;
 347     $result .= htmladdresslinks("Reported by: ", \&submitterurl,
 348                                 $status{originator});
 349     $result .= ";\nOwned by: " . htmlsanit($status{owner})
 350                if length $status{owner};
 351     $result .= ";\nTags: <strong>"
 352                  . htmlsanit(join(", ", sort(split(/\s+/, $status{tags}))))
 353                  . "</strong>"
 354                        if (length($status{tags}));
 355
 356     my @merged= split(/ /,$status{mergedwith});
 357     my $mseparator= ";\nmerged with ";
 358     for my $m (@merged) {
 359         $result .= $mseparator."<A href=\"" . bugurl($m) . "\">#$m</A>";
 360         $mseparator= ", ";
 361     }
 362
 363     if (length($status{done})) {
 364         $result .= ";\n<strong>Done:</strong> " . htmlsanit($status{done});
 365         $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
 366         if ($days >= 0) {
 367             $result .= ";\n<strong>Will be archived:</strong>" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" );
 368         } else {
 369             $result .= ";\n<strong>Archived</strong>";
 370         }
 371     }
 372
 373     unless (length($status{done})) {
 374         if (length($status{forwarded})) {
 375             $result .= ";\n<strong>Forwarded</strong> to "
 376                        . maybelink($status{forwarded});
 377         }
 378         my $daysold = int((time - $status{date}) / 86400);   # seconds to days
 379         if ($daysold >= 7) {
 380             my $font = "";
 381             my $efont = "";
 382             $font = "em" if ($daysold > 30);
 383             $font = "strong" if ($daysold > 60);
 384             $efont = "</$font>" if ($font);
 385             $font = "<$font>" if ($font);
 386
 387             my $yearsold = int($daysold / 365);
 388             $daysold -= $yearsold * 365;
 389
 390             $result .= ";\n $font";
 391             my @age;
 392             push @age, "1 year" if ($yearsold == 1);
 393             push @age, "$yearsold years" if ($yearsold > 1);
 394             push @age, "1 day" if ($daysold == 1);
 395             push @age, "$daysold days" if ($daysold > 1);
 396             $result .= join(" and ", @age);
 397             $result .= " old$efont";
 398         }
 399     }
 400
 401     $result .= ".";
 402
 403     return $result;
 404 }
 405
 406 sub urlargs {
 407     my $args = '';
 408     $args .= ";archive=yes" if $common_archive;
 409     $args .= ";repeatmerged=no" unless $common_repeatmerged;
 410     $args .= ";version=$common_version" if defined $common_version;
 411     $args .= ";dist=$common_dist" if defined $common_dist;
 412     $args .= ";arch=$common_arch" if defined $common_arch;
 413     return $args;
 414 }
 415
 416 sub submitterurl { pkg_etc_url(emailfromrfc822($_[0] || ""), "submitter"); }
 417 sub mainturl { pkg_etc_url(emailfromrfc822($_[0] || ""), "maint"); }
 418 sub pkgurl { pkg_etc_url($_[0] || "", "pkg"); }
 419 sub srcurl { pkg_etc_url($_[0] || "", "src"); }
 420 sub tagurl { pkg_etc_url($_[0] || "", "tag"); }
 421
 422 sub pkg_etc_url {
 423     my $ref = shift;
 424     my $code = shift;
 425     if ($common_leet_urls) {
 426         $code = "package" if ($code eq "pkg");
 427         $code = "source" if ($code eq "src");
 428         return urlsanit("/x/$code/$ref");
 429     } else {
 430         my $params = "$code=$ref";
 431         $params .= urlargs();
 432         return urlsanit("pkgreport.cgi" . "?" . $params);
 433     }
 434 }
 435
 436 sub urlsanit {
 437     my $url = shift;
 438     $url =~ s/%/%25/g;
 439     $url =~ s/#/%23/g;
 440     $url =~ s/\+/%2b/g;
 441     my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
 442     $url =~ s/([<>&"])/\&$saniarray{$1};/g;
 443     return $url;
 444 }
 445
 446 sub htmlsanit {
 447     my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
 448     my $in = shift || "";
 449     $in =~ s/([<>&"])/\&$saniarray{$1};/g;
 450     return $in;
 451 }
 452
 453 sub maybelink {
 454     my $in = shift;
 455     if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
 456         return qq{<a href="$in">} . htmlsanit($in) . '</a>';
 457     } else {
 458         return htmlsanit($in);
 459     }
 460 }
 461
 462 sub bugurl {
 463     my $ref = shift;
 464     my $params = "bug=$ref";
 465     my $filename = '';
 466
 467     if ($common_leet_urls) {
 468         my $msg = "";
 469         my $mbox = "";
 470         my $att = "";
 471         foreach my $val (@_) {
 472             $mbox = "/mbox" if ($val eq "mbox");
 473             $msg = "/$1" if ($val =~ /^msg=([0-9]+)/);
 474             $att = "/$1" if ($val =~ /^att=([0-9]+)/);
 475             $filename = "/$1" if ($val =~ /^filename=(.*)$/);
 476         }
 477         my $ext = "";
 478         if ($mbox ne "") {
 479             $ext = $mbox;
 480         } elsif ($att ne "") {
 481             $ext = "$att$filename";
 482         }
 483         return urlsanit("/x/$ref$msg$ext");
 484     } else {
 485         foreach my $val (@_) {
 486             $params .= ";mbox=yes" if ($val eq "mbox");
 487             $params .= ";msg=$1" if ($val =~ /^msg=([0-9]+)/);
 488             $params .= ";att=$1" if ($val =~ /^att=([0-9]+)/);
 489             $filename = $1 if ($val =~ /^filename=(.*)$/);
 490             $params .= ";archive=yes" if (!$common_archive && $val =~ /^archive.*$/);
 491         }
 492         $params .= ";archive=yes" if ($common_archive);
 493         $params .= ";repeatmerged=no" unless ($common_repeatmerged);
 494
 495         my $pathinfo = '';
 496         $pathinfo = '/'.uri_escape($filename) if $filename ne '';
 497
 498         return urlsanit("bugreport.cgi" . $pathinfo . "?" . $params);
 499     }
 500 }
 501
 502 sub dlurl { bugurl(@_); }
 503 sub mboxurl { return bugurl($ref, "mbox"); }
 504
 505 sub allbugs {
 506     return @{getbugs(sub { 1 })};
 507 }
 508
 509 sub bugmatches(\%\%) {
 510     my ($hash, $status) = @_;
 511     foreach my $key( keys( %$hash ) ) {
 512         my $value = $hash->{$key};
 513         my $sub = $field_match{$key};
 514         return 1 if ($sub->($key, $value, $status));
 515     }
 516     return 0;
 517 }
 518 sub bugfilter($%) {
 519     my ($bug, %status) = @_;
 520     our (%seenmerged);
 521     if (%common_include) {
 522         return 1 if (!bugmatches(%common_include, %status));
 523     }
 524     if (%common_exclude) {
 525         return 1 if (bugmatches(%common_exclude, %status));
 526     }
 527     my @merged = sort {$a<=>$b} $bug, split(/ /, $status{mergedwith});
 528     return 1 unless ($common_repeatmerged || !$seenmerged{$merged[0]});
 529     $seenmerged{$merged[0]} = 1;
 530     return 0;
 531 }
 532
 533 sub htmlizebugs {
 534     $b = $_[0];
 535     my @bugs = @$b;
 536     my $anydone = 0;
 537
 538     my @status = ();
 539     my %count;
 540     my $header = '';
 541     my $footer = '';
 542
 543     if (@bugs == 0) {
 544         return "<HR><H2>No reports found!</H2></HR>\n";
 545     }
 546
 547     if ( $common_bug_reverse ) {
 548         @bugs = sort {$b<=>$a} @bugs;
 549     } else {
 550         @bugs = sort {$a<=>$b} @bugs;
 551     }
 552     my %seenmerged;
 553     foreach my $bug (@bugs) {
 554         my %status = %{getbugstatus($bug)};
 555         next unless %status;
 556         next if bugfilter($bug, %status);
 557
 558         my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
 559             bugurl($bug), $bug, htmlsanit($status{subject});
 560         $html .= htmlindexentrystatus(\%status) . "\n";
 561         my $key = join( '_', map( {$status{$_}} @common_grouping ) );
 562         $section{$key} .= $html;
 563         $count{"_$key"}++;
 564         foreach my $grouping ( @common_grouping ) {
 565             $count{"${grouping}_$status{$grouping}"}++;
 566         }
 567         $anydone = 1 if $status{pending} eq 'done';
 568         push @status, [ $bug, \%status, $html ];
 569     }
 570
 571     my $result = "";
 572     if ($common_raw_sort) {
 573         $result .= "<UL>\n" . join("", map( { $_->[ 2 ] } @status ) ) . "</UL>\n";
 574     } else {
 575         my (@order, @headers);
 576         for( my $i = 0; $i < @common_grouping; $i++ ) {
 577             my $grouping_name = $common_grouping[ $i ];
 578             my @items = @{ $common_grouping_order{ $grouping_name } };
 579             @items = reverse( @items ) if ( $common_reverse{ $grouping_name } );
 580             my @neworder = ();
 581             my @newheaders = ();
 582             if ( @order ) {
 583                 foreach my $grouping ( @items ) {
 584                     push @neworder, map( { "${_}_$grouping" } @order );
 585                     push @newheaders, map( { "$_ - $common_headers{$grouping_name}{$grouping}" } @headers );
 586                 }
 587                 @order = @neworder;
 588                 @headers = @newheaders;
 589             } else {
 590                 push @order, @items;
 591                 push @headers, map( { $common_headers{$common_grouping[$i]}{$_} } @items );
 592             }
 593         }
 594         $header .= "<ul>\n";
 595         for ( my $i = 0; $i < @order; $i++ ) {
 596             my $order = $order[ $i ];
 597             next unless defined $section{$order};
 598             my $count = $count{"_$order"};
 599             my $bugs = $count == 1 ? "bug" : "bugs";
 600             $header .= "<li><a href=\"#$order\">$headers[$i]</a> ($count $bugs)</li>\n";
 601         }
 602         $header .= "</ul>\n";
 603         for ( my $i = 0; $i < @order; $i++ ) {
 604             my $order = $order[ $i ];
 605             next unless defined $section{$order};
 606             if ($common{show_list_header}) {
 607                 my $count = $count{"_$order"};
 608                 my $bugs = $count == 1 ? "bug" : "bugs";
 609                 $result .= "<HR><H2><a name=\"$order\"></a>$headers[$i] ($count $bugs)</H2>\n";
 610             } else {
 611                 $result .= "<HR><H2>$headers[$i]</H2>\n";
 612             }
 613             $result .= "<UL>\n";
 614             $result .= $section{$order};
 615             $result .= "</UL>\n";
 616         }
 617         $footer .= "<ul>\n";
 618         foreach my $grouping ( @common_grouping ) {
 619             my $local_result = '';
 620             foreach my $key ( @{$common_grouping_order{ $grouping }} ) {
 621                 my $count = $count{"${grouping}_$key"};
 622                 next if !$count;
 623                 $local_result .= "<li>$count $common_headers{$grouping}{$key}</li>\n";
 624             }
 625             if ( $local_result ) {
 626                 $footer .= "<li>$common_grouping_display{$grouping}<ul>\n$local_result</ul></li>\n";
 627             }
 628         }
 629         $footer .= "</ul>\n";
 630     }
 631
 632     $result = $header . $result if ( $common{show_list_header} );
 633     $result .= $debbugs::gHTMLExpireNote if $debbugs::gRemoveAge and $anydone;
 634     $result .= "<hr>" . $footer if ( $common{show_list_footer} );
 635     return $result;
 636 }
 637
 638 sub countbugs {
 639     my $bugfunc = shift;
 640     if ($common_archive) {
 641         open I, "<$debbugs::gSpoolDir/index.archive"
 642             or &quitcgi("$debbugs::gSpoolDir/index.archive: $!");
 643     } else {
 644         open I, "<$debbugs::gSpoolDir/index.db"
 645             or &quitcgi("$debbugs::gSpoolDir/index.db: $!");
 646     }
 647
 648     my %count = ();
 649     while(<I>)
 650     {
 651         if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
 652             my @x = $bugfunc->(pkg => $1, bug => $2, status => $4,
 653                                submitter => $5, severity => $6, tags => $7);
 654             local $_;
 655             $count{$_}++ foreach @x;
 656         }
 657     }
 658     close I;
 659     return %count;
 660 }
 661
 662 sub getbugs {
 663     my $bugfunc = shift;
 664     my $opt = shift;
 665
 666     my @result = ();
 667
 668     my $fastidx;
 669     if (!defined $opt) {
 670         # leave $fastidx undefined;
 671     } elsif (!$common_archive) {
 672         $fastidx = "$debbugs::gSpoolDir/by-$opt.idx";
 673     } else {
 674         $fastidx = "$debbugs::gSpoolDir/by-$opt-arc.idx";
 675     }
 676
 677     if (defined $fastidx && -e $fastidx) {
 678         my %lookup;
 679 print STDERR "optimized\n" if ($debug);
 680         tie %lookup, DB_File => $fastidx, O_RDONLY
 681             or die "$0: can't open $fastidx ($!)\n";
 682         while ($key = shift) {
 683             my $bugs = $lookup{$key};
 684             if (defined $bugs) {
 685                 push @result, (unpack 'N*', $bugs);
 686             } elsif (defined $lookup{"count $key"}) {
 687                 my $which = 0;
 688                 while (1) {
 689                     $bugs = $lookup{"$which $key"};
 690                     last unless defined $bugs;
 691                     push @result, (unpack 'N*', $bugs);
 692                     $which += 100;
 693                 }
 694             }
 695         }
 696         untie %lookup;
 697 print STDERR "done optimized\n" if ($debug);
 698     } else {
 699         if ( $common_archive ) {
 700             open I, "<$debbugs::gSpoolDir/index.archive"
 701                 or &quitcgi("$debbugs::gSpoolDir/index.archive: $!");
 702         } else {
 703             open I, "<$debbugs::gSpoolDir/index.db"
 704                 or &quitcgi("$debbugs::gSpoolDir/index.db: $!");
 705         }
 706         while(<I>) {
 707             if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
 708                 if ($bugfunc->(pkg => $1, bug => $2, status => $4,
 709                             submitter => $5, severity => $6, tags => $7))
 710                 {
 711                     push (@result, $2);
 712                 }
 713             }
 714         }
 715         close I;
 716     }
 717     @result = sort {$a <=> $b} @result;
 718     return \@result;
 719 }
 720
 721 sub emailfromrfc822 {
 722     my $email = shift;
 723     $email =~ s/\s*\(.*\)\s*//;
 724     $email = $1 if ($email =~ m/<(.*)>/);
 725     return $email;
 726 }
 727
 728 sub maintencoded {
 729     my $input = shift;
 730     my $encoded = '';
 731
 732     while ($input =~ m/\W/) {
 733         $encoded.=$`.sprintf("-%02x_",unpack("C",$&));
 734         $input= $';
 735     }
 736
 737     $encoded.= $input;
 738     $encoded =~ s/-2e_/\./g;
 739     $encoded =~ s/^([^,]+)-20_-3c_(.*)-40_(.*)-3e_/$1,$2,$3,/;
 740     $encoded =~ s/^(.*)-40_(.*)-20_-28_([^,]+)-29_$/,$1,$2,$3/;
 741     $encoded =~ s/-20_/_/g;
 742     $encoded =~ s/-([^_]+)_-/-$1/g;
 743     return $encoded;
 744 }
 745
 746 my $_maintainer;
 747 sub getmaintainers {
 748     return $_maintainer if $_maintainer;
 749     my %maintainer;
 750
 751     open(MM,"$debbugs::gMaintainerFile") or &quitcgi("open $debbugs::gMaintainerFile: $!");
 752     while(<MM>) {
 753         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 754         ($a,$b)=($1,$2);
 755         $a =~ y/A-Z/a-z/;
 756         $maintainer{$a}= $b;
 757     }
 758     close(MM);
 759     if (defined $debbugs::gMaintainerFileOverride) {
 760         open(MM,"$debbugs::gMaintainerFileOverride") or &quitcgi("open $debbugs::gMaintainerFileOverride: $!");
 761         while(<MM>) {
 762             next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 763             ($a,$b)=($1,$2);
 764             $a =~ y/A-Z/a-z/;
 765             $maintainer{$a}= $b;
 766         }
 767         close(MM);
 768     }
 769     $_maintainer = \%maintainer;
 770     return $_maintainer;
 771 }
 772
 773 my $_pseudodesc;
 774 sub getpseudodesc {
 775     return $_pseudodesc if $_pseudodesc;
 776     my %pseudodesc;
 777
 778     open(PSEUDO, "< $debbugs::gPseudoDescFile") or &quitcgi("open $debbugs::gPseudoDescFile: $!");
 779     while(<PSEUDO>) {
 780         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 781         $pseudodesc{lc $1} = $2;
 782     }
 783     close(PSEUDO);
 784     $_pseudodesc = \%pseudodesc;
 785     return $_pseudodesc;
 786 }
 787
 788 sub getbugstatus {
 789     my $bugnum = shift;
 790
 791     my %status;
 792
 793     if ( $use_bug_idx eq 1 && exists( $bugidx{ $bugnum } ) ) {
 794         %status = %{ $bugidx{ $bugnum } };
 795         $status{ pending } = $status{ status };
 796         $status{ id } = $bugnum;
 797         return \%status;
 798     }
 799
 800     my $location = getbuglocation( $bugnum, 'summary' );
 801     return {} if ( !$location );
 802     %status = %{ readbug( $bugnum, $location ) };
 803     $status{ id } = $bugnum;
 804
 805     $status{tags} = $status{keywords};
 806     my %tags = map { $_ => 1 } split ' ', $status{tags};
 807
 808     $status{"package"} =~ s/\s*$//;
 809     $status{"package"} = 'unknown' if ($status{"package"} eq '');
 810     $status{"severity"} = 'normal' if ($status{"severity"} eq '');
 811
 812     $status{"pending"} = 'pending';
 813     $status{"pending"} = 'forwarded'        if (length($status{"forwarded"}));
 814     $status{"pending"} = 'pending-fixed'    if ($tags{pending});
 815     $status{"pending"} = 'fixed'            if ($tags{fixed});
 816
 817     my @versions;
 818     if (defined $common_version) {
 819         @versions = ($common_version);
 820     } elsif (defined $common_dist) {
 821         @versions = getversions($status{package}, $common_dist, $common_arch);
 822     }
 823
 824     # TODO: This should probably be handled further out for efficiency and
 825     # for more ease of distinguishing between pkg= and src= queries.
 826     my @sourceversions = makesourceversions($status{package}, $common_arch,
 827                                             @versions);
 828
 829     if (@sourceversions) {
 830         # Resolve bugginess states (we might be looking at multiple
 831         # architectures, say). Found wins, then fixed, then absent.
 832         my $maxbuggy = 'absent';
 833         for my $version (@sourceversions) {
 834             my $buggy = buggyversion($bugnum, $version, \%status);
 835             if ($buggy eq 'found') {
 836                 $maxbuggy = 'found';
 837                 last;
 838             } elsif ($buggy eq 'fixed' and $maxbuggy ne 'found') {
 839                 $maxbuggy = 'fixed';
 840             }
 841         }
 842         if ($maxbuggy eq 'absent') {
 843             $status{"pending"} = 'absent';
 844         } elsif ($maxbuggy eq 'fixed') {
 845             $status{"pending"} = 'done';
 846         }
 847     }
 848
 849     if (length($status{done}) and
 850             (not @sourceversions or not @{$status{fixed_versions}})) {
 851         $status{"pending"} = 'done';
 852     }
 853
 854     return \%status;
 855 }
 856
 857 sub buglog {
 858     my $bugnum = shift;
 859     my $location = getbuglocation($bugnum, 'log');
 860     return getbugcomponent($bugnum, 'log', $location) if ($location);
 861     $location = getbuglocation($bugnum, 'log.gz');
 862     return getbugcomponent($bugnum, 'log.gz', $location);
 863 }
 864
 865 # Canonicalize versions into source versions, which have an explicitly
 866 # named source package. This is used to cope with source packages whose
 867 # names have changed during their history, and with cases where source
 868 # version numbers differ from binary version numbers.
 869 sub makesourceversions {
 870     my $pkg = shift;
 871     my $arch = shift;
 872     my %sourceversions;
 873
 874     for my $version (@_) {
 875         if ($version =~ m[/]) {
 876             # Already a source version.
 877             $sourceversions{$version} = 1;
 878         } else {
 879             my @srcinfo = binarytosource($pkg, $version, $arch);
 880             unless (@srcinfo) {
 881                 # We don't have explicit information about the
 882                 # binary-to-source mapping for this version (yet). Since
 883                 # this is a CGI script and our output is transient, we can
 884                 # get away with just looking in the unversioned map; if it's
 885                 # wrong (as it will be when binary and source package
 886                 # versions differ), too bad.
 887                 my $pkgsrc = getpkgsrc();
 888                 if (exists $pkgsrc->{$pkg}) {
 889                     @srcinfo = ([$pkgsrc->{$pkg}, $version]);
 890                 } else {
 891                     next;
 892                 }
 893             }
 894             $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
 895         }
 896     }
 897
 898     return sort keys %sourceversions;
 899 }
 900
 901 my %_versionobj;
 902 sub buggyversion {
 903     my ($bug, $ver, $status) = @_;
 904     return '' unless defined $debbugs::gVersionPackagesDir;
 905     my $src = getpkgsrc()->{$status->{package}};
 906     $src = $status->{package} unless defined $src;
 907
 908     my $tree;
 909     if (exists $_versionobj{$src}) {
 910         $tree = $_versionobj{$src};
 911     } else {
 912         $tree = Debbugs::Versions->new(\&DpkgVer::vercmp);
 913         my $srchash = substr $src, 0, 1;
 914         if (open VERFILE, "< $debbugs::gVersionPackagesDir/$srchash/$src") {
 915             $tree->load(\*VERFILE);
 916             close VERFILE;
 917         }
 918         $_versionobj{$src} = $tree;
 919     }
 920
 921     my @found = makesourceversions($status->{package}, undef,
 922                                    @{$status->{found_versions}});
 923     my @fixed = makesourceversions($status->{package}, undef,
 924                                    @{$status->{fixed_versions}});
 925
 926     return $tree->buggy($ver, \@found, \@fixed);
 927 }
 928
 929 my %_versions;
 930 sub getversions {
 931     my ($pkg, $dist, $arch) = @_;
 932     return () unless defined $debbugs::gVersionIndex;
 933     $dist = 'unstable' unless defined $dist;
 934
 935     unless (tied %_versions) {
 936         tie %_versions, 'MLDBM', $debbugs::gVersionIndex, O_RDONLY
 937             or die "can't open versions index: $!";
 938     }
 939
 940     if (defined $arch and exists $_versions{$pkg}{$dist}{$arch}) {
 941         my $ver = $_versions{$pkg}{$dist}{$arch};
 942         return $ver if defined $ver;
 943         return ();
 944     } else {
 945         my %uniq;
 946         for my $ar (keys %{$_versions{$pkg}{$dist}}) {
 947             $uniq{$_versions{$pkg}{$dist}{$ar}} = 1 unless $ar eq 'source';
 948         }
 949         return keys %uniq;
 950     }
 951 }
 952
 953 sub getversiondesc {
 954     my $pkg = shift;
 955
 956     if (defined $common_version) {
 957         return "version $common_version";
 958     } elsif (defined $common_dist) {
 959         my @distvers = getversions($pkg, $common_dist, $common_arch);
 960         @distvers = sort @distvers;
 961         local $" = ', ';
 962         if (@distvers > 1) {
 963             return "versions @distvers";
 964         } elsif (@distvers == 1) {
 965             return "version @distvers";
 966         }
 967     }
 968
 969     return undef;
 970 }
 971
 972 1;