1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later
3 # version at your option.
4 # See the file README and COPYING for more information.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
14 Debbugs::CGI -- General routines for the cgi scripts
18 use Debbugs::CGI qw(:url :html);
20 html_escape(bug_url($ref,mbox=>'yes',mboxstatus=>'yes'));
24 This module is a replacement for parts of common.pl; subroutines in
25 common.pl will be gradually phased out and replaced with equivalent
26 (or better) functionality here.
36 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
37 use base qw(Exporter);
40 use Debbugs::Common qw(getparsedaddrs);
41 use Params::Validate qw(validate_with :types);
42 use Debbugs::Config qw(:config);
43 use Debbugs::Status qw(splitpackages);
46 use Storable qw(dclone);
52 ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
53 $DEBUG = 0 unless defined $DEBUG;
56 %EXPORT_TAGS = (url => [qw(bug_url bug_links bug_linklist maybelink),
57 qw(set_url_params pkg_url version_url),
58 qw(submitterurl mainturl)
60 html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
61 qw(maybelink htmlize_addresslinks htmlize_maintlinks),
63 util => [qw(cgi_parameters quitcgi),
66 #status => [qw(getbugstatus)],
69 Exporter::export_ok_tags(qw(url html util));
70 $EXPORT_TAGS{all} = [@EXPORT_OK];
80 Sets the url params which will be used to generate urls.
89 my $url = Debbugs::URI->new($_[0]||'');
90 %URL_PARAMS = %{$url->query_form_hash};
97 bug_url($ref,mbox=>'yes',mboxstat=>'yes');
99 Constructs urls which point to a specific
101 XXX use Params::Validate
110 %params = (%URL_PARAMS,@_);
115 my $url = Debbugs::URI->new('bugreport.cgi?');
116 $url->query_form(bug=>$ref,%params);
117 return $url->as_string;
124 %params = (%URL_PARAMS,@_);
129 my $url = Debbugs::URI->new('pkgreport.cgi?');
130 $url->query_form(%params);
131 return $url->as_string;
136 version_url($package,$found,$fixed)
138 Creates a link to the version cgi script
143 my ($package,$found,$fixed,$width,$height) = @_;
144 my $url = Debbugs::URI->new('version.cgi?');
145 $url->query_form(package => $package,
148 (defined $width)?(width => $width):(),
149 (defined $height)?(height => $height):(),
150 (defined $width or defined $height)?(collapse => 1):(),
152 return $url->as_string;
159 Escapes html entities by calling HTML::Entities::encode_entities;
166 return HTML::Entities::encode_entities($string,q(<>&"'));
169 =head2 cgi_parameters
173 Returns all of the cgi_parameters from a CGI script using CGI::Simple
178 my %options = validate_with(params => \@_,
179 spec => {query => {type => OBJECT,
182 single => {type => ARRAYREF,
185 default => {type => HASHREF,
190 my $q = $options{query};
192 @single{@{$options{single}}} = (1) x @{$options{single}};
194 for my $paramname ($q->param) {
195 if ($single{$paramname}) {
196 $param{$paramname} = $q->param($paramname);
199 $param{$paramname} = [$q->param($paramname)];
202 for my $default (keys %{$options{default}}) {
203 if (not exists $param{$default}) {
204 # We'll clone the reference here to avoid surprises later.
205 $param{$default} = ref($options{default}{$default})?
206 dclone($options{default}{$default}):$options{default}{$default};
215 print "Content-Type: text/html\n\n";
216 print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
217 print "An error occurred. Dammit.\n";
218 print "Error was: $msg.\n";
219 print "</BODY></HTML>\n";
228 htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}});
230 Turns a list of bugs into an html snippit of the bugs.
233 # htmlize_bugs(bugs=>[@bugs]);
238 for my $bug (@bugs) {
239 my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
240 bug_url($bug->{bug}), $bug->{bug}, html_escape($bug->{status}{subject});
241 $html .= htmlize_bugstatus($bug->{status}) . "\n";
247 sub htmlize_bugstatus {
248 my %status = %{$_[0]};
253 if ($status{severity} eq $config{default_severity}) {
255 } elsif (isstrongseverity($status{severity})) {
256 $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
258 $showseverity = "Severity: <em>$status{severity}</em>;\n";
261 $result .= htmlize_packagelinks($status{"package"}, 1);
263 my $showversions = '';
264 if (@{$status{found_versions}}) {
265 my @found = @{$status{found_versions}};
267 s{/}{ } foreach @found;
268 $showversions .= join ', ', map html_escape($_), @found;
270 if (@{$status{fixed_versions}}) {
271 $showversions .= '; ' if length $showversions;
272 $showversions .= '<strong>fixed</strong>: ';
273 my @fixed = @{$status{fixed_versions}};
274 $showversions .= join ', ', map {s#/##; html_escape($_)} @fixed;
276 $result .= " ($showversions)" if length $showversions;
279 $result .= $showseverity;
280 $result .= htmlize_addresslinks("Reported by: ", \&submitterurl,
281 $status{originator});
282 $result .= ";\nOwned by: " . html_escape($status{owner})
283 if length $status{owner};
284 $result .= ";\nTags: <strong>"
285 . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
287 if (length($status{tags}));
289 $result .= ";\nMerged with ".
292 split(/ /,$status{mergedwith}))
293 if length $status{mergedwith};
294 $result .= ";\nBlocked by ".
297 split(/ /,$status{blockedby}))
298 if length $status{blockedby};
299 $result .= ";\nBlocks ".
302 split(/ /,$status{blocks})
304 if length $status{blocks};
307 if (length($status{done})) {
308 $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
309 $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
311 $result .= ";\n<strong>Will be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
313 $result .= ";\n<strong>Archived</strong>";
317 if (length($status{forwarded})) {
318 $result .= ";\n<strong>Forwarded</strong> to "
319 . maybelink($status{forwarded});
321 my $daysold = int((time - $status{date}) / 86400); # seconds to days
325 $font = "em" if ($daysold > 30);
326 $font = "strong" if ($daysold > 60);
327 $efont = "</$font>" if ($font);
328 $font = "<$font>" if ($font);
330 my $yearsold = int($daysold / 365);
331 $daysold -= $yearsold * 365;
333 $result .= ";\n $font";
335 push @age, "1 year" if ($yearsold == 1);
336 push @age, "$yearsold years" if ($yearsold > 1);
337 push @age, "1 day" if ($daysold == 1);
338 push @age, "$daysold days" if ($daysold > 1);
339 $result .= join(" and ", @age);
340 $result .= " old$efont";
349 =head2 htmlize_packagelinks
353 Given a scalar containing a list of packages separated by something
354 that L<Debbugs::CGI/splitpackages> can separate, returns a
355 formatted set of links to packages.
359 sub htmlize_packagelinks {
360 my ($pkgs,$strong) = @_;
361 return unless defined $pkgs and $pkgs ne '';
362 my @pkglist = splitpackages($pkgs);
365 my $openstrong = $strong ? '<strong>' : '';
366 my $closestrong = $strong ? '</strong>' : '';
368 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
371 '<a class="submitter" href="' . pkg_url(pkg=>$_||'') . '">' .
372 $openstrong . html_escape($_) . $closestrong . '</a>'
381 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
382 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
385 In the first form, links the link if it looks like a link. In the
386 second form, first splits based on the regex, then reassembles the
387 link, linking things that look like links. In the third form, rejoins
388 the split links with commas and spaces.
393 my ($links,$regex,$join) = @_;
394 $join = ' ' if not defined $join;
397 if (defined $regex) {
398 @segments = split $regex, $links;
401 @segments = ($links);
403 for my $in (@segments) {
404 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
405 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
407 push @return, html_escape($in);
410 return @return?join($join,@return):'';
414 =head2 htmlize_addresslinks
416 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
419 Generate a comma-separated list of HTML links to each address given in
420 $addresses, which should be a comma-separated list of RFC822
421 addresses. $urlfunc should be a reference to a function like mainturl
422 or submitterurl which returns the URL for each individual address.
427 sub htmlize_addresslinks {
428 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
429 $class = defined $class?qq(class="$class" ):'';
430 if (defined $addresses and $addresses ne '') {
431 my @addrs = getparsedaddrs($addresses);
432 my $prefix = (ref $prefixfunc) ?
433 $prefixfunc->(scalar @addrs):$prefixfunc;
436 { sprintf qq(<a ${class}).
438 $urlfunc->($_->address),
439 html_escape($_->format) ||
445 my $prefix = (ref $prefixfunc) ?
446 $prefixfunc->(1) : $prefixfunc;
447 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
448 $prefix, $urlfunc->('');
453 my $addr = getparsedaddrs($_[0] || "");
454 $addr = defined $addr?$addr->address:'';
458 sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); }
459 sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); }
460 sub htmlize_maintlinks {
461 my ($prefixfunc, $maints) = @_;
462 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
467 our $_maintainer_rev;
471 return $_pseudodesc if $_pseudodesc;
474 my $pseudo = new IO::File $config{pseudo_desc_file},'r'
475 or &quitcgi("Unable to open $config{pseudo_desc_file}: $!");
477 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
478 $pseudodesc{lc $1} = $2;
481 $_pseudodesc = \%pseudodesc;
489 bug_links($starting_bug,$stoping_bugs,);
491 Creates a set of links to bugs, starting with bug number
492 $starting_bug, and finishing with $stoping_bug; if only one bug is
493 passed, makes a link to only a single bug.
495 The content of the link is the bug number.
497 XXX Use L<Params::Validate>; we want to be able to support query
503 my ($start,$stop,$query_arguments) = @_;
504 $stop = $stop || $start;
505 $query_arguments ||= '';
507 for my $bug ($start..$stop) {
508 push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
510 return join(', ',@output);
515 bug_linklist($separator,$class,@bugs)
517 Creates a set of links to C<@bugs> separated by C<$separator> with
518 link class C<$class>.
520 XXX Use L<Params::Validate>; we want to be able to support query
521 arguments here too; we should be able to combine bug_links and this
522 function into one. [Hell, bug_url should be one function with this one
529 my ($sep,$class,@bugs) = @_;
531 $class = qq(class="$class" );
533 return join($sep,map{qq(<a ${class}href=").
534 bug_url($_).qq(">#$_</a>)