]> git.donarmstrong.com Git - debbugs.git/blob - cgi/common.pl
[project @ 2003-05-21 20:55:13 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
309     return urlsanit("bugreport.cgi/$filename?$params");
310 }
311
312 sub mboxurl {
313     my $ref = shift;
314     return urlsanit("bugreport.cgi" . "?" . "bug=$ref&mbox=yes");
315 }
316
317 sub allbugs {
318     my @bugs = ();
319
320     opendir(D, "$debbugs::gSpoolDir/db") or &quitcgi("opendir db: $!");
321     @bugs = sort {$a<=>$b} grep s/\.status$//,
322                  (grep m/^[0-9]+\.status$/,
323                  (readdir(D)));
324     closedir(D);
325
326     return @bugs;
327 }
328
329 sub htmlizebugs {
330     $b = $_[0];
331     my @bugs = @$b;
332     my @rawsort;
333
334     my %section = ();
335
336     my %displayshowpending = ("pending", "outstanding",
337                               "pending-fixed", "pending upload",
338                               "fixed", "fixed in NMU",
339                               "done", "resolved",
340                               "forwarded", "forwarded to upstream software authors");
341
342     if (@bugs == 0) {
343         return "<HR><H2>No reports found!</H2></HR>\n";
344     }
345
346     if ( $common_bug_reverse ) {
347         @bugs = sort {$b<=>$a} @bugs;
348     } else {
349         @bugs = sort {$a<=>$b} @bugs;
350     }
351     my %seenmerged;
352     foreach my $bug (@bugs) {
353         my %status = %{getbugstatus($bug)};
354         next unless %status;
355         if (%common_include) {
356             my $okay = 0;
357             foreach my $t (split /\s+/, $status{tags}) {
358                 $okay = 1, last if (defined $common_include{$t});
359             }
360             if (defined $common_include{subj}) {
361                 if (index($status{subject}, $common_include{subj}) > -1) {
362                     $okay = 1;
363                 }
364             }
365             next unless ($okay);
366         }
367         if (%common_exclude) {
368             my $okay = 1;
369             foreach my $t (split /\s+/, $status{tags}) {
370                 $okay = 0, last if (defined $common_exclude{$t});
371             }
372             if (defined $common_exclude{subj}) {
373                 if (index($status{subject}, $common_exclude{subj}) > -1) {
374                     $okay = 0;
375                 }
376             }
377             next unless ($okay);
378         }
379         next if @common_pending_include and
380              not grep { $_ eq $status{pending} } @common_pending_include;
381         next if @common_severity_include and
382              not grep { $_ eq $status{severity} } @common_severity_include;
383         next if grep { $_ eq $status{pending} } @common_pending_exclude;
384         next if grep { $_ eq $status{severity} } @common_severity_exclude;
385
386         my @merged = sort {$a<=>$b} ($bug, split(/ /, $status{mergedwith}));
387         next unless ($common_repeatmerged || !$seenmerged{$merged[0]});
388         $seenmerged{$merged[0]} = 1;
389
390         my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
391             bugurl($bug), $bug, htmlsanit($status{subject});
392         $html .= htmlindexentrystatus(\%status) . "\n";
393         $section{$status{pending} . "_" . $status{severity}} .= $html;
394         push @rawsort, $html if $common_raw_sort;
395     }
396
397     my $result = "";
398     my $anydone = 0;
399     if ($common_raw_sort) {
400         $result .= "<UL>\n" . join("", @rawsort ) . "</UL>\n";
401     } else {
402         my @pendingList = qw(pending forwarded pending-fixed fixed done);
403         @pendingList = reverse @pendingList if $common_pending_reverse;
404 #print STDERR join(",",@pendingList)."\n";
405 #print STDERR join(",",@common_pending_include).":$#common_pending_include\n";
406     foreach my $pending (@pendingList) {
407         my @severityList = @debbugs::gSeverityList;
408         @severityList = reverse @severityList if $common_severity_reverse;
409 #print STDERR join(",",@severityList)."\n";
410
411 #        foreach my $severity(@debbugs::gSeverityList) {
412         foreach my $severity(@severityList) {
413             $severity = $debbugs::gDefaultSeverity if ($severity eq '');
414             next unless defined $section{${pending} . "_" . ${severity}};
415             $result .= "<HR><H2>$debbugs::gSeverityDisplay{$severity} - $displayshowpending{$pending}</H2>\n";
416             #$result .= "(A list of <a href=\"http://${debbugs::gWebDomain}/db/si/$pending$severity\">all such bugs</a> is available).\n";
417             #$result .= "(A list of all such bugs used to be available).\n";
418             $result .= "<UL>\n";
419             $result .= $section{$pending . "_" . $severity}; 
420             $result .= "</UL>\n";
421             $anydone = 1 if ($pending eq "done");
422          }
423     }
424
425     }
426     $result .= $debbugs::gHTMLExpireNote if ($anydone);
427     return $result;
428 }
429
430 sub countbugs {
431     my $bugfunc = shift;
432     if ($common_archive) {
433         open I, "<$debbugs::gSpoolDir/index.archive" or &quitcgi("bugindex: $!");
434     } else {
435         open I, "<$debbugs::gSpoolDir/index.db" or &quitcgi("bugindex: $!");
436     }
437
438     my %count = ();
439     while(<I>) 
440     {
441         if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
442             my @x = $bugfunc->(pkg => $1, bug => $2, status => $4, 
443                                submitter => $5, severity => $6, tags => $7);
444             local $_;
445             $count{$_}++ foreach @x;
446         }
447     }
448     close I;
449     return %count;
450 }
451
452 sub getbugs {
453     my $bugfunc = shift;
454     my $opt = shift;
455
456     my @result = ();
457
458     if (!$common_archive && defined $opt && 
459         -e "$debbugs::gSpoolDir/by-$opt.idx") 
460     {
461         my %lookup;
462 print STDERR "optimized\n" if ($debug);
463         tie %lookup, DB_File => "$debbugs::gSpoolDir/by-$opt.idx", O_RDONLY
464             or die "$0: can't open $debbugs::gSpoolDir/by-$opt.idx ($!)\n";
465         while ($key = shift) {
466             my $bugs = $lookup{$key};
467             if (defined $bugs) {
468                 push @result, (unpack 'N*', $bugs);
469             }
470         }
471         untie %lookup;
472 print STDERR "done optimized\n" if ($debug);
473     } else {
474         if ( $common_archive ) {
475             open I, "<$debbugs::gSpoolDir/index.archive" 
476                 or &quitcgi("bugindex: $!");
477         } else {
478             open I, "<$debbugs::gSpoolDir/index.db" 
479                 or &quitcgi("bugindex: $!");
480         }
481         while(<I>) {
482             if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
483                 if ($bugfunc->(pkg => $1, bug => $2, status => $4,
484                             submitter => $5, severity => $6, tags => $7)) 
485                 {
486                     push (@result, $2);
487                 }
488             }
489         }
490         close I;
491     }
492     @result = sort {$a <=> $b} @result;
493     return \@result;
494 }
495
496 sub emailfromrfc822 {
497     my $email = shift;
498     $email =~ s/\s*\(.*\)\s*//;
499     $email = $1 if ($email =~ m/<(.*)>/);
500     return $email;
501 }
502
503 sub maintencoded {
504     my $input = shift;
505     my $encoded = '';
506
507     while ($input =~ m/\W/) {
508         $encoded.=$`.sprintf("-%02x_",unpack("C",$&));
509         $input= $';
510     }
511
512     $encoded.= $input;
513     $encoded =~ s/-2e_/\./g;
514     $encoded =~ s/^([^,]+)-20_-3c_(.*)-40_(.*)-3e_/$1,$2,$3,/;
515     $encoded =~ s/^(.*)-40_(.*)-20_-28_([^,]+)-29_$/,$1,$2,$3/;
516     $encoded =~ s/-20_/_/g;
517     $encoded =~ s/-([^_]+)_-/-$1/g;
518     return $encoded;
519 }
520
521 my $_maintainer;
522 sub getmaintainers {
523     return $_maintainer if $_maintainer;
524     my %maintainer;
525
526     open(MM,"$gMaintainerFile") or &quitcgi("open $gMaintainerFile: $!");
527     while(<MM>) {
528         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
529         ($a,$b)=($1,$2);
530         $a =~ y/A-Z/a-z/;
531         $maintainer{$a}= $b;
532     }
533     close(MM);
534     open(MM,"$gMaintainerFileOverride") or &quitcgi("open $gMaintainerFileOverride: $!");
535     while(<MM>) {
536         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
537         ($a,$b)=($1,$2);
538         $a =~ y/A-Z/a-z/;
539         $maintainer{$a}= $b;
540     }
541     close(MM);
542     $_maintainer = \%maintainer;
543     return $_maintainer;
544 }
545
546 my $_pkgsrc;
547 my $_pkgcomponent;
548 sub getpkgsrc {
549     return $_pkgsrc if $_pkgsrc;
550     my %pkgsrc;
551     my %pkgcomponent;
552
553     open(MM,"$gPackageSource") or &quitcgi("open $gPackageSource: $!");
554     while(<MM>) {
555         next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
556         ($a,$b,$c)=($1,$2,$3);
557         $a =~ y/A-Z/a-z/;
558         $pkgsrc{$a}= $c;
559         $pkgcomponent{$a}= $b;
560     }
561     close(MM);
562     $_pkgsrc = \%pkgsrc;
563     $_pkgcomponent = \%pkgcomponent;
564     return $_pkgsrc;
565 }
566
567 sub getpkgcomponent {
568     return $_pkgcomponent if $_pkgcomponent;
569     getpkgsrc();
570     return $_pkgcomponent;
571 }
572
573 my $_pseudodesc;
574 sub getpseudodesc {
575     return $_pseudodesc if $_pseudodesc;
576     my %pseudodesc;
577
578     open(PSEUDO, "< $gPseudoDescFile") or &quitcgi("open $gPseudoDescFile: $!");
579     while(<PSEUDO>) {
580         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
581         $pseudodesc{lc $1} = $2;
582     }
583     close(PSEUDO);
584     $_pseudodesc = \%pseudodesc;
585     return $_pseudodesc;
586 }
587
588 sub getbugstatus {
589     my $bugnum = shift;
590
591     my %status;
592
593     my $location = getbuglocation( $bugnum, "status" );
594     return {} if ( !$location );
595     %status = %{ readbug( $bugnum, $location ) };
596
597     $status{tags} = $status{keywords};
598
599     $status{"package"} =~ s/\s*$//;
600     $status{"package"} = 'unknown' if ($status{"package"} eq '');
601     $status{"severity"} = 'normal' if ($status{"severity"} eq '');
602
603     $status{"pending"} = 'pending';
604     $status{"pending"} = 'forwarded'        if (length($status{"forwarded"}));
605     $status{"pending"} = 'pending-fixed'    if ($status{"tags"} =~ /\bpending\b/);
606     $status{"pending"} = 'fixed'            if ($status{"tags"} =~ /\bfixed\b/);
607     $status{"pending"} = 'done'             if (length($status{"done"}));
608
609     return \%status;
610 }
611
612 sub getsrcpkgs {
613     my $src = shift;
614     return () if !$src;
615     my %pkgsrc = %{getpkgsrc()};
616     my @pkgs;
617     foreach ( keys %pkgsrc ) {
618         push @pkgs, $_ if $pkgsrc{$_} eq $src;
619     }
620     return @pkgs;
621 }
622    
623 sub buglog {
624     my $bugnum = shift;
625
626     my $dir = getlocationpath( getbuglocation( $bugnum, "log" ) );
627     my $hash = get_hashname( $bugnum );
628     return "" if ( !$dir );
629     return "$dir/$hash/$bugnum.log";
630 }
631
632 1;