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