]> git.donarmstrong.com Git - debbugs.git/blob - cgi/common.pl
[project @ 2003-03-21 04:26:43 by cjwatson]
[debbugs.git] / 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 my $common_pending_reverse = 0;
13 my $common_severity_reverse = 0;
14
15 my @common_pending_include = ();
16 my @common_pending_exclude = ();
17 my @common_severity_include = ();
18 my @common_severity_exclude = ();
19
20 my $debug = 0;
21
22 sub set_option {
23     my ($opt, $val) = @_;
24     if ($opt eq "archive") { $common_archive = $val; }
25     if ($opt eq "repeatmerged") { $common_repeatmerged = $val; }
26     if ($opt eq "exclude") { %common_exclude = %{$val}; }
27     if ($opt eq "include") { %common_include = %{$val}; }
28     if ($opt eq "raw") { $common_raw_sort = $val; }
29     if ($opt eq "bug-rev") { $common_bug_reverse = $val; }
30     if ($opt eq "pend-rev") { $common_pending_reverse = $val; }
31     if ($opt eq "sev-rev") { $common_severity_reverse = $val; }
32     if ($opt eq "pend-exc") {
33         my @vals;
34         @vals = ( $val ) if (ref($val) eq "" && $val );
35         @vals = ( $$val ) if (ref($val) eq "SCALAR" && $$val );
36         @vals = @{$val} if (ref($val) eq "ARRAY" );
37         @common_pending_exclude = @vals if (@vals);
38     }
39     if ($opt eq "pend-inc") {
40         my @vals;
41         @vals = ( $val, ) if (ref($val) eq "" && $val );
42         @vals = ( $$val, ) if (ref($val) eq "SCALAR" && $$val );
43         @vals = @{$val} if (ref($val) eq "ARRAY" );
44         @common_pending_include = @vals if (@vals);
45     }
46     if ($opt eq "sev-exc") {
47         my @vals;
48         @vals = ( $val ) if (ref($val) eq "" && $val );
49         @vals = ( $$val ) if (ref($val) eq "SCALAR" && $$val );
50         @vals = @{$val} if (ref($val) eq "ARRAY" );
51         @common_severity_exclude = @vals if (@vals);
52     }
53     if ($opt eq "sev-inc") {
54         my @vals;
55         @vals = ( $val ) if (ref($val) eq "" && $val );
56         @vals = ( $$val ) if (ref($val) eq "SCALAR" && $$val );
57         @vals = @{$val} if (ref($val) eq "ARRAY" );
58         @common_severity_include = @vals if (@vals);
59     }
60 }
61
62 sub readparse {
63     my ($in, $key, $val, %ret);
64     if (defined $ENV{"QUERY_STRING"} && $ENV{"QUERY_STRING"} ne "") {
65         $in=$ENV{QUERY_STRING};
66     } elsif(defined $ENV{"REQUEST_METHOD"}
67         && $ENV{"REQUEST_METHOD"} eq "POST")
68     {
69         read(STDIN,$in,$ENV{CONTENT_LENGTH});
70     } else {
71         return;
72     }
73     foreach (split(/[&;]/,$in)) {
74         s/\+/ /g;
75         ($key, $val) = split(/=/,$_,2);
76         $key=~s/%(..)/pack("c",hex($1))/ge;
77         $val=~s/%(..)/pack("c",hex($1))/ge;
78         if ( exists $ret{$key} ) {
79             if ( !exists $ret{"&$key"} ) {
80                 $ret{"&$key"} = [ $ret{$key} ];
81             }
82             push @{$ret{"&$key"}},$val;
83         }
84         $ret{$key}=$val;
85     }
86 $debug = 1 if (defined $ret{"debug"} && $ret{"debug"} eq "aj");
87     return %ret;
88 }
89
90 sub quit {
91     my $msg = shift;
92     print "Content-Type: text/html\n\n";
93     print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
94     print "An error occurred. Dammit.\n";
95     print "Error was: $msg.\n";
96     print "</BODY></HTML>\n";
97     exit 0;
98 }
99
100 #sub abort {
101 #    my $msg = shift;
102 #    my $Archive = $common_archive ? "archive" : "";
103 #    print header . start_html("Sorry");
104 #    print "Sorry bug #$msg doesn't seem to be in the $Archive database.\n";
105 #    print end_html;
106 #    exit 0;
107 #}
108
109 # Split a package string from the status file into a list of package names.
110 sub splitpackages {
111     my $pkgs = shift;
112     return unless defined $pkgs;
113     return split /[ \t?,()]+/, $pkgs;
114 }
115
116 # Generate a comma-separated list of HTML links to each package given in
117 # $pkgs. $pkgs may be empty, in which case an empty string is returned, or
118 # it may be a comma-separated list of package names.
119 sub htmlpackagelinks {
120     my $pkgs = shift;
121     return unless defined $pkgs and $pkgs ne '';
122     my $strong = shift;
123     my @pkglist = splitpackages($pkgs);
124
125     my $openstrong  = $strong ? '<strong>' : '';
126     my $closestrong = $strong ? '</strong>' : '';
127
128     return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
129            join(', ',
130                 map {
131                     '<a href="' . pkgurl($_) . '">' .
132                     $openstrong . htmlsanit($_) . $closestrong . '</a>'
133                 } @pkglist
134            ) . ";\n";
135 }
136
137 sub htmlindexentry {
138     my $ref = shift;
139     my %status = %{getbugstatus($ref)};
140     return htmlindexentrystatus(%status) if (%status);
141     return "";
142 }
143
144 sub htmlindexentrystatus {
145     my $s = shift;
146     my %status = %{$s};
147
148     my $result = "";
149
150     if  ($status{severity} eq 'normal') {
151         $showseverity = '';
152     } elsif (grep($status{severity} eq $_, @debbugs::gStrongSeverities)) {
153         $showseverity = "<strong>Severity: $status{severity}</strong>;\n";
154     } else {
155         $showseverity = "Severity: <em>$status{severity}</em>;\n";
156     }
157
158     $result .= htmlpackagelinks($status{"package"}, 1);
159     $result .= $showseverity;
160     $result .= "Reported by: <a href=\"" . submitterurl($status{originator})
161                . "\">" . htmlsanit($status{originator}) . "</a>";
162     $result .= ";\nTags: <strong>" 
163                  . htmlsanit(join(", ", sort(split(/\s+/, $status{tags}))))
164                  . "</strong>"
165                        if (length($status{tags}));
166
167     my @merged= split(/ /,$status{mergedwith});
168     my $mseparator= ";\nmerged with ";
169     for my $m (@merged) {
170         $result .= $mseparator."<A href=\"" . bugurl($m) . "\">#$m</A>";
171         $mseparator= ", ";
172     }
173
174     if (length($status{done})) {
175         $result .= ";\n<strong>Done:</strong> " . htmlsanit($status{done});
176     } else {
177         if (length($status{forwarded})) {
178             $result .= ";\n<strong>Forwarded</strong> to "
179                        . maybelink($status{forwarded});
180         }
181         my $daysold = int((time - $status{date}) / 86400);   # seconds to days
182         if ($daysold >= 7) {
183             my $font = "";
184             my $efont = "";
185             $font = "em" if ($daysold > 30);
186             $font = "strong" if ($daysold > 60);
187             $efont = "</$font>" if ($font);
188             $font = "<$font>" if ($font);
189
190             my $yearsold = int($daysold / 364);
191             $daysold = $daysold - $yearsold * 364;
192
193             $result .= ";\n $font";
194             my @age;
195             push @age, "1 year" if ($yearsold == 1);
196             push @age, "$yearsold years" if ($yearsold > 1);
197             push @age, "1 day" if ($daysold == 1);
198             push @age, "$daysold days" if ($daysold > 1);
199             $result .= join(" and ", @age);
200             $result .= " old$efont";
201         }
202     }
203
204     $result .= ".";
205
206     return $result;
207 }
208
209 sub submitterurl {
210     my $ref = shift || "";
211     my $params = "submitter=" . emailfromrfc822($ref);
212     $params .= "&archive=yes" if ($common_archive);
213     $params .= "&repeatmerged=no" unless ($common_repeatmerged);
214     return urlsanit("pkgreport.cgi" . "?" . $params);
215 }
216
217 sub mainturl {
218     my $ref = shift || "";
219     my $params = "maint=" . emailfromrfc822($ref);
220     $params .= "&archive=yes" if ($common_archive);
221     $params .= "&repeatmerged=no" unless ($common_repeatmerged);
222     return urlsanit("pkgreport.cgi" . "?" . $params);
223 }
224
225 sub pkgurl {
226     my $ref = shift;
227     my $params = "pkg=$ref";
228     $params .= "&archive=yes" if ($common_archive);
229     $params .= "&repeatmerged=no" unless ($common_repeatmerged);
230     
231     return urlsanit("pkgreport.cgi" . "?" . "$params");
232 }
233
234 sub srcurl {
235     my $ref = shift;
236     my $params = "src=$ref";
237     $params .= "&archive=yes" if ($common_archive);
238     $params .= "&repeatmerged=no" unless ($common_repeatmerged);
239     return urlsanit("pkgreport.cgi" . "?" . "$params");
240 }
241
242 sub urlsanit {
243     my $url = shift;
244     $url =~ s/%/%25/g;
245     $url =~ s/\+/%2b/g;
246     my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
247     $url =~ s/([<>&"])/\&$saniarray{$1};/g;
248     return $url;
249 }
250
251 sub htmlsanit {
252     my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
253     my $in = shift || "";
254     $in =~ s/([<>&"])/\&$saniarray{$1};/g;
255     return $in;
256 }
257
258 sub maybelink {
259     my $in = shift;
260     if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
261         return qq{<a href="$in">} . htmlsanit($in) . '</a>';
262     } else {
263         return htmlsanit($in);
264     }
265 }
266
267 sub bugurl {
268     my $ref = shift;
269     my $params = "bug=$ref";
270     foreach my $val (@_) {
271         $params .= "\&msg=$1" if ($val =~ /^msg=([0-9]+)/);
272         $params .= "\&archive=yes" if (!$common_archive && $val =~ /^archive.*$/);
273     }
274     $params .= "&archive=yes" if ($common_archive);
275     $params .= "&repeatmerged=no" unless ($common_repeatmerged);
276
277     return urlsanit("bugreport.cgi" . "?" . "$params");
278 }
279
280 sub dlurl {
281     my $ref = shift;
282     my $params = "bug=$ref";
283     my $filename = '';
284     foreach my $val (@_) {
285         $params .= "\&$1=$2" if ($val =~ /^(msg|att)=([0-9]+)/);
286         $filename = $1 if ($val =~ /^filename=(.*)$/);
287     }
288     $params .= "&archive=yes" if ($common_archive);
289
290     return urlsanit("bugreport.cgi/$filename?$params");
291 }
292
293 sub mboxurl {
294     my $ref = shift;
295     return urlsanit("bugreport.cgi" . "?" . "bug=$ref&mbox=yes");
296 }
297
298 sub allbugs {
299     my @bugs = ();
300
301     opendir(D, "$debbugs::gSpoolDir/db") or &quit("opendir db: $!");
302     @bugs = sort {$a<=>$b} grep s/\.status$//,
303                  (grep m/^[0-9]+\.status$/,
304                  (readdir(D)));
305     closedir(D);
306
307     return @bugs;
308 }
309
310 sub htmlizebugs {
311     $b = $_[0];
312     my @bugs = @$b;
313     my @rawsort;
314
315     my %section = ();
316
317     my %displayshowpending = ("pending", "outstanding",
318                               "pending-fixed", "pending upload",
319                               "fixed", "fixed in NMU",
320                               "done", "resolved",
321                               "forwarded", "forwarded to upstream software authors");
322
323     if (@bugs == 0) {
324         return "<HR><H2>No reports found!</H2></HR>\n";
325     }
326
327     if ( $common_bug_reverse ) {
328         @bugs = sort {$b<=>$a} @bugs;
329     } else {
330         @bugs = sort {$a<=>$b} @bugs;
331     }
332     foreach my $bug (@bugs) {
333         my %status = %{getbugstatus($bug)};
334         next unless %status;
335         my @merged = sort {$a<=>$b} ($bug, split(/ /, $status{mergedwith}));
336         next unless ($common_repeatmerged || $bug == $merged[0]);
337         if (%common_include) {
338             my $okay = 0;
339             foreach my $t (split /\s+/, $status{tags}) {
340                 $okay = 1, last if (defined $common_include{$t});
341             }
342             if (defined $common_include{subj}) {
343                 if (index($status{subject}, $common_include{subj}) > -1) {
344                     $okay = 1;
345                 }
346             }
347             next unless ($okay);
348         }
349         if (%common_exclude) {
350             my $okay = 1;
351             foreach my $t (split /\s+/, $status{tags}) {
352                 $okay = 0, last if (defined $common_exclude{$t});
353             }
354             if (defined $common_exclude{subj}) {
355                 if (index($status{subject}, $common_exclude{subj}) > -1) {
356                     $okay = 0;
357                 }
358             }
359             next unless ($okay);
360         }
361         next if @common_pending_include and
362              not grep { $_ eq $status{pending} } @common_pending_include;
363         next if @common_severity_include and
364              not grep { $_ eq $status{severity} } @common_severity_include;
365         next if grep { $_ eq $status{pending} } @common_pending_exclude;
366         next if grep { $_ eq $status{severity} } @common_severity_exclude;
367
368         my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
369             bugurl($bug), $bug, htmlsanit($status{subject});
370         $html .= htmlindexentrystatus(\%status) . "\n";
371         $section{$status{pending} . "_" . $status{severity}} .= $html;
372         push @rawsort, $html if $common_raw_sort;
373     }
374
375     my $result = "";
376     my $anydone = 0;
377     if ($common_raw_sort) {
378         $result .= "<UL>\n" . join("", @rawsort ) . "</UL>\n";
379     } else {
380         my @pendingList = qw(pending forwarded pending-fixed fixed done);
381         @pendingList = reverse @pendingList if $common_pending_reverse;
382 #print STDERR join(",",@pendingList)."\n";
383 #print STDERR join(",",@common_pending_include).":$#common_pending_include\n";
384     foreach my $pending (@pendingList) {
385         my @severityList = @debbugs::gSeverityList;
386         @severityList = reverse @severityList if $common_severity_reverse;
387 #print STDERR join(",",@severityList)."\n";
388
389 #        foreach my $severity(@debbugs::gSeverityList) {
390         foreach my $severity(@severityList) {
391             $severity = $debbugs::gDefaultSeverity if ($severity eq '');
392             next unless defined $section{${pending} . "_" . ${severity}};
393             $result .= "<HR><H2>$debbugs::gSeverityDisplay{$severity} - $displayshowpending{$pending}</H2>\n";
394             #$result .= "(A list of <a href=\"http://${debbugs::gWebDomain}/db/si/$pending$severity\">all such bugs</a> is available).\n";
395             #$result .= "(A list of all such bugs used to be available).\n";
396             $result .= "<UL>\n";
397             $result .= $section{$pending . "_" . $severity}; 
398             $result .= "</UL>\n";
399             $anydone = 1 if ($pending eq "done");
400          }
401     }
402
403     }
404     $result .= $debbugs::gHTMLExpireNote if ($anydone);
405     return $result;
406 }
407
408 sub countbugs {
409     my $bugfunc = shift;
410     if ($common_archive) {
411         open I, "<$debbugs::gSpoolDir/index.archive" or &quit("bugindex: $!");
412     } else {
413         open I, "<$debbugs::gSpoolDir/index.db" or &quit("bugindex: $!");
414     }
415
416     my %count = ();
417     while(<I>) 
418     {
419         if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
420             my $x = $bugfunc->(pkg => $1, bug => $2, status => $4, 
421                                submitter => $5, severity => $6, tags => $7);
422             $count{$x}++;
423         }
424     }
425     close I;
426     return %count;
427 }
428
429 sub getbugs {
430     my $bugfunc = shift;
431     my $opt = shift;
432
433     my @result = ();
434
435     if (!$common_archive && defined $opt && 
436         -e "$debbugs::gSpoolDir/by-$opt.idx") 
437     {
438         my %lookup;
439 print STDERR "optimized\n" if ($debug);
440         tie %lookup, DB_File => "$debbugs::gSpoolDir/by-$opt.idx", O_RDONLY
441             or die "$0: can't open $debbugs::gSpoolDir/by-$opt.idx ($!)\n";
442         while ($key = shift) {
443             my $bugs = $lookup{$key};
444             if (defined $bugs) {
445                 push @result, (unpack 'N*', $bugs);
446             }
447         }
448         untie %lookup;
449 print STDERR "done optimized\n" if ($debug);
450     } else {
451         if ( $common_archive ) {
452             open I, "<$debbugs::gSpoolDir/index.archive" 
453                 or &quit("bugindex: $!");
454         } else {
455             open I, "<$debbugs::gSpoolDir/index.db" 
456                 or &quit("bugindex: $!");
457         }
458         while(<I>) {
459             if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
460                 if ($bugfunc->(pkg => $1, bug => $2, status => $4,
461                             submitter => $5, severity => $6, tags => $7)) 
462                 {
463                     push (@result, $2);
464                 }
465             }
466         }
467         close I;
468     }
469     @result = sort {$a <=> $b} @result;
470     return \@result;
471 }
472
473 sub emailfromrfc822 {
474     my $email = shift;
475     $email =~ s/\s*\(.*\)\s*//;
476     $email = $1 if ($email =~ m/<(.*)>/);
477     return $email;
478 }
479
480 sub maintencoded {
481     my $input = shift;
482     my $encoded = '';
483
484     while ($input =~ m/\W/) {
485         $encoded.=$`.sprintf("-%02x_",unpack("C",$&));
486         $input= $';
487     }
488
489     $encoded.= $input;
490     $encoded =~ s/-2e_/\./g;
491     $encoded =~ s/^([^,]+)-20_-3c_(.*)-40_(.*)-3e_/$1,$2,$3,/;
492     $encoded =~ s/^(.*)-40_(.*)-20_-28_([^,]+)-29_$/,$1,$2,$3/;
493     $encoded =~ s/-20_/_/g;
494     $encoded =~ s/-([^_]+)_-/-$1/g;
495     return $encoded;
496 }
497
498 my $_maintainer;
499 sub getmaintainers {
500     return $_maintainer if $_maintainer;
501     my %maintainer;
502
503     open(MM,"$gMaintainerFile") or &quit("open $gMaintainerFile: $!");
504     while(<MM>) {
505         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
506         ($a,$b)=($1,$2);
507         $a =~ y/A-Z/a-z/;
508         $maintainer{$a}= $b;
509     }
510     close(MM);
511     open(MM,"$gMaintainerFileOverride") or &quit("open $gMaintainerFileOverride: $!");
512     while(<MM>) {
513         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
514         ($a,$b)=($1,$2);
515         $a =~ y/A-Z/a-z/;
516         $maintainer{$a}= $b;
517     }
518     close(MM);
519     $_maintainer = \%maintainer;
520     return $_maintainer;
521 }
522
523 my $_pkgsrc;
524 my $_pkgcomponent;
525 sub getpkgsrc {
526     return $_pkgsrc if $_pkgsrc;
527     my %pkgsrc;
528     my %pkgcomponent;
529
530     open(MM,"$gPackageSource") or &quit("open $gPackageSource: $!");
531     while(<MM>) {
532         next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
533         ($a,$b,$c)=($1,$2,$3);
534         $a =~ y/A-Z/a-z/;
535         $pkgsrc{$a}= $c;
536         $pkgcomponent{$a}= $b;
537     }
538     close(MM);
539     $_pkgsrc = \%pkgsrc;
540     $_pkgcomponent = \%pkgcomponent;
541     return $_pkgsrc;
542 }
543
544 sub getpkgcomponent {
545     return $_pkgcomponent if $_pkgcomponent;
546     getpkgsrc();
547     return $_pkgcomponent;
548 }
549
550 my $_pseudodesc;
551 sub getpseudodesc {
552     return $_pseudodesc if $_pseudodesc;
553     my %pseudodesc;
554
555     open(PSEUDO, "< $gPseudoDescFile") or &quit("open $gPseudoDescFile: $!");
556     while(<PSEUDO>) {
557         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
558         $pseudodesc{lc $1} = $2;
559     }
560     close(PSEUDO);
561     $_pseudodesc = \%pseudodesc;
562     return $_pseudodesc;
563 }
564
565 sub getbugdir {
566     my ( $bugnum, $ext ) = @_;
567     my $archdir = sprintf "%02d", $bugnum % 100;
568     foreach ( ( "$gSpoolDir/db-h/$archdir", "$gSpoolDir/db", "$gSpoolDir/archive/$archdir" ) ) {
569         return $_ if ( -r "$_/$bugnum.$ext" );
570     }
571     return undef;
572 }
573     
574 sub getbugstatus {
575     my $bugnum = shift;
576
577     my %status;
578
579     my $dir = getbugdir( $bugnum, "status" );
580     return {} if ( !$dir );
581     open S, "< $dir/$bugnum.status";
582     my @lines = qw(originator date subject msgid package tags done
583                         forwarded mergedwith severity);
584     while(<S>) {
585         chomp;
586         $status{shift @lines} = $_;
587     }
588     close(S);
589     $status{shift @lines} = '' while(@lines);
590
591     $status{"package"} =~ s/\s*$//;
592     $status{"package"} = 'unknown' if ($status{"package"} eq '');
593     $status{"severity"} = 'normal' if ($status{"severity"} eq '');
594
595     $status{"pending"} = 'pending';
596     $status{"pending"} = 'forwarded'        if (length($status{"forwarded"}));
597     $status{"pending"} = 'pending-fixed'    if ($status{"tags"} =~ /\bpending\b/);
598     $status{"pending"} = 'fixed'            if ($status{"tags"} =~ /\bfixed\b/);
599     $status{"pending"} = 'done'             if (length($status{"done"}));
600
601     return \%status;
602 }
603
604 sub getsrcpkgs {
605     my $src = shift;
606     return () if !$src;
607     my %pkgsrc = %{getpkgsrc()};
608     my @pkgs;
609     foreach ( keys %pkgsrc ) {
610         push @pkgs, $_ if $pkgsrc{$_} eq $src;
611     }
612     return @pkgs;
613 }
614    
615 sub buglog {
616     my $bugnum = shift;
617
618     my $dir = getbugdir( $bugnum, "log" );
619     return "" if ( !$dir );
620     return "$dir/$bugnum.log";
621 }
622
623 1;