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 isstrongseverity);
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),
65 misc => [qw(maint_decode)],
66 #status => [qw(getbugstatus)],
69 Exporter::export_ok_tags(qw(url html util misc));
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 my @old_param = $new_url->query_form();
144 while (my ($key,$value) = splice @old_param,0,2) {
145 push @new_param,($key,$value) unless exists $params{$key};
147 $new_url->query_form(@new_param,%params);
148 return $new_url->as_string;
154 version_url($package,$found,$fixed)
156 Creates a link to the version cgi script
161 my ($package,$found,$fixed,$width,$height) = @_;
162 my $url = Debbugs::URI->new('version.cgi?');
163 $url->query_form(package => $package,
166 (defined $width)?(width => $width):(),
167 (defined $height)?(height => $height):(),
168 (defined $width or defined $height)?(collapse => 1):(info => 1),
170 return $url->as_string;
177 Escapes html entities by calling HTML::Entities::encode_entities;
184 return HTML::Entities::encode_entities($string,q(<>&"'));
187 =head2 cgi_parameters
191 Returns all of the cgi_parameters from a CGI script using CGI::Simple
196 my %options = validate_with(params => \@_,
197 spec => {query => {type => OBJECT,
200 single => {type => ARRAYREF,
203 default => {type => HASHREF,
208 my $q = $options{query};
210 @single{@{$options{single}}} = (1) x @{$options{single}};
212 for my $paramname ($q->param) {
213 if ($single{$paramname}) {
214 $param{$paramname} = $q->param($paramname);
217 $param{$paramname} = [$q->param($paramname)];
220 for my $default (keys %{$options{default}}) {
221 if (not exists $param{$default}) {
222 # We'll clone the reference here to avoid surprises later.
223 $param{$default} = ref($options{default}{$default})?
224 dclone($options{default}{$default}):$options{default}{$default};
233 print "Content-Type: text/html\n\n";
234 print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
235 print "An error occurred. Dammit.\n";
236 print "Error was: $msg.\n";
237 print "</BODY></HTML>\n";
246 htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}});
248 Turns a list of bugs into an html snippit of the bugs.
251 # htmlize_bugs(bugs=>[@bugs]);
256 for my $bug (@bugs) {
257 my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
258 bug_url($bug->{bug}), $bug->{bug}, html_escape($bug->{status}{subject});
259 $html .= htmlize_bugstatus($bug->{status}) . "\n";
265 sub htmlize_bugstatus {
266 my %status = %{$_[0]};
271 if ($status{severity} eq $config{default_severity}) {
273 } elsif (isstrongseverity($status{severity})) {
274 $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
276 $showseverity = "Severity: <em>$status{severity}</em>;\n";
279 $result .= htmlize_packagelinks($status{"package"}, 1);
281 my $showversions = '';
282 if (@{$status{found_versions}}) {
283 my @found = @{$status{found_versions}};
285 s{/}{ } foreach @found;
286 $showversions .= join ', ', map html_escape($_), @found;
288 if (@{$status{fixed_versions}}) {
289 $showversions .= '; ' if length $showversions;
290 $showversions .= '<strong>fixed</strong>: ';
291 my @fixed = @{$status{fixed_versions}};
292 $showversions .= join ', ', map {s#/##; html_escape($_)} @fixed;
294 $result .= " ($showversions)" if length $showversions;
297 $result .= $showseverity;
298 $result .= htmlize_addresslinks("Reported by: ", \&submitterurl,
299 $status{originator});
300 $result .= ";\nOwned by: " . html_escape($status{owner})
301 if length $status{owner};
302 $result .= ";\nTags: <strong>"
303 . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
305 if (length($status{tags}));
307 $result .= ";\nMerged with ".
310 split(/ /,$status{mergedwith}))
311 if length $status{mergedwith};
312 $result .= ";\nBlocked by ".
315 split(/ /,$status{blockedby}))
316 if length $status{blockedby};
317 $result .= ";\nBlocks ".
320 split(/ /,$status{blocks})
322 if length $status{blocks};
325 if (length($status{done})) {
326 $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
327 $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
329 $result .= ";\n<strong>Will be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
331 $result .= ";\n<strong>Archived</strong>";
335 if (length($status{forwarded})) {
336 $result .= ";\n<strong>Forwarded</strong> to "
337 . maybelink($status{forwarded});
339 my $daysold = int((time - $status{date}) / 86400); # seconds to days
343 $font = "em" if ($daysold > 30);
344 $font = "strong" if ($daysold > 60);
345 $efont = "</$font>" if ($font);
346 $font = "<$font>" if ($font);
348 my $yearsold = int($daysold / 365);
349 $daysold -= $yearsold * 365;
351 $result .= ";\n $font";
353 push @age, "1 year" if ($yearsold == 1);
354 push @age, "$yearsold years" if ($yearsold > 1);
355 push @age, "1 day" if ($daysold == 1);
356 push @age, "$daysold days" if ($daysold > 1);
357 $result .= join(" and ", @age);
358 $result .= " old$efont";
367 =head2 htmlize_packagelinks
371 Given a scalar containing a list of packages separated by something
372 that L<Debbugs::CGI/splitpackages> can separate, returns a
373 formatted set of links to packages.
377 sub htmlize_packagelinks {
378 my ($pkgs,$strong) = @_;
379 return unless defined $pkgs and $pkgs ne '';
380 my @pkglist = splitpackages($pkgs);
383 my $openstrong = $strong ? '<strong>' : '';
384 my $closestrong = $strong ? '</strong>' : '';
386 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
389 '<a class="submitter" href="' . pkg_url(pkg=>$_||'') . '">' .
390 $openstrong . html_escape($_) . $closestrong . '</a>'
399 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
400 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
403 In the first form, links the link if it looks like a link. In the
404 second form, first splits based on the regex, then reassembles the
405 link, linking things that look like links. In the third form, rejoins
406 the split links with commas and spaces.
411 my ($links,$regex,$join) = @_;
412 $join = ' ' if not defined $join;
415 if (defined $regex) {
416 @segments = split $regex, $links;
419 @segments = ($links);
421 for my $in (@segments) {
422 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
423 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
425 push @return, html_escape($in);
428 return @return?join($join,@return):'';
432 =head2 htmlize_addresslinks
434 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
437 Generate a comma-separated list of HTML links to each address given in
438 $addresses, which should be a comma-separated list of RFC822
439 addresses. $urlfunc should be a reference to a function like mainturl
440 or submitterurl which returns the URL for each individual address.
445 sub htmlize_addresslinks {
446 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
447 $class = defined $class?qq(class="$class" ):'';
448 if (defined $addresses and $addresses ne '') {
449 my @addrs = getparsedaddrs($addresses);
450 my $prefix = (ref $prefixfunc) ?
451 $prefixfunc->(scalar @addrs):$prefixfunc;
454 { sprintf qq(<a ${class}).
456 $urlfunc->($_->address),
457 html_escape($_->format) ||
463 my $prefix = (ref $prefixfunc) ?
464 $prefixfunc->(1) : $prefixfunc;
465 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
466 $prefix, $urlfunc->('');
471 my $addr = getparsedaddrs($_[0] || "");
472 $addr = defined $addr?$addr->address:'';
476 sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); }
477 sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); }
478 sub htmlize_maintlinks {
479 my ($prefixfunc, $maints) = @_;
480 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
485 our $_maintainer_rev;
490 bug_links($starting_bug,$stoping_bugs,);
492 Creates a set of links to bugs, starting with bug number
493 $starting_bug, and finishing with $stoping_bug; if only one bug is
494 passed, makes a link to only a single bug.
496 The content of the link is the bug number.
498 XXX Use L<Params::Validate>; we want to be able to support query
504 my ($start,$stop,$query_arguments) = @_;
505 $stop = $stop || $start;
506 $query_arguments ||= '';
508 for my $bug ($start..$stop) {
509 push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
511 return join(', ',@output);
516 bug_linklist($separator,$class,@bugs)
518 Creates a set of links to C<@bugs> separated by C<$separator> with
519 link class C<$class>.
521 XXX Use L<Params::Validate>; we want to be able to support query
522 arguments here too; we should be able to combine bug_links and this
523 function into one. [Hell, bug_url should be one function with this one
530 my ($sep,$class,@bugs) = @_;
532 $class = qq(class="$class" );
534 return join($sep,map{qq(<a ${class}href=").
535 bug_url($_).qq(">#$_</a>)
548 Decodes the funky maintainer encoding.
550 Don't ask me what in the world it does.
556 return () unless @input;
558 for my $input (@input) {
559 my $decoded = $input;
560 $decoded =~ s/-([^_]+)/-$1_-/g;
561 $decoded =~ s/_/-20_/g;
562 $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
563 $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
564 $decoded =~ s/\./-2e_/g;
565 $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
566 push @output,$decoded;
568 wantarray ? @output : $output[0];