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 munge_url)
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 return munge_url('bugreport.cgi?',%params,bug=>$ref);
122 %params = (%URL_PARAMS,@_);
127 return munge_url('pkgreport.cgi?',%params);
132 my $url = munge_url($url,%params_to_munge);
134 Munges a url, replacing parameters with %params_to_munge as appropriate.
141 my $new_url = Debbugs::URI->new($url);
142 %params = ($new_url->query_form(),%params);
143 $new_url->query_form(%params);
144 return $new_url->as_string;
150 version_url($package,$found,$fixed)
152 Creates a link to the version cgi script
157 my ($package,$found,$fixed,$width,$height) = @_;
158 my $url = Debbugs::URI->new('version.cgi?');
159 $url->query_form(package => $package,
162 (defined $width)?(width => $width):(),
163 (defined $height)?(height => $height):(),
164 (defined $width or defined $height)?(collapse => 1):(info => 1),
166 return $url->as_string;
173 Escapes html entities by calling HTML::Entities::encode_entities;
180 return HTML::Entities::encode_entities($string,q(<>&"'));
183 =head2 cgi_parameters
187 Returns all of the cgi_parameters from a CGI script using CGI::Simple
192 my %options = validate_with(params => \@_,
193 spec => {query => {type => OBJECT,
196 single => {type => ARRAYREF,
199 default => {type => HASHREF,
204 my $q = $options{query};
206 @single{@{$options{single}}} = (1) x @{$options{single}};
208 for my $paramname ($q->param) {
209 if ($single{$paramname}) {
210 $param{$paramname} = $q->param($paramname);
213 $param{$paramname} = [$q->param($paramname)];
216 for my $default (keys %{$options{default}}) {
217 if (not exists $param{$default}) {
218 # We'll clone the reference here to avoid surprises later.
219 $param{$default} = ref($options{default}{$default})?
220 dclone($options{default}{$default}):$options{default}{$default};
229 print "Content-Type: text/html\n\n";
230 print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
231 print "An error occurred. Dammit.\n";
232 print "Error was: $msg.\n";
233 print "</BODY></HTML>\n";
242 htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}});
244 Turns a list of bugs into an html snippit of the bugs.
247 # htmlize_bugs(bugs=>[@bugs]);
252 for my $bug (@bugs) {
253 my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
254 bug_url($bug->{bug}), $bug->{bug}, html_escape($bug->{status}{subject});
255 $html .= htmlize_bugstatus($bug->{status}) . "\n";
261 sub htmlize_bugstatus {
262 my %status = %{$_[0]};
267 if ($status{severity} eq $config{default_severity}) {
269 } elsif (isstrongseverity($status{severity})) {
270 $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
272 $showseverity = "Severity: <em>$status{severity}</em>;\n";
275 $result .= htmlize_packagelinks($status{"package"}, 1);
277 my $showversions = '';
278 if (@{$status{found_versions}}) {
279 my @found = @{$status{found_versions}};
281 s{/}{ } foreach @found;
282 $showversions .= join ', ', map html_escape($_), @found;
284 if (@{$status{fixed_versions}}) {
285 $showversions .= '; ' if length $showversions;
286 $showversions .= '<strong>fixed</strong>: ';
287 my @fixed = @{$status{fixed_versions}};
288 $showversions .= join ', ', map {s#/##; html_escape($_)} @fixed;
290 $result .= " ($showversions)" if length $showversions;
293 $result .= $showseverity;
294 $result .= htmlize_addresslinks("Reported by: ", \&submitterurl,
295 $status{originator});
296 $result .= ";\nOwned by: " . html_escape($status{owner})
297 if length $status{owner};
298 $result .= ";\nTags: <strong>"
299 . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
301 if (length($status{tags}));
303 $result .= ";\nMerged with ".
306 split(/ /,$status{mergedwith}))
307 if length $status{mergedwith};
308 $result .= ";\nBlocked by ".
311 split(/ /,$status{blockedby}))
312 if length $status{blockedby};
313 $result .= ";\nBlocks ".
316 split(/ /,$status{blocks})
318 if length $status{blocks};
321 if (length($status{done})) {
322 $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
323 $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
325 $result .= ";\n<strong>Will be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
327 $result .= ";\n<strong>Archived</strong>";
331 if (length($status{forwarded})) {
332 $result .= ";\n<strong>Forwarded</strong> to "
333 . maybelink($status{forwarded});
335 my $daysold = int((time - $status{date}) / 86400); # seconds to days
339 $font = "em" if ($daysold > 30);
340 $font = "strong" if ($daysold > 60);
341 $efont = "</$font>" if ($font);
342 $font = "<$font>" if ($font);
344 my $yearsold = int($daysold / 365);
345 $daysold -= $yearsold * 365;
347 $result .= ";\n $font";
349 push @age, "1 year" if ($yearsold == 1);
350 push @age, "$yearsold years" if ($yearsold > 1);
351 push @age, "1 day" if ($daysold == 1);
352 push @age, "$daysold days" if ($daysold > 1);
353 $result .= join(" and ", @age);
354 $result .= " old$efont";
363 =head2 htmlize_packagelinks
367 Given a scalar containing a list of packages separated by something
368 that L<Debbugs::CGI/splitpackages> can separate, returns a
369 formatted set of links to packages.
373 sub htmlize_packagelinks {
374 my ($pkgs,$strong) = @_;
375 return unless defined $pkgs and $pkgs ne '';
376 my @pkglist = splitpackages($pkgs);
379 my $openstrong = $strong ? '<strong>' : '';
380 my $closestrong = $strong ? '</strong>' : '';
382 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
385 '<a class="submitter" href="' . pkg_url(pkg=>$_||'') . '">' .
386 $openstrong . html_escape($_) . $closestrong . '</a>'
395 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
396 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
399 In the first form, links the link if it looks like a link. In the
400 second form, first splits based on the regex, then reassembles the
401 link, linking things that look like links. In the third form, rejoins
402 the split links with commas and spaces.
407 my ($links,$regex,$join) = @_;
408 $join = ' ' if not defined $join;
411 if (defined $regex) {
412 @segments = split $regex, $links;
415 @segments = ($links);
417 for my $in (@segments) {
418 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
419 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
421 push @return, html_escape($in);
424 return @return?join($join,@return):'';
428 =head2 htmlize_addresslinks
430 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
433 Generate a comma-separated list of HTML links to each address given in
434 $addresses, which should be a comma-separated list of RFC822
435 addresses. $urlfunc should be a reference to a function like mainturl
436 or submitterurl which returns the URL for each individual address.
441 sub htmlize_addresslinks {
442 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
443 $class = defined $class?qq(class="$class" ):'';
444 if (defined $addresses and $addresses ne '') {
445 my @addrs = getparsedaddrs($addresses);
446 my $prefix = (ref $prefixfunc) ?
447 $prefixfunc->(scalar @addrs):$prefixfunc;
450 { sprintf qq(<a ${class}).
452 $urlfunc->($_->address),
453 html_escape($_->format) ||
459 my $prefix = (ref $prefixfunc) ?
460 $prefixfunc->(1) : $prefixfunc;
461 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
462 $prefix, $urlfunc->('');
467 my $addr = getparsedaddrs($_[0] || "");
468 $addr = defined $addr?$addr->address:'';
472 sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); }
473 sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); }
474 sub htmlize_maintlinks {
475 my ($prefixfunc, $maints) = @_;
476 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
481 our $_maintainer_rev;
485 return $_pseudodesc if $_pseudodesc;
488 my $pseudo = new IO::File $config{pseudo_desc_file},'r'
489 or &quitcgi("Unable to open $config{pseudo_desc_file}: $!");
491 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
492 $pseudodesc{lc $1} = $2;
495 $_pseudodesc = \%pseudodesc;
503 bug_links($starting_bug,$stoping_bugs,);
505 Creates a set of links to bugs, starting with bug number
506 $starting_bug, and finishing with $stoping_bug; if only one bug is
507 passed, makes a link to only a single bug.
509 The content of the link is the bug number.
511 XXX Use L<Params::Validate>; we want to be able to support query
517 my ($start,$stop,$query_arguments) = @_;
518 $stop = $stop || $start;
519 $query_arguments ||= '';
521 for my $bug ($start..$stop) {
522 push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
524 return join(', ',@output);
529 bug_linklist($separator,$class,@bugs)
531 Creates a set of links to C<@bugs> separated by C<$separator> with
532 link class C<$class>.
534 XXX Use L<Params::Validate>; we want to be able to support query
535 arguments here too; we should be able to combine bug_links and this
536 function into one. [Hell, bug_url should be one function with this one
543 my ($sep,$class,@bugs) = @_;
545 $class = qq(class="$class" );
547 return join($sep,map{qq(<a ${class}href=").
548 bug_url($_).qq(">#$_</a>)