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);
37 use Storable qw(dclone);
43 ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
44 $DEBUG = 0 unless defined $DEBUG;
47 %EXPORT_TAGS = (url => [qw(bug_url bug_links bug_linklist maybelink),
48 qw(set_url_params pkg_url version_url),
49 qw(submitterurl mainturl)
51 html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
52 qw(maybelink htmlize_addresslinks htmlize_maintlinks),
54 util => [qw(cgi_parameters quitcgi),
55 qw(getmaintainers getpseudodesc splitpackages)
57 #status => [qw(getbugstatus)],
60 Exporter::export_ok_tags(qw(url html util));
61 $EXPORT_TAGS{all} = [@EXPORT_OK];
71 Sets the url params which will be used to generate urls.
80 my $url = Debbugs::URI->new($_[0]||'');
81 %URL_PARAMS = %{$url->query_form_hash};
88 bug_url($ref,mbox=>'yes',mboxstat=>'yes');
90 Constructs urls which point to a specific
92 XXX use Params::Validate
101 %params = (%URL_PARAMS,@_);
106 my $url = Debbugs::URI->new('bugreport.cgi?');
107 $url->query_form(bug=>$ref,%params);
108 return $url->as_string;
115 %params = (%URL_PARAMS,@_);
120 my $url = Debbugs::URI->new('pkgreport.cgi?');
121 $url->query_form(%params);
122 return $url->as_string;
127 version_url($package,$found,$fixed)
129 Creates a link to the version cgi script
134 my ($package,$found,$fixed,$width,$height) = @_;
135 my $url = Debbugs::URI->new('version.cgi?');
136 $url->query_form(package => $package,
139 (defined $width)?(width => $width):(),
140 (defined $height)?(height => $height):()
142 return $url->as_string;
149 Escapes html entities by calling HTML::Entities::encode_entities;
156 return HTML::Entities::encode_entities($string)
159 =head2 cgi_parameters
163 Returns all of the cgi_parameters from a CGI script using CGI::Simple
168 my %options = validate_with(params => \@_,
169 spec => {query => {type => OBJECT,
172 single => {type => ARRAYREF,
175 default => {type => HASHREF,
180 my $q = $options{query};
182 @single{@{$options{single}}} = (1) x @{$options{single}};
184 for my $paramname ($q->param) {
185 if ($single{$paramname}) {
186 $param{$paramname} = $q->param($paramname);
189 $param{$paramname} = [$q->param($paramname)];
192 for my $default (keys %{$options{default}}) {
193 if (not exists $param{$default}) {
194 # We'll clone the reference here to avoid surprises later.
195 $param{$default} = ref($options{default}{$default})?
196 dclone($options{default}{$default}):$options{default}{$default};
205 print "Content-Type: text/html\n\n";
206 print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
207 print "An error occurred. Dammit.\n";
208 print "Error was: $msg.\n";
209 print "</BODY></HTML>\n";
214 my %common_bugusertags;
222 htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}});
224 Turns a list of bugs into an html snippit of the bugs.
227 # htmlize_bugs(bugs=>[@bugs]);
232 for my $bug (@bugs) {
233 my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
234 bug_url($bug->{bug}), $bug->{bug}, html_escape($bug->{status}{subject});
235 $html .= htmlize_bugstatus($bug->{status}) . "\n";
241 sub htmlize_bugstatus {
242 my %status = %{$_[0]};
247 if ($status{severity} eq $config{default_severity}) {
249 } elsif (isstrongseverity($status{severity})) {
250 $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
252 $showseverity = "Severity: <em>$status{severity}</em>;\n";
255 $result .= htmlize_packagelinks($status{"package"}, 1);
257 my $showversions = '';
258 if (@{$status{found_versions}}) {
259 my @found = @{$status{found_versions}};
261 s{/}{ } foreach @found;
262 $showversions .= join ', ', map html_escape($_), @found;
264 if (@{$status{fixed_versions}}) {
265 $showversions .= '; ' if length $showversions;
266 $showversions .= '<strong>fixed</strong>: ';
267 my @fixed = @{$status{fixed_versions}};
268 $showversions .= join ', ', map {s#/##; html_escape($_)} @fixed;
270 $result .= " ($showversions)" if length $showversions;
273 $result .= $showseverity;
274 $result .= htmlize_addresslinks("Reported by: ", \&submitterurl,
275 $status{originator});
276 $result .= ";\nOwned by: " . html_escape($status{owner})
277 if length $status{owner};
278 $result .= ";\nTags: <strong>"
279 . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
281 if (length($status{tags}));
283 $result .= ";\nMerged with ".
286 split(/ /,$status{mergedwith}))
287 if length $status{mergedwith};
288 $result .= ";\nBlocked by ".
291 split(/ /,$status{blockedby}))
292 if length $status{blockedby};
293 $result .= ";\nBlocks ".
296 split(/ /,$status{blocks})
298 if length $status{blocks};
301 if (length($status{done})) {
302 $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
303 $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
305 $result .= ";\n<strong>Will be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
307 $result .= ";\n<strong>Archived</strong>";
311 if (length($status{forwarded})) {
312 $result .= ";\n<strong>Forwarded</strong> to "
313 . maybelink($status{forwarded});
315 my $daysold = int((time - $status{date}) / 86400); # seconds to days
319 $font = "em" if ($daysold > 30);
320 $font = "strong" if ($daysold > 60);
321 $efont = "</$font>" if ($font);
322 $font = "<$font>" if ($font);
324 my $yearsold = int($daysold / 365);
325 $daysold -= $yearsold * 365;
327 $result .= ";\n $font";
329 push @age, "1 year" if ($yearsold == 1);
330 push @age, "$yearsold years" if ($yearsold > 1);
331 push @age, "1 day" if ($daysold == 1);
332 push @age, "$daysold days" if ($daysold > 1);
333 $result .= join(" and ", @age);
334 $result .= " old$efont";
343 # Split a package string from the status file into a list of package names.
346 return unless defined $pkgs;
347 return map lc, split /[ \t?,()]+/, $pkgs;
351 =head2 htmlize_packagelinks
355 Given a scalar containing a list of packages separated by something
356 that L<Debbugs::CGI/splitpackages> can separate, returns a
357 formatted set of links to packages.
361 sub htmlize_packagelinks {
362 my ($pkgs,$strong) = @_;
363 return unless defined $pkgs and $pkgs ne '';
364 my @pkglist = splitpackages($pkgs);
367 my $openstrong = $strong ? '<strong>' : '';
368 my $closestrong = $strong ? '</strong>' : '';
370 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
373 '<a class="submitter" href="' . pkg_url(pkg=>$_||'') . '">' .
374 $openstrong . html_escape($_) . $closestrong . '</a>'
383 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
384 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
387 In the first form, links the link if it looks like a link. In the
388 second form, first splits based on the regex, then reassembles the
389 link, linking things that look like links. In the third form, rejoins
390 the split links with commas and spaces.
395 my ($links,$regex,$join) = @_;
396 $join = ' ' if not defined $join;
399 if (defined $regex) {
400 @segments = split $regex, $links;
403 @segments = ($links);
405 for my $in (@segments) {
406 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
407 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
409 push @return, html_escape($in);
412 return @return?join($join,@return):'';
416 =head2 htmlize_addresslinks
418 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
421 Generate a comma-separated list of HTML links to each address given in
422 $addresses, which should be a comma-separated list of RFC822
423 addresses. $urlfunc should be a reference to a function like mainturl
424 or submitterurl which returns the URL for each individual address.
429 sub htmlize_addresslinks {
430 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
431 $class = defined $class?qq(class="$class" ):'';
432 if (defined $addresses and $addresses ne '') {
433 my @addrs = getparsedaddrs($addresses);
434 my $prefix = (ref $prefixfunc) ?
435 $prefixfunc->(scalar @addrs):$prefixfunc;
438 { sprintf qq(<a ${class}).
440 $urlfunc->($_->address),
441 html_escape($_->format) ||
447 my $prefix = (ref $prefixfunc) ?
448 $prefixfunc->(1) : $prefixfunc;
449 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
450 $prefix, $urlfunc->('');
455 my $addr = getparsedaddrs($_[0] || "");
456 $addr = defined $addr?$addr->address:'';
460 sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); }
461 sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); }
462 sub htmlize_maintlinks {
463 my ($prefixfunc, $maints) = @_;
464 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
471 return $_maintainer if $_maintainer;
474 for my $file (@config{qw(maintainer_file maintainer_file_override)}) {
475 next unless defined $file;
476 my $maintfile = new IO::File $file,'r' or
477 &quitcgi("Unable to open $file: $!");
478 while(<$maintfile>) {
479 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
483 for my $maint (map {lc($_->address)} getparsedaddrs($b)) {
484 push @{$maintainer_rev{$maint}},$a;
489 $_maintainer = \%maintainer;
490 $_maintainer_rev = \%maintainer_rev;
493 sub getmaintainers_reverse{
494 return $_maintainer_rev if $_maintainer_rev;
496 return $_maintainer_rev;
502 return $_pseudodesc if $_pseudodesc;
505 my $pseudo = new IO::File $config{pseudo_desc_file},'r'
506 or &quitcgi("Unable to open $config{pseudo_desc_file}: $!");
508 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
509 $pseudodesc{lc $1} = $2;
512 $_pseudodesc = \%pseudodesc;
520 bug_links($starting_bug,$stoping_bugs,);
522 Creates a set of links to bugs, starting with bug number
523 $starting_bug, and finishing with $stoping_bug; if only one bug is
524 passed, makes a link to only a single bug.
526 The content of the link is the bug number.
528 XXX Use L<Params::Validate>; we want to be able to support query
534 my ($start,$stop,$query_arguments) = @_;
535 $stop = $stop || $start;
536 $query_arguments ||= '';
538 for my $bug ($start..$stop) {
539 push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
541 return join(', ',@output);
546 bug_linklist($separator,$class,@bugs)
548 Creates a set of links to C<@bugs> separated by C<$separator> with
549 link class C<$class>.
551 XXX Use L<Params::Validate>; we want to be able to support query
552 arguments here too; we should be able to combine bug_links and this
553 function into one. [Hell, bug_url should be one function with this one
560 my ($sep,$class,@bugs) = @_;
562 $class = qq(class="$class" );
564 return join($sep,map{qq(<a ${class}href=").
565 bug_url($_).qq(">#$_</a>)