6 Debbugs::CGI -- General routines for the cgi scripts
10 use Debbugs::CGI qw(:url :html);
12 html_escape(bug_url($ref,mbox=>'yes',mboxstatus=>'yes'));
16 This module is a replacement for parts of common.pl; subroutines in
17 common.pl will be gradually phased out and replaced with equivalent
18 (or better) functionality here.
28 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
29 use base qw(Exporter);
32 use Debbugs::Common qw(getparsedaddrs);
33 use Params::Validate qw(validate_with :types);
34 use Debbugs::Config qw(:config);
35 use Debbugs::Status qw(splitpackages);
38 use Storable qw(dclone);
44 ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
45 $DEBUG = 0 unless defined $DEBUG;
48 %EXPORT_TAGS = (url => [qw(bug_url bug_links bug_linklist maybelink),
49 qw(set_url_params pkg_url version_url),
50 qw(submitterurl mainturl)
52 html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
53 qw(maybelink htmlize_addresslinks htmlize_maintlinks),
55 util => [qw(cgi_parameters quitcgi),
56 qw(getmaintainers getpseudodesc)
58 #status => [qw(getbugstatus)],
61 Exporter::export_ok_tags(qw(url html util));
62 $EXPORT_TAGS{all} = [@EXPORT_OK];
72 Sets the url params which will be used to generate urls.
81 my $url = Debbugs::URI->new($_[0]||'');
82 %URL_PARAMS = %{$url->query_form_hash};
89 bug_url($ref,mbox=>'yes',mboxstat=>'yes');
91 Constructs urls which point to a specific
93 XXX use Params::Validate
102 %params = (%URL_PARAMS,@_);
107 my $url = Debbugs::URI->new('bugreport.cgi?');
108 $url->query_form(bug=>$ref,%params);
109 return $url->as_string;
116 %params = (%URL_PARAMS,@_);
121 my $url = Debbugs::URI->new('pkgreport.cgi?');
122 $url->query_form(%params);
123 return $url->as_string;
128 version_url($package,$found,$fixed)
130 Creates a link to the version cgi script
135 my ($package,$found,$fixed,$width,$height) = @_;
136 my $url = Debbugs::URI->new('version.cgi?');
137 $url->query_form(package => $package,
140 (defined $width)?(width => $width):(),
141 (defined $height)?(height => $height):()
143 return $url->as_string;
150 Escapes html entities by calling HTML::Entities::encode_entities;
157 return HTML::Entities::encode_entities($string)
160 =head2 cgi_parameters
164 Returns all of the cgi_parameters from a CGI script using CGI::Simple
169 my %options = validate_with(params => \@_,
170 spec => {query => {type => OBJECT,
173 single => {type => ARRAYREF,
176 default => {type => HASHREF,
181 my $q = $options{query};
183 @single{@{$options{single}}} = (1) x @{$options{single}};
185 for my $paramname ($q->param) {
186 if ($single{$paramname}) {
187 $param{$paramname} = $q->param($paramname);
190 $param{$paramname} = [$q->param($paramname)];
193 for my $default (keys %{$options{default}}) {
194 if (not exists $param{$default}) {
195 # We'll clone the reference here to avoid surprises later.
196 $param{$default} = ref($options{default}{$default})?
197 dclone($options{default}{$default}):$options{default}{$default};
206 print "Content-Type: text/html\n\n";
207 print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
208 print "An error occurred. Dammit.\n";
209 print "Error was: $msg.\n";
210 print "</BODY></HTML>\n";
215 my %common_bugusertags;
223 htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}});
225 Turns a list of bugs into an html snippit of the bugs.
228 # htmlize_bugs(bugs=>[@bugs]);
233 for my $bug (@bugs) {
234 my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
235 bug_url($bug->{bug}), $bug->{bug}, html_escape($bug->{status}{subject});
236 $html .= htmlize_bugstatus($bug->{status}) . "\n";
242 sub htmlize_bugstatus {
243 my %status = %{$_[0]};
248 if ($status{severity} eq $config{default_severity}) {
250 } elsif (isstrongseverity($status{severity})) {
251 $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
253 $showseverity = "Severity: <em>$status{severity}</em>;\n";
256 $result .= htmlize_packagelinks($status{"package"}, 1);
258 my $showversions = '';
259 if (@{$status{found_versions}}) {
260 my @found = @{$status{found_versions}};
262 s{/}{ } foreach @found;
263 $showversions .= join ', ', map html_escape($_), @found;
265 if (@{$status{fixed_versions}}) {
266 $showversions .= '; ' if length $showversions;
267 $showversions .= '<strong>fixed</strong>: ';
268 my @fixed = @{$status{fixed_versions}};
269 $showversions .= join ', ', map {s#/##; html_escape($_)} @fixed;
271 $result .= " ($showversions)" if length $showversions;
274 $result .= $showseverity;
275 $result .= htmlize_addresslinks("Reported by: ", \&submitterurl,
276 $status{originator});
277 $result .= ";\nOwned by: " . html_escape($status{owner})
278 if length $status{owner};
279 $result .= ";\nTags: <strong>"
280 . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
282 if (length($status{tags}));
284 $result .= ";\nMerged with ".
287 split(/ /,$status{mergedwith}))
288 if length $status{mergedwith};
289 $result .= ";\nBlocked by ".
292 split(/ /,$status{blockedby}))
293 if length $status{blockedby};
294 $result .= ";\nBlocks ".
297 split(/ /,$status{blocks})
299 if length $status{blocks};
302 if (length($status{done})) {
303 $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
304 $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
306 $result .= ";\n<strong>Will be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
308 $result .= ";\n<strong>Archived</strong>";
312 if (length($status{forwarded})) {
313 $result .= ";\n<strong>Forwarded</strong> to "
314 . maybelink($status{forwarded});
316 my $daysold = int((time - $status{date}) / 86400); # seconds to days
320 $font = "em" if ($daysold > 30);
321 $font = "strong" if ($daysold > 60);
322 $efont = "</$font>" if ($font);
323 $font = "<$font>" if ($font);
325 my $yearsold = int($daysold / 365);
326 $daysold -= $yearsold * 365;
328 $result .= ";\n $font";
330 push @age, "1 year" if ($yearsold == 1);
331 push @age, "$yearsold years" if ($yearsold > 1);
332 push @age, "1 day" if ($daysold == 1);
333 push @age, "$daysold days" if ($daysold > 1);
334 $result .= join(" and ", @age);
335 $result .= " old$efont";
344 =head2 htmlize_packagelinks
348 Given a scalar containing a list of packages separated by something
349 that L<Debbugs::CGI/splitpackages> can separate, returns a
350 formatted set of links to packages.
354 sub htmlize_packagelinks {
355 my ($pkgs,$strong) = @_;
356 return unless defined $pkgs and $pkgs ne '';
357 my @pkglist = splitpackages($pkgs);
360 my $openstrong = $strong ? '<strong>' : '';
361 my $closestrong = $strong ? '</strong>' : '';
363 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
366 '<a class="submitter" href="' . pkg_url(pkg=>$_||'') . '">' .
367 $openstrong . html_escape($_) . $closestrong . '</a>'
376 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
377 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
380 In the first form, links the link if it looks like a link. In the
381 second form, first splits based on the regex, then reassembles the
382 link, linking things that look like links. In the third form, rejoins
383 the split links with commas and spaces.
388 my ($links,$regex,$join) = @_;
389 $join = ' ' if not defined $join;
392 if (defined $regex) {
393 @segments = split $regex, $links;
396 @segments = ($links);
398 for my $in (@segments) {
399 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
400 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
402 push @return, html_escape($in);
405 return @return?join($join,@return):'';
409 =head2 htmlize_addresslinks
411 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
414 Generate a comma-separated list of HTML links to each address given in
415 $addresses, which should be a comma-separated list of RFC822
416 addresses. $urlfunc should be a reference to a function like mainturl
417 or submitterurl which returns the URL for each individual address.
422 sub htmlize_addresslinks {
423 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
424 $class = defined $class?qq(class="$class" ):'';
425 if (defined $addresses and $addresses ne '') {
426 my @addrs = getparsedaddrs($addresses);
427 my $prefix = (ref $prefixfunc) ?
428 $prefixfunc->(scalar @addrs):$prefixfunc;
431 { sprintf qq(<a ${class}).
433 $urlfunc->($_->address),
434 html_escape($_->format) ||
440 my $prefix = (ref $prefixfunc) ?
441 $prefixfunc->(1) : $prefixfunc;
442 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
443 $prefix, $urlfunc->('');
448 my $addr = getparsedaddrs($_[0] || "");
449 $addr = defined $addr?$addr->address:'';
453 sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); }
454 sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); }
455 sub htmlize_maintlinks {
456 my ($prefixfunc, $maints) = @_;
457 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
464 return $_maintainer if $_maintainer;
467 for my $file (@config{qw(maintainer_file maintainer_file_override)}) {
468 next unless defined $file;
469 my $maintfile = new IO::File $file,'r' or
470 &quitcgi("Unable to open $file: $!");
471 while(<$maintfile>) {
472 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
476 for my $maint (map {lc($_->address)} getparsedaddrs($b)) {
477 push @{$maintainer_rev{$maint}},$a;
482 $_maintainer = \%maintainer;
483 $_maintainer_rev = \%maintainer_rev;
486 sub getmaintainers_reverse{
487 return $_maintainer_rev if $_maintainer_rev;
489 return $_maintainer_rev;
495 return $_pseudodesc if $_pseudodesc;
498 my $pseudo = new IO::File $config{pseudo_desc_file},'r'
499 or &quitcgi("Unable to open $config{pseudo_desc_file}: $!");
501 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
502 $pseudodesc{lc $1} = $2;
505 $_pseudodesc = \%pseudodesc;
513 bug_links($starting_bug,$stoping_bugs,);
515 Creates a set of links to bugs, starting with bug number
516 $starting_bug, and finishing with $stoping_bug; if only one bug is
517 passed, makes a link to only a single bug.
519 The content of the link is the bug number.
521 XXX Use L<Params::Validate>; we want to be able to support query
527 my ($start,$stop,$query_arguments) = @_;
528 $stop = $stop || $start;
529 $query_arguments ||= '';
531 for my $bug ($start..$stop) {
532 push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
534 return join(', ',@output);
539 bug_linklist($separator,$class,@bugs)
541 Creates a set of links to C<@bugs> separated by C<$separator> with
542 link class C<$class>.
544 XXX Use L<Params::Validate>; we want to be able to support query
545 arguments here too; we should be able to combine bug_links and this
546 function into one. [Hell, bug_url should be one function with this one
553 my ($sep,$class,@bugs) = @_;
555 $class = qq(class="$class" );
557 return join($sep,map{qq(<a ${class}href=").
558 bug_url($_).qq(">#$_</a>)