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);
48 use Debbugs::Text qw(fill_in_template);
54 ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
55 $DEBUG = 0 unless defined $DEBUG;
58 %EXPORT_TAGS = (url => [qw(bug_url bug_links bug_linklist maybelink),
59 qw(set_url_params pkg_url version_url),
60 qw(submitterurl mainturl munge_url)
62 html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
63 qw(maybelink htmlize_addresslinks htmlize_maintlinks),
65 util => [qw(cgi_parameters quitcgi),
67 misc => [qw(maint_decode)],
68 #status => [qw(getbugstatus)],
71 Exporter::export_ok_tags(qw(url html util misc));
72 $EXPORT_TAGS{all} = [@EXPORT_OK];
82 Sets the url params which will be used to generate urls.
91 my $url = Debbugs::URI->new($_[0]||'');
92 %URL_PARAMS = %{$url->query_form_hash};
99 bug_url($ref,mbox=>'yes',mboxstat=>'yes');
101 Constructs urls which point to a specific
103 XXX use Params::Validate
112 %params = (%URL_PARAMS,@_);
117 return munge_url('bugreport.cgi?',%params,bug=>$ref);
124 %params = (%URL_PARAMS,@_);
129 return munge_url('pkgreport.cgi?',%params);
134 my $url = munge_url($url,%params_to_munge);
136 Munges a url, replacing parameters with %params_to_munge as appropriate.
143 my $new_url = Debbugs::URI->new($url);
144 my @old_param = $new_url->query_form();
146 while (my ($key,$value) = splice @old_param,0,2) {
147 push @new_param,($key,$value) unless exists $params{$key};
149 $new_url->query_form(@new_param,%params);
150 return $new_url->as_string;
156 version_url(package => $package,found => $found,fixed => $fixed)
158 Creates a link to the version cgi script
162 =item package -- source package whose graph to display
164 =item found -- arrayref of found versions
166 =item fixed -- arrayref of fixed versions
168 =item width -- optional width of graph
170 =item height -- optional height of graph
172 =item info -- display html info surrounding graph; defaults to 1 if
173 width and height are not passed.
175 =item collapse -- whether to collapse the graph; defaults to 1 if
176 width and height are passed.
183 my %params = validate_with(params => \@_,
184 spec => {package => {type => SCALAR,
186 found => {type => ARRAYREF,
189 fixed => {type => ARRAYREF,
192 width => {type => SCALAR,
195 height => {type => SCALAR,
198 absolute => {type => BOOLEAN,
201 collapse => {type => BOOLEAN,
204 info => {type => BOOLEAN,
209 if (not defined $params{width} and not defined $params{height}) {
210 $params{info} = 1 if not exists $params{info};
212 my $url = Debbugs::URI->new('version.cgi?');
213 $url->query_form(%params);
214 return $url->as_string;
221 Escapes html entities by calling HTML::Entities::encode_entities;
228 return HTML::Entities::encode_entities($string,q(<>&"'));
231 =head2 cgi_parameters
235 Returns all of the cgi_parameters from a CGI script using CGI::Simple
240 my %options = validate_with(params => \@_,
241 spec => {query => {type => OBJECT,
244 single => {type => ARRAYREF,
247 default => {type => HASHREF,
252 my $q = $options{query};
254 @single{@{$options{single}}} = (1) x @{$options{single}};
256 for my $paramname ($q->param) {
257 if ($single{$paramname}) {
258 $param{$paramname} = $q->param($paramname);
261 $param{$paramname} = [$q->param($paramname)];
264 for my $default (keys %{$options{default}}) {
265 if (not exists $param{$default}) {
266 # We'll clone the reference here to avoid surprises later.
267 $param{$default} = ref($options{default}{$default})?
268 dclone($options{default}{$default}):$options{default}{$default};
277 print "Content-Type: text/html\n\n";
278 print fill_in_template(template=>'cgi/quit',
279 variables => {msg => $msg}
289 htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}});
291 Turns a list of bugs into an html snippit of the bugs.
294 # htmlize_bugs(bugs=>[@bugs]);
299 for my $bug (@bugs) {
300 my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
301 bug_url($bug->{bug}), $bug->{bug}, html_escape($bug->{status}{subject});
302 $html .= htmlize_bugstatus($bug->{status}) . "\n";
308 sub htmlize_bugstatus {
309 my %status = %{$_[0]};
314 if ($status{severity} eq $config{default_severity}) {
316 } elsif (isstrongseverity($status{severity})) {
317 $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
319 $showseverity = "Severity: <em>$status{severity}</em>;\n";
322 $result .= htmlize_packagelinks($status{"package"}, 1);
324 my $showversions = '';
325 if (@{$status{found_versions}}) {
326 my @found = @{$status{found_versions}};
328 s{/}{ } foreach @found;
329 $showversions .= join ', ', map html_escape($_), @found;
331 if (@{$status{fixed_versions}}) {
332 $showversions .= '; ' if length $showversions;
333 $showversions .= '<strong>fixed</strong>: ';
334 my @fixed = @{$status{fixed_versions}};
335 $showversions .= join ', ', map {s#/##; html_escape($_)} @fixed;
337 $result .= " ($showversions)" if length $showversions;
340 $result .= $showseverity;
341 $result .= htmlize_addresslinks("Reported by: ", \&submitterurl,
342 $status{originator});
343 $result .= ";\nOwned by: " . html_escape($status{owner})
344 if length $status{owner};
345 $result .= ";\nTags: <strong>"
346 . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
348 if (length($status{tags}));
350 $result .= ";\nMerged with ".
353 split(/ /,$status{mergedwith}))
354 if length $status{mergedwith};
355 $result .= ";\nBlocked by ".
358 split(/ /,$status{blockedby}))
359 if length $status{blockedby};
360 $result .= ";\nBlocks ".
363 split(/ /,$status{blocks})
365 if length $status{blocks};
368 if (length($status{done})) {
369 $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
370 $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
372 $result .= ";\n<strong>Will be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
374 $result .= ";\n<strong>Archived</strong>";
378 if (length($status{forwarded})) {
379 $result .= ";\n<strong>Forwarded</strong> to "
380 . maybelink($status{forwarded});
382 my $daysold = int((time - $status{date}) / 86400); # seconds to days
386 $font = "em" if ($daysold > 30);
387 $font = "strong" if ($daysold > 60);
388 $efont = "</$font>" if ($font);
389 $font = "<$font>" if ($font);
391 my $yearsold = int($daysold / 365);
392 $daysold -= $yearsold * 365;
394 $result .= ";\n $font";
396 push @age, "1 year" if ($yearsold == 1);
397 push @age, "$yearsold years" if ($yearsold > 1);
398 push @age, "1 day" if ($daysold == 1);
399 push @age, "$daysold days" if ($daysold > 1);
400 $result .= join(" and ", @age);
401 $result .= " old$efont";
410 =head2 htmlize_packagelinks
414 Given a scalar containing a list of packages separated by something
415 that L<Debbugs::CGI/splitpackages> can separate, returns a
416 formatted set of links to packages.
420 sub htmlize_packagelinks {
421 my ($pkgs,$strong) = @_;
422 return unless defined $pkgs and $pkgs ne '';
423 my @pkglist = splitpackages($pkgs);
426 my $openstrong = $strong ? '<strong>' : '';
427 my $closestrong = $strong ? '</strong>' : '';
429 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
432 '<a class="submitter" href="' . pkg_url(pkg=>$_||'') . '">' .
433 $openstrong . html_escape($_) . $closestrong . '</a>'
442 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
443 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
446 In the first form, links the link if it looks like a link. In the
447 second form, first splits based on the regex, then reassembles the
448 link, linking things that look like links. In the third form, rejoins
449 the split links with commas and spaces.
454 my ($links,$regex,$join) = @_;
455 $join = ' ' if not defined $join;
458 if (defined $regex) {
459 @segments = split $regex, $links;
462 @segments = ($links);
464 for my $in (@segments) {
465 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
466 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
468 push @return, html_escape($in);
471 return @return?join($join,@return):'';
475 =head2 htmlize_addresslinks
477 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
480 Generate a comma-separated list of HTML links to each address given in
481 $addresses, which should be a comma-separated list of RFC822
482 addresses. $urlfunc should be a reference to a function like mainturl
483 or submitterurl which returns the URL for each individual address.
488 sub htmlize_addresslinks {
489 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
490 $class = defined $class?qq(class="$class" ):'';
491 if (defined $addresses and $addresses ne '') {
492 my @addrs = getparsedaddrs($addresses);
493 my $prefix = (ref $prefixfunc) ?
494 $prefixfunc->(scalar @addrs):$prefixfunc;
497 { sprintf qq(<a ${class}).
499 $urlfunc->($_->address),
500 html_escape($_->format) ||
506 my $prefix = (ref $prefixfunc) ?
507 $prefixfunc->(1) : $prefixfunc;
508 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
509 $prefix, $urlfunc->('');
514 my $addr = getparsedaddrs($_[0] || "");
515 $addr = defined $addr?$addr->address:'';
519 sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); }
520 sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); }
521 sub htmlize_maintlinks {
522 my ($prefixfunc, $maints) = @_;
523 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
528 our $_maintainer_rev;
533 bug_links($starting_bug,$stoping_bugs,);
535 Creates a set of links to bugs, starting with bug number
536 $starting_bug, and finishing with $stoping_bug; if only one bug is
537 passed, makes a link to only a single bug.
539 The content of the link is the bug number.
541 XXX Use L<Params::Validate>; we want to be able to support query
547 my ($start,$stop,$query_arguments) = @_;
548 $stop = $stop || $start;
549 $query_arguments ||= '';
551 for my $bug ($start..$stop) {
552 push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
554 return join(', ',@output);
559 bug_linklist($separator,$class,@bugs)
561 Creates a set of links to C<@bugs> separated by C<$separator> with
562 link class C<$class>.
564 XXX Use L<Params::Validate>; we want to be able to support query
565 arguments here too; we should be able to combine bug_links and this
566 function into one. [Hell, bug_url should be one function with this one
573 my ($sep,$class,@bugs) = @_;
575 $class = qq(class="$class" );
577 return join($sep,map{qq(<a ${class}href=").
578 bug_url($_).qq(">#$_</a>)
591 Decodes the funky maintainer encoding.
593 Don't ask me what in the world it does.
599 return () unless @input;
601 for my $input (@input) {
602 my $decoded = $input;
603 $decoded =~ s/-([^_]+)/-$1_-/g;
604 $decoded =~ s/_/-20_/g;
605 $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
606 $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
607 $decoded =~ s/\./-2e_/g;
608 $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
609 push @output,$decoded;
611 wantarray ? @output : $output[0];