]> git.donarmstrong.com Git - debbugs.git/blob - cgi/common.pl
[project @ 2003-06-06 17:56:05 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" or &quitcgi("bugindex: $!");
428     } else {
429         open I, "<$debbugs::gSpoolDir/index.db" or &quitcgi("bugindex: $!");
430     }
431
432     my %count = ();
433     while(<I>) 
434     {
435         if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
436             my @x = $bugfunc->(pkg => $1, bug => $2, status => $4, 
437                                submitter => $5, severity => $6, tags => $7);
438             local $_;
439             $count{$_}++ foreach @x;
440         }
441     }
442     close I;
443     return %count;
444 }
445
446 sub getbugs {
447     my $bugfunc = shift;
448     my $opt = shift;
449
450     my @result = ();
451
452     if (!$common_archive && defined $opt && 
453         -e "$debbugs::gSpoolDir/by-$opt.idx") 
454     {
455         my %lookup;
456 print STDERR "optimized\n" if ($debug);
457         tie %lookup, DB_File => "$debbugs::gSpoolDir/by-$opt.idx", O_RDONLY
458             or die "$0: can't open $debbugs::gSpoolDir/by-$opt.idx ($!)\n";
459         while ($key = shift) {
460             my $bugs = $lookup{$key};
461             if (defined $bugs) {
462                 push @result, (unpack 'N*', $bugs);
463             }
464         }
465         untie %lookup;
466 print STDERR "done optimized\n" if ($debug);
467     } else {
468         if ( $common_archive ) {
469             open I, "<$debbugs::gSpoolDir/index.archive" 
470                 or &quitcgi("bugindex: $!");
471         } else {
472             open I, "<$debbugs::gSpoolDir/index.db" 
473                 or &quitcgi("bugindex: $!");
474         }
475         while(<I>) {
476             if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
477                 if ($bugfunc->(pkg => $1, bug => $2, status => $4,
478                             submitter => $5, severity => $6, tags => $7)) 
479                 {
480                     push (@result, $2);
481                 }
482             }
483         }
484         close I;
485     }
486     @result = sort {$a <=> $b} @result;
487     return \@result;
488 }
489
490 sub emailfromrfc822 {
491     my $email = shift;
492     $email =~ s/\s*\(.*\)\s*//;
493     $email = $1 if ($email =~ m/<(.*)>/);
494     return $email;
495 }
496
497 sub maintencoded {
498     my $input = shift;
499     my $encoded = '';
500
501     while ($input =~ m/\W/) {
502         $encoded.=$`.sprintf("-%02x_",unpack("C",$&));
503         $input= $';
504     }
505
506     $encoded.= $input;
507     $encoded =~ s/-2e_/\./g;
508     $encoded =~ s/^([^,]+)-20_-3c_(.*)-40_(.*)-3e_/$1,$2,$3,/;
509     $encoded =~ s/^(.*)-40_(.*)-20_-28_([^,]+)-29_$/,$1,$2,$3/;
510     $encoded =~ s/-20_/_/g;
511     $encoded =~ s/-([^_]+)_-/-$1/g;
512     return $encoded;
513 }
514
515 my $_maintainer;
516 sub getmaintainers {
517     return $_maintainer if $_maintainer;
518     my %maintainer;
519
520     open(MM,"$gMaintainerFile") or &quitcgi("open $gMaintainerFile: $!");
521     while(<MM>) {
522         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
523         ($a,$b)=($1,$2);
524         $a =~ y/A-Z/a-z/;
525         $maintainer{$a}= $b;
526     }
527     close(MM);
528     open(MM,"$gMaintainerFileOverride") or &quitcgi("open $gMaintainerFileOverride: $!");
529     while(<MM>) {
530         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
531         ($a,$b)=($1,$2);
532         $a =~ y/A-Z/a-z/;
533         $maintainer{$a}= $b;
534     }
535     close(MM);
536     $_maintainer = \%maintainer;
537     return $_maintainer;
538 }
539
540 my $_pkgsrc;
541 my $_pkgcomponent;
542 sub getpkgsrc {
543     return $_pkgsrc if $_pkgsrc;
544     my %pkgsrc;
545     my %pkgcomponent;
546
547     open(MM,"$gPackageSource") or &quitcgi("open $gPackageSource: $!");
548     while(<MM>) {
549         next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
550         ($a,$b,$c)=($1,$2,$3);
551         $a =~ y/A-Z/a-z/;
552         $pkgsrc{$a}= $c;
553         $pkgcomponent{$a}= $b;
554     }
555     close(MM);
556     $_pkgsrc = \%pkgsrc;
557     $_pkgcomponent = \%pkgcomponent;
558     return $_pkgsrc;
559 }
560
561 sub getpkgcomponent {
562     return $_pkgcomponent if $_pkgcomponent;
563     getpkgsrc();
564     return $_pkgcomponent;
565 }
566
567 my $_pseudodesc;
568 sub getpseudodesc {
569     return $_pseudodesc if $_pseudodesc;
570     my %pseudodesc;
571
572     open(PSEUDO, "< $gPseudoDescFile") or &quitcgi("open $gPseudoDescFile: $!");
573     while(<PSEUDO>) {
574         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
575         $pseudodesc{lc $1} = $2;
576     }
577     close(PSEUDO);
578     $_pseudodesc = \%pseudodesc;
579     return $_pseudodesc;
580 }
581
582 sub getbugstatus {
583     my $bugnum = shift;
584
585     my %status;
586
587     my $location = getbuglocation( $bugnum, "status" );
588     return {} if ( !$location );
589     %status = %{ readbug( $bugnum, $location ) };
590
591     $status{tags} = $status{keywords};
592
593     $status{"package"} =~ s/\s*$//;
594     $status{"package"} = 'unknown' if ($status{"package"} eq '');
595     $status{"severity"} = 'normal' if ($status{"severity"} eq '');
596
597     $status{"pending"} = 'pending';
598     $status{"pending"} = 'forwarded'        if (length($status{"forwarded"}));
599     $status{"pending"} = 'pending-fixed'    if ($status{"tags"} =~ /\bpending\b/);
600     $status{"pending"} = 'fixed'            if ($status{"tags"} =~ /\bfixed\b/);
601     $status{"pending"} = 'done'             if (length($status{"done"}));
602
603     return \%status;
604 }
605
606 sub getsrcpkgs {
607     my $src = shift;
608     return () if !$src;
609     my %pkgsrc = %{getpkgsrc()};
610     my @pkgs;
611     foreach ( keys %pkgsrc ) {
612         push @pkgs, $_ if $pkgsrc{$_} eq $src;
613     }
614     return @pkgs;
615 }
616    
617 sub buglog {
618     my $bugnum = shift;
619     return getbugcomponent($bugnum, 'log');
620 }
621
622 1;