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 misc => [qw(maint_decode)],
67 #status => [qw(getbugstatus)],
70 Exporter::export_ok_tags(qw(url html util misc));
71 $EXPORT_TAGS{all} = [@EXPORT_OK];
81 Sets the url params which will be used to generate urls.
90 my $url = Debbugs::URI->new($_[0]||'');
91 %URL_PARAMS = %{$url->query_form_hash};
98 bug_url($ref,mbox=>'yes',mboxstat=>'yes');
100 Constructs urls which point to a specific
102 XXX use Params::Validate
111 %params = (%URL_PARAMS,@_);
116 return munge_url('bugreport.cgi?',%params,bug=>$ref);
123 %params = (%URL_PARAMS,@_);
128 return munge_url('pkgreport.cgi?',%params);
133 my $url = munge_url($url,%params_to_munge);
135 Munges a url, replacing parameters with %params_to_munge as appropriate.
142 my $new_url = Debbugs::URI->new($url);
143 my @old_param = $new_url->query_form();
145 while (my ($key,$value) = splice @old_param,0,2) {
146 push @new_param,($key,$value) unless exists $params{$key};
148 $new_url->query_form(@new_param,%params);
149 return $new_url->as_string;
155 version_url($package,$found,$fixed)
157 Creates a link to the version cgi script
162 my ($package,$found,$fixed,$width,$height) = @_;
163 my $url = Debbugs::URI->new('version.cgi?');
164 $url->query_form(package => $package,
167 (defined $width)?(width => $width):(),
168 (defined $height)?(height => $height):(),
169 (defined $width or defined $height)?(collapse => 1):(info => 1),
171 return $url->as_string;
178 Escapes html entities by calling HTML::Entities::encode_entities;
185 return HTML::Entities::encode_entities($string,q(<>&"'));
188 =head2 cgi_parameters
192 Returns all of the cgi_parameters from a CGI script using CGI::Simple
197 my %options = validate_with(params => \@_,
198 spec => {query => {type => OBJECT,
201 single => {type => ARRAYREF,
204 default => {type => HASHREF,
209 my $q = $options{query};
211 @single{@{$options{single}}} = (1) x @{$options{single}};
213 for my $paramname ($q->param) {
214 if ($single{$paramname}) {
215 $param{$paramname} = $q->param($paramname);
218 $param{$paramname} = [$q->param($paramname)];
221 for my $default (keys %{$options{default}}) {
222 if (not exists $param{$default}) {
223 # We'll clone the reference here to avoid surprises later.
224 $param{$default} = ref($options{default}{$default})?
225 dclone($options{default}{$default}):$options{default}{$default};
234 print "Content-Type: text/html\n\n";
235 print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
236 print "An error occurred. Dammit.\n";
237 print "Error was: $msg.\n";
238 print "</BODY></HTML>\n";
247 htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}});
249 Turns a list of bugs into an html snippit of the bugs.
252 # htmlize_bugs(bugs=>[@bugs]);
257 for my $bug (@bugs) {
258 my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
259 bug_url($bug->{bug}), $bug->{bug}, html_escape($bug->{status}{subject});
260 $html .= htmlize_bugstatus($bug->{status}) . "\n";
266 sub htmlize_bugstatus {
267 my %status = %{$_[0]};
272 if ($status{severity} eq $config{default_severity}) {
274 } elsif (isstrongseverity($status{severity})) {
275 $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
277 $showseverity = "Severity: <em>$status{severity}</em>;\n";
280 $result .= htmlize_packagelinks($status{"package"}, 1);
282 my $showversions = '';
283 if (@{$status{found_versions}}) {
284 my @found = @{$status{found_versions}};
286 s{/}{ } foreach @found;
287 $showversions .= join ', ', map html_escape($_), @found;
289 if (@{$status{fixed_versions}}) {
290 $showversions .= '; ' if length $showversions;
291 $showversions .= '<strong>fixed</strong>: ';
292 my @fixed = @{$status{fixed_versions}};
293 $showversions .= join ', ', map {s#/##; html_escape($_)} @fixed;
295 $result .= " ($showversions)" if length $showversions;
298 $result .= $showseverity;
299 $result .= htmlize_addresslinks("Reported by: ", \&submitterurl,
300 $status{originator});
301 $result .= ";\nOwned by: " . html_escape($status{owner})
302 if length $status{owner};
303 $result .= ";\nTags: <strong>"
304 . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
306 if (length($status{tags}));
308 $result .= ";\nMerged with ".
311 split(/ /,$status{mergedwith}))
312 if length $status{mergedwith};
313 $result .= ";\nBlocked by ".
316 split(/ /,$status{blockedby}))
317 if length $status{blockedby};
318 $result .= ";\nBlocks ".
321 split(/ /,$status{blocks})
323 if length $status{blocks};
326 if (length($status{done})) {
327 $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
328 $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
330 $result .= ";\n<strong>Will be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
332 $result .= ";\n<strong>Archived</strong>";
336 if (length($status{forwarded})) {
337 $result .= ";\n<strong>Forwarded</strong> to "
338 . maybelink($status{forwarded});
340 my $daysold = int((time - $status{date}) / 86400); # seconds to days
344 $font = "em" if ($daysold > 30);
345 $font = "strong" if ($daysold > 60);
346 $efont = "</$font>" if ($font);
347 $font = "<$font>" if ($font);
349 my $yearsold = int($daysold / 365);
350 $daysold -= $yearsold * 365;
352 $result .= ";\n $font";
354 push @age, "1 year" if ($yearsold == 1);
355 push @age, "$yearsold years" if ($yearsold > 1);
356 push @age, "1 day" if ($daysold == 1);
357 push @age, "$daysold days" if ($daysold > 1);
358 $result .= join(" and ", @age);
359 $result .= " old$efont";
368 =head2 htmlize_packagelinks
372 Given a scalar containing a list of packages separated by something
373 that L<Debbugs::CGI/splitpackages> can separate, returns a
374 formatted set of links to packages.
378 sub htmlize_packagelinks {
379 my ($pkgs,$strong) = @_;
380 return unless defined $pkgs and $pkgs ne '';
381 my @pkglist = splitpackages($pkgs);
384 my $openstrong = $strong ? '<strong>' : '';
385 my $closestrong = $strong ? '</strong>' : '';
387 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
390 '<a class="submitter" href="' . pkg_url(pkg=>$_||'') . '">' .
391 $openstrong . html_escape($_) . $closestrong . '</a>'
400 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
401 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
404 In the first form, links the link if it looks like a link. In the
405 second form, first splits based on the regex, then reassembles the
406 link, linking things that look like links. In the third form, rejoins
407 the split links with commas and spaces.
412 my ($links,$regex,$join) = @_;
413 $join = ' ' if not defined $join;
416 if (defined $regex) {
417 @segments = split $regex, $links;
420 @segments = ($links);
422 for my $in (@segments) {
423 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
424 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
426 push @return, html_escape($in);
429 return @return?join($join,@return):'';
433 =head2 htmlize_addresslinks
435 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
438 Generate a comma-separated list of HTML links to each address given in
439 $addresses, which should be a comma-separated list of RFC822
440 addresses. $urlfunc should be a reference to a function like mainturl
441 or submitterurl which returns the URL for each individual address.
446 sub htmlize_addresslinks {
447 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
448 $class = defined $class?qq(class="$class" ):'';
449 if (defined $addresses and $addresses ne '') {
450 my @addrs = getparsedaddrs($addresses);
451 my $prefix = (ref $prefixfunc) ?
452 $prefixfunc->(scalar @addrs):$prefixfunc;
455 { sprintf qq(<a ${class}).
457 $urlfunc->($_->address),
458 html_escape($_->format) ||
464 my $prefix = (ref $prefixfunc) ?
465 $prefixfunc->(1) : $prefixfunc;
466 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
467 $prefix, $urlfunc->('');
472 my $addr = getparsedaddrs($_[0] || "");
473 $addr = defined $addr?$addr->address:'';
477 sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); }
478 sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); }
479 sub htmlize_maintlinks {
480 my ($prefixfunc, $maints) = @_;
481 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
486 our $_maintainer_rev;
490 return $_pseudodesc if $_pseudodesc;
493 my $pseudo = new IO::File $config{pseudo_desc_file},'r'
494 or &quitcgi("Unable to open $config{pseudo_desc_file}: $!");
496 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
497 $pseudodesc{lc $1} = $2;
500 $_pseudodesc = \%pseudodesc;
508 bug_links($starting_bug,$stoping_bugs,);
510 Creates a set of links to bugs, starting with bug number
511 $starting_bug, and finishing with $stoping_bug; if only one bug is
512 passed, makes a link to only a single bug.
514 The content of the link is the bug number.
516 XXX Use L<Params::Validate>; we want to be able to support query
522 my ($start,$stop,$query_arguments) = @_;
523 $stop = $stop || $start;
524 $query_arguments ||= '';
526 for my $bug ($start..$stop) {
527 push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
529 return join(', ',@output);
534 bug_linklist($separator,$class,@bugs)
536 Creates a set of links to C<@bugs> separated by C<$separator> with
537 link class C<$class>.
539 XXX Use L<Params::Validate>; we want to be able to support query
540 arguments here too; we should be able to combine bug_links and this
541 function into one. [Hell, bug_url should be one function with this one
548 my ($sep,$class,@bugs) = @_;
550 $class = qq(class="$class" );
552 return join($sep,map{qq(<a ${class}href=").
553 bug_url($_).qq(">#$_</a>)
566 Decodes the funky maintainer encoding.
568 Don't ask me what in the world it does.
574 return () unless @input;
576 for my $input (@input) {
577 my $decoded = $input;
578 $decoded =~ s/-([^_]+)/-$1_-/g;
579 $decoded =~ s/_/-20_/g;
580 $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
581 $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
582 $decoded =~ s/\./-2e_/g;
583 $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
584 push @output,$decoded;
586 wantarray ? @output : $output[0];