cgi/common.pl

   1 #!/usr/bin/perl -w
   2
   3 use DB_File;
   4 use Fcntl qw/O_RDONLY/;
   5
   6 my $common_archive = 0;
   7 my $common_repeatmerged = 1;
   8 my %common_include = ();
   9 my %common_exclude = ();
  10 my $common_raw_sort = 0;
  11 my $common_bug_reverse = 0;
  12
  13 my $debug = 0;
  14
  15 sub set_option {
  16     my ($opt, $val) = @_;
  17     if ($opt eq "archive") { $common_archive = $val; }
  18     if ($opt eq "repeatmerged") { $common_repeatmerged = $val; }
  19     if ($opt eq "exclude") { %common_exclude = %{$val}; }
  20     if ($opt eq "include") { %common_include = %{$val}; }
  21     if ($opt eq "raw") { $common_raw_sort = $val; }
  22     if ($opt eq "bug-rev") { $common_bug_reverse = $val; }
  23 }
  24
  25 sub readparse {
  26     my ($in, $key, $val, %ret);
  27     if (defined $ENV{"QUERY_STRING"} && $ENV{"QUERY_STRING"} ne "") {
  28         $in=$ENV{QUERY_STRING};
  29     } elsif(defined $ENV{"REQUEST_METHOD"}
  30         && $ENV{"REQUEST_METHOD"} eq "POST")
  31     {
  32         read(STDIN,$in,$ENV{CONTENT_LENGTH});
  33     } else {
  34         return;
  35     }
  36     foreach (split(/&/,$in)) {
  37         s/\+/ /g;
  38         ($key, $val) = split(/=/,$_,2);
  39         $key=~s/%(..)/pack("c",hex($1))/ge;
  40         $val=~s/%(..)/pack("c",hex($1))/ge;
  41         if ( exists $ret{$key} ) {
  42             if ( !exists $ret{"&$key"} ) {
  43                 $ret{"&$key"} = [ $ret{$key} ];
  44             }
  45             push @{$ret{"&$key"}},$val;
  46         }
  47         $ret{$key}=$val;
  48     }
  49 $debug = 1 if (defined $ret{"debug"} && $ret{"debug"} eq "aj");
  50     return %ret;
  51 }
  52
  53 sub quit {
  54     my $msg = shift;
  55     print "Content-Type: text/html\n\n";
  56     print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
  57     print "An error occurred. Dammit.\n";
  58     print "Error was: $msg.\n";
  59     print "</BODY></HTML>\n";
  60     exit 0;
  61 }
  62
  63 #sub abort {
  64 #    my $msg = shift;
  65 #    my $Archive = $common_archive ? "archive" : "";
  66 #    print header . start_html("Sorry");
  67 #    print "Sorry bug #$msg doesn't seem to be in the $Archive database.\n";
  68 #    print end_html;
  69 #    exit 0;
  70 #}
  71
  72 sub htmlindexentry {
  73     my $ref = shift;
  74     my %status = %{getbugstatus($ref)};
  75     return htmlindexentrystatus(%status) if (%status);
  76     return "";
  77 }
  78
  79 sub htmlindexentrystatus {
  80     my $s = shift;
  81     my %status = %{$s};
  82
  83     my $result = "";
  84
  85     if  ($status{severity} eq 'normal') {
  86         $showseverity = '';
  87     } elsif (grep($status{severity} eq $_, @debbugs::gStrongSeverities)) {
  88         $showseverity = "<strong>Severity: $status{severity}</strong>;\n";
  89     } else {
  90         $showseverity = "Severity: <em>$status{severity}</em>;\n";
  91     }
  92
  93     $result .= "Package: <a href=\"" . pkgurl($status{"package"}) . "\">"
  94                . "<strong>" . htmlsanit($status{"package"}) . "</strong></a>;\n"
  95                if (length($status{"package"}));
  96     $result .= $showseverity;
  97     $result .= "Reported by: " . htmlsanit($status{originator});
  98     $result .= ";\nTags: <strong>"
  99                  . htmlsanit(join(", ", sort(split(/\s+/, $status{tags}))))
 100                  . "</strong>"
 101                        if (length($status{tags}));
 102
 103     my @merged= split(/ /,$status{mergedwith});
 104     my $mseparator= ";\nmerged with ";
 105     for my $m (@merged) {
 106         $result .= $mseparator."<A href=\"" . bugurl($m) . "\">#$m</A>";
 107         $mseparator= ", ";
 108     }
 109
 110     if (length($status{done})) {
 111         $result .= ";\n<strong>Done:</strong> " . htmlsanit($status{done});
 112     } elsif (length($status{forwarded})) {
 113         $result .= ";\n<strong>Forwarded</strong> to "
 114                    . htmlsanit($status{forwarded});
 115     } else {
 116         my $daysold = int((time - $status{date}) / 86400);   # seconds to days
 117         if ($daysold >= 7) {
 118             my $font = "";
 119             my $efont = "";
 120             $font = "em" if ($daysold > 30);
 121             $font = "strong" if ($daysold > 60);
 122             $efont = "</$font>" if ($font);
 123             $font = "<$font>" if ($font);
 124
 125             my $yearsold = int($daysold / 364);
 126             $daysold = $daysold - $yearsold * 364;
 127
 128             $result .= ";\n $font";
 129             $result .= "1 year and " if ($yearsold == 1);
 130             $result .= "$yearsold years and " if ($yearsold > 1);
 131             $result .= "1 day old" if ($daysold == 1);
 132             $result .= "$daysold days old" if ($daysold != 1);
 133             $result .= "$efont";
 134         }
 135     }
 136
 137     $result .= ".";
 138
 139     return $result;
 140 }
 141
 142 sub submitterurl {
 143     my $ref = shift || "";
 144     my $params = "submitter=" . emailfromrfc822($ref);
 145     $params .= "&archive=yes" if ($common_archive);
 146     $params .= "&repeatmerged=yes" if ($common_repeatmerged);
 147     return urlsanit($debbugs::gCGIDomain . "pkgreport.cgi" . "?" . $params);
 148 }
 149
 150 sub mainturl {
 151     my $ref = shift || "";
 152     my $params = "maint=" . emailfromrfc822($ref);
 153     $params .= "&archive=yes" if ($common_archive);
 154     $params .= "&repeatmerged=yes" if ($common_repeatmerged);
 155     return urlsanit($debbugs::gCGIDomain . "pkgreport.cgi" . "?" . $params);
 156 }
 157
 158 sub pkgurl {
 159     my $ref = shift;
 160     my $params = "pkg=$ref";
 161     $params .= "&archive=yes" if ($common_archive);
 162     $params .= "&repeatmerged=yes" if ($common_repeatmerged);
 163
 164     return urlsanit($debbugs::gCGIDomain . "pkgreport.cgi" . "?" . "$params");
 165 }
 166
 167 sub srcurl {
 168     my $ref = shift;
 169     my $params = "src=$ref";
 170     $params .= "&archive=yes" if ($common_archive);
 171     $params .= "&repeatmerged=yes" if ($common_repeatmerged);
 172     return urlsanit($debbugs::gCGIDomain . "pkgreport.cgi" . "?" . "$params");
 173 }
 174
 175 sub urlsanit {
 176     my $url = shift;
 177     $url =~ s/%/%25/g;
 178     $url =~ s/\+/%2b/g;
 179     my %saniarray = ('<','lt', '>','gt', '"','quot');
 180     my $out;
 181     while ($url =~ m/[<>"]/) {
 182         $out .= $`. '&'. $saniarray{$&}. ';';
 183         $url = $';
 184     }
 185     $out .= $url;
 186     return $out;
 187 }
 188
 189 sub htmlsanit {
 190     my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
 191     my $in = shift || "";
 192     my $out;
 193     while ($in =~ m/[<>&"]/) {
 194         $out .= $`. '&'. $saniarray{$&}. ';';
 195         $in = $';
 196     }
 197     $out .= $in;
 198     return $out;
 199 }
 200
 201 sub bugurl {
 202     my $ref = shift;
 203     my $params = "bug=$ref";
 204     foreach my $val (@_) {
 205         $params .= "\&msg=$1" if ($val =~ /^msg=([0-9]+)/);
 206         $params .= "\&archive=yes" if (!$common_archive && $val =~ /^archive.*$/);
 207     }
 208     $params .= "&archive=yes" if ($common_archive);
 209     $params .= "&repeatmerged=yes" if ($common_repeatmerged);
 210
 211     return urlsanit($debbugs::gCGIDomain . "bugreport.cgi" . "?" . "$params");
 212 }
 213
 214 sub packageurl {
 215     my $ref = shift;
 216     return urlsanit($debbugs::gCGIDomain . "package.cgi" . "?" . "package=$ref");
 217 }
 218
 219 sub allbugs {
 220     my @bugs = ();
 221
 222     opendir(D, "$debbugs::gSpoolDir/db") or &quit("opendir db: $!");
 223     @bugs = sort {$a<=>$b} grep s/\.status$//,
 224                  (grep m/^[0-9]+\.status$/,
 225                  (readdir(D)));
 226     closedir(D);
 227
 228     return @bugs;
 229 }
 230
 231 sub htmlizebugs {
 232     $b = $_[0];
 233     my @bugs = @$b;
 234     my @rawsort;
 235
 236     my %section = ();
 237
 238     my %displayshowpending = ("pending", "outstanding",
 239                               "pending-fixed", "pending upload",
 240                               "fixed", "fixed in NMU",
 241                               "done", "resolved",
 242                               "forwarded", "forwarded to upstream software authors");
 243
 244     if (@bugs == 0) {
 245         return "<HR><H2>No reports found!</H2></HR>\n";
 246     }
 247
 248     if ( $common_bug_reverse ) {
 249         @bugs = sort {$b<=>$a} @bugs;
 250     } else {
 251         @bugs = sort {$a<=>$b} @bugs;
 252     }
 253     foreach my $bug (@bugs) {
 254         my %status = %{getbugstatus($bug)};
 255         next unless %status;
 256         my @merged = sort {$a<=>$b} ($bug, split(/ /, $status{mergedwith}));
 257         next unless ($common_repeatmerged || $bug == $merged[0]);
 258         if (%common_include) {
 259             my $okay = 0;
 260             foreach my $t (split /\s+/, $status{tags}) {
 261                 $okay = 1, last if (defined $common_include{$t});
 262             }
 263             if (defined $common_include{subj}) {
 264                 if (index($status{subject}, $common_include{subj}) > -1) {
 265                     $okay = 1;
 266                 }
 267             }
 268             next unless ($okay);
 269         }
 270         if (%common_exclude) {
 271             my $okay = 1;
 272             foreach my $t (split /\s+/, $status{tags}) {
 273                 $okay = 0, last if (defined $common_exclude{$t});
 274             }
 275             if (defined $common_exclude{subj}) {
 276                 if (index($status{subject}, $common_exclude{subj}) > -1) {
 277                     $okay = 0;
 278                 }
 279             }
 280             next unless ($okay);
 281         }
 282
 283         my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
 284             bugurl($bug), $bug, htmlsanit($status{subject});
 285         $html .= htmlindexentrystatus(\%status) . "\n";
 286         $section{$status{pending} . "_" . $status{severity}} .= $html;
 287         push @rawsort, $html if $common_raw_sort;
 288     }
 289
 290     my $result = "";
 291     my $anydone = 0;
 292     if ($common_raw_sort) {
 293         $result .= "<UL>\n" . join("", @rawsort ) . "</UL>\n";
 294     } else {
 295     foreach my $pending (qw(pending forwarded pending-fixed fixed done)) {
 296         foreach my $severity(@debbugs::gSeverityList) {
 297             $severity = $debbugs::gDefaultSeverity if ($severity eq '');
 298             next unless defined $section{${pending} . "_" . ${severity}};
 299             $result .= "<HR><H2>$debbugs::gSeverityDisplay{$severity} - $displayshowpending{$pending}</H2>\n";
 300             #$result .= "(A list of <a href=\"http://${debbugs::gWebDomain}/db/si/$pending$severity\">all such bugs</a> is available).\n";
 301             $result .= "(A list of all such bugs used to be available).\n";
 302             $result .= "<UL>\n";
 303             $result .= $section{$pending . "_" . $severity};
 304             $result .= "</UL>\n";
 305             $anydone = 1 if ($pending eq "done");
 306          }
 307     }
 308
 309     }
 310     $result .= $debbugs::gHTMLExpireNote if ($anydone);
 311     return $result;
 312 }
 313
 314 sub countbugs {
 315     my $bugfunc = shift;
 316     if ($common_archive) {
 317         open I, "<$debbugs::gSpoolDir/index.archive" or &quit("bugindex: $!");
 318     } else {
 319         open I, "<$debbugs::gSpoolDir/index.db" or &quit("bugindex: $!");
 320     }
 321
 322     my %count = ();
 323     while(<I>)
 324     {
 325         if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
 326             my $x = $bugfunc->(pkg => $1, bug => $2, status => $4,
 327                                submitter => $5, severity => $6, tags => $7);
 328             $count{$x}++;
 329         }
 330     }
 331     close I;
 332     return %count;
 333 }
 334
 335 sub getbugs {
 336     my $bugfunc = shift;
 337     my $opt = shift;
 338
 339     my @result = ();
 340
 341     if (!$common_archive && defined $opt &&
 342         -e "$debbugs::gSpoolDir/by-$opt.idx")
 343     {
 344         my %lookup;
 345 print STDERR "optimized\n" if ($debug);
 346         tie %lookup, DB_File => "$debbugs::gSpoolDir/by-$opt.idx", O_RDONLY
 347             or die "$0: can't open $debbugs::gSpoolDir/by-$opt.idx ($!)\n";
 348         while ($key = shift) {
 349             my $bugs = $lookup{$key};
 350             if (defined $bugs) {
 351                 push @result, (unpack 'N*', $bugs);
 352             }
 353         }
 354         untie %lookup;
 355 print STDERR "done optimized\n" if ($debug);
 356     } else {
 357         if ( $common_archive ) {
 358             open I, "<$debbugs::gSpoolDir/index.archive"
 359                 or &quit("bugindex: $!");
 360         } else {
 361             open I, "<$debbugs::gSpoolDir/index.db"
 362                 or &quit("bugindex: $!");
 363         }
 364         while(<I>) {
 365             if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
 366                 if ($bugfunc->(pkg => $1, bug => $2, status => $4,
 367                             submitter => $5, severity => $6, tags => $7))
 368                 {
 369                     push (@result, $2);
 370                 }
 371             }
 372         }
 373         close I;
 374     }
 375     @result = sort {$a <=> $b} @result;
 376     return \@result;
 377 }
 378
 379 sub emailfromrfc822 {
 380     my $email = shift;
 381     $email =~ s/\s*\(.*\)\s*//;
 382     $email = $1 if ($email =~ m/<(.*)>/);
 383     return $email;
 384 }
 385
 386 sub maintencoded {
 387     my $input = shift;
 388     my $encoded = '';
 389
 390     while ($input =~ m/\W/) {
 391         $encoded.=$`.sprintf("-%02x_",unpack("C",$&));
 392         $input= $';
 393     }
 394
 395     $encoded.= $input;
 396     $encoded =~ s/-2e_/\./g;
 397     $encoded =~ s/^([^,]+)-20_-3c_(.*)-40_(.*)-3e_/$1,$2,$3,/;
 398     $encoded =~ s/^(.*)-40_(.*)-20_-28_([^,]+)-29_$/,$1,$2,$3/;
 399     $encoded =~ s/-20_/_/g;
 400     $encoded =~ s/-([^_]+)_-/-$1/g;
 401     return $encoded;
 402 }
 403
 404 my $_maintainer;
 405 sub getmaintainers {
 406     return $_maintainer if $_maintainer;
 407     my %maintainer;
 408
 409     open(MM,"$gMaintainerFile") or &quit("open $gMaintainerFile: $!");
 410     while(<MM>) {
 411         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 412         ($a,$b)=($1,$2);
 413         $a =~ y/A-Z/a-z/;
 414         $maintainer{$a}= $b;
 415     }
 416     close(MM);
 417     open(MM,"$gMaintainerFileOverride") or &quit("open $gMaintainerFileOverride: $!");
 418     while(<MM>) {
 419         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 420         ($a,$b)=($1,$2);
 421         $a =~ y/A-Z/a-z/;
 422         $maintainer{$a}= $b;
 423     }
 424     close(MM);
 425     $_maintainer = \%maintainer;
 426     return $_maintainer;
 427 }
 428
 429 my $_pkgsrc;
 430 sub getpkgsrc {
 431     return $_pkgsrc if $_pkgsrc;
 432     my %pkgsrc;
 433
 434     open(MM,"$gPackageSource") or &quit("open $gPackageSource: $!");
 435     while(<MM>) {
 436         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 437         ($a,$b)=($1,$2);
 438         $a =~ y/A-Z/a-z/;
 439         $pkgsrc{$a}= $b;
 440     }
 441     close(MM);
 442     $_pkgsrc = \%pkgsrc;
 443     return $_pkgsrc;
 444 }
 445
 446 sub getbugdir {
 447     my ( $bugnum, $ext ) = @_;
 448     my $archdir = sprintf "%02d", $bugnum % 100;
 449     foreach ( ( "$gSpoolDir/db-h/$archdir", "$gSpoolDir/db", "$gSpoolDir/archive/$archdir" ) ) {
 450         return $_ if ( -r "$_/$bugnum.$ext" );
 451     }
 452     return undef;
 453 }
 454
 455 sub getbugstatus {
 456     my $bugnum = shift;
 457
 458     my %status;
 459
 460     my $dir = getbugdir( $bugnum, "status" );
 461     return {} if ( !$dir );
 462     open S, "< $dir/$bugnum.status";
 463     my @lines = qw(originator date subject msgid package tags done
 464                         forwarded mergedwith severity);
 465     while(<S>) {
 466         chomp;
 467         $status{shift @lines} = $_;
 468     }
 469     close(S);
 470     $status{shift @lines} = '' while(@lines);
 471
 472     $status{"package"} =~ s/\s*$//;
 473     $status{"package"} = 'unknown' if ($status{"package"} eq '');
 474     $status{"severity"} = 'normal' if ($status{"severity"} eq '');
 475
 476     $status{"pending"} = 'pending';
 477     $status{"pending"} = 'forwarded'        if (length($status{"forwarded"}));
 478     $status{"pending"} = 'fixed'            if ($status{"tags"} =~ /\bfixed\b/);
 479     $status{"pending"} = 'pending-fixed'    if ($status{"tags"} =~ /\bpending\b/);
 480     $status{"pending"} = 'done'             if (length($status{"done"}));
 481
 482     return \%status;
 483 }
 484
 485 sub getsrcpkgs {
 486     my $src = shift;
 487
 488     my %pkgsrc = %{getpkgsrc()};
 489     my @pkgs;
 490     foreach ( keys %pkgsrc ) {
 491         push @pkgs, $_ if $pkgsrc{$_} eq $src;
 492     }
 493     return @pkgs;
 494 }
 495
 496 sub buglog {
 497     my $bugnum = shift;
 498
 499     my $dir = getbugdir( $bugnum, "log" );
 500     return "" if ( !$dir );
 501     return "$dir/$bugnum.log";
 502 }
 503
 504 1;