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