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),
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);
466 return $_pseudodesc if $_pseudodesc;
469 my $pseudo = new IO::File $config{pseudo_desc_file},'r'
470 or &quitcgi("Unable to open $config{pseudo_desc_file}: $!");
472 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
473 $pseudodesc{lc $1} = $2;
476 $_pseudodesc = \%pseudodesc;
484 bug_links($starting_bug,$stoping_bugs,);
486 Creates a set of links to bugs, starting with bug number
487 $starting_bug, and finishing with $stoping_bug; if only one bug is
488 passed, makes a link to only a single bug.
490 The content of the link is the bug number.
492 XXX Use L<Params::Validate>; we want to be able to support query
498 my ($start,$stop,$query_arguments) = @_;
499 $stop = $stop || $start;
500 $query_arguments ||= '';
502 for my $bug ($start..$stop) {
503 push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
505 return join(', ',@output);
510 bug_linklist($separator,$class,@bugs)
512 Creates a set of links to C<@bugs> separated by C<$separator> with
513 link class C<$class>.
515 XXX Use L<Params::Validate>; we want to be able to support query
516 arguments here too; we should be able to combine bug_links and this
517 function into one. [Hell, bug_url should be one function with this one
524 my ($sep,$class,@bugs) = @_;
526 $class = qq(class="$class" );
528 return join($sep,map{qq(<a ${class}href=").
529 bug_url($_).qq(">#$_</a>)