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