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