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();
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(getparsedaddrs 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) = @_;
135 my $url = Debbugs::URI->new('version.cgi?');
136 $url->query_form(package => $package,
140 return $url->as_string;
147 Escapes html entities by calling HTML::Entities::encode_entities;
154 return HTML::Entities::encode_entities($string)
157 =head2 cgi_parameters
161 Returns all of the cgi_parameters from a CGI script using CGI::Simple
166 my %options = validate_with(params => \@_,
167 spec => {query => {type => OBJECT,
170 single => {type => ARRAYREF,
173 default => {type => HASHREF,
178 my $q = $options{query};
180 @single{@{$options{single}}} = (1) x @{$options{single}};
182 for my $paramname ($q->param) {
183 if ($single{$paramname}) {
184 $param{$paramname} = $q->param($paramname);
187 $param{$paramname} = [$q->param($paramname)];
190 for my $default (keys %{$options{default}}) {
191 if (not exists $param{$default}) {
192 # We'll clone the reference here to avoid surprises later.
193 $param{$default} = ref($options{default}{$default})?
194 dclone($options{default}{$default}):$options{default}{$default};
203 print "Content-Type: text/html\n\n";
204 print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
205 print "An error occurred. Dammit.\n";
206 print "Error was: $msg.\n";
207 print "</BODY></HTML>\n";
212 my %common_bugusertags;
220 htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}});
222 Turns a list of bugs into an html snippit of the bugs.
225 # htmlize_bugs(bugs=>[@bugs]);
230 for my $bug (@bugs) {
231 my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
232 bug_url($bug->{bug}), $bug->{bug}, html_escape($bug->{status}{subject});
233 $html .= htmlize_bugstatus($bug->{status}) . "\n";
239 sub htmlize_bugstatus {
240 my %status = %{$_[0]};
245 if ($status{severity} eq $config{default_severity}) {
247 } elsif (isstrongseverity($status{severity})) {
248 $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
250 $showseverity = "Severity: <em>$status{severity}</em>;\n";
253 $result .= htmlize_packagelinks($status{"package"}, 1);
255 my $showversions = '';
256 if (@{$status{found_versions}}) {
257 my @found = @{$status{found_versions}};
259 s{/}{ } foreach @found;
260 $showversions .= join ', ', map html_escape($_), @found;
262 if (@{$status{fixed_versions}}) {
263 $showversions .= '; ' if length $showversions;
264 $showversions .= '<strong>fixed</strong>: ';
265 my @fixed = @{$status{fixed_versions}};
266 $showversions .= join ', ', map {s#/##; html_escape($_)} @fixed;
268 $result .= " ($showversions)" if length $showversions;
271 $result .= $showseverity;
272 $result .= htmlize_addresslinks("Reported by: ", \&submitterurl,
273 $status{originator});
274 $result .= ";\nOwned by: " . html_escape($status{owner})
275 if length $status{owner};
276 $result .= ";\nTags: <strong>"
277 . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
279 if (length($status{tags}));
281 $result .= ";\nMerged with ".
284 split(/ /,$status{mergedwith}))
285 if length $status{mergedwith};
286 $result .= ";\nBlocked by ".
289 split(/ /,$status{blockedby}))
290 if length $status{blockedby};
291 $result .= ";\nBlocks ".
294 split(/ /,$status{blocks})
296 if length $status{blocks};
299 if (length($status{done})) {
300 $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
301 $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
303 $result .= ";\n<strong>Will be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
305 $result .= ";\n<strong>Archived</strong>";
309 if (length($status{forwarded})) {
310 $result .= ";\n<strong>Forwarded</strong> to "
311 . maybelink($status{forwarded});
313 my $daysold = int((time - $status{date}) / 86400); # seconds to days
317 $font = "em" if ($daysold > 30);
318 $font = "strong" if ($daysold > 60);
319 $efont = "</$font>" if ($font);
320 $font = "<$font>" if ($font);
322 my $yearsold = int($daysold / 365);
323 $daysold -= $yearsold * 365;
325 $result .= ";\n $font";
327 push @age, "1 year" if ($yearsold == 1);
328 push @age, "$yearsold years" if ($yearsold > 1);
329 push @age, "1 day" if ($daysold == 1);
330 push @age, "$daysold days" if ($daysold > 1);
331 $result .= join(" and ", @age);
332 $result .= " old$efont";
341 # Split a package string from the status file into a list of package names.
344 return unless defined $pkgs;
345 return map lc, split /[ \t?,()]+/, $pkgs;
349 =head2 htmlize_packagelinks
353 Given a scalar containing a list of packages separated by something
354 that L<Debbugs::CGI/splitpackages> can separate, returns a
355 formatted set of links to packages.
359 sub htmlize_packagelinks {
360 my ($pkgs,$strong) = @_;
361 return unless defined $pkgs and $pkgs ne '';
362 my @pkglist = splitpackages($pkgs);
365 my $openstrong = $strong ? '<strong>' : '';
366 my $closestrong = $strong ? '</strong>' : '';
368 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
371 '<a class="submitter" href="' . pkg_url(pkg=>$_||'') . '">' .
372 $openstrong . html_escape($_) . $closestrong . '</a>'
381 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
382 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
385 In the first form, links the link if it looks like a link. In the
386 second form, first splits based on the regex, then reassembles the
387 link, linking things that look like links. In the third form, rejoins
388 the split links with commas and spaces.
393 my ($links,$regex,$join) = @_;
394 $join = ' ' if not defined $join;
397 if (defined $regex) {
398 @segments = split $regex, $links;
401 @segments = ($links);
403 for my $in (@segments) {
404 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
405 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
407 push @return, html_escape($in);
410 return @return?join($join,@return):'';
414 =head2 htmlize_addresslinks
416 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
419 Generate a comma-separated list of HTML links to each address given in
420 $addresses, which should be a comma-separated list of RFC822
421 addresses. $urlfunc should be a reference to a function like mainturl
422 or submitterurl which returns the URL for each individual address.
427 sub htmlize_addresslinks {
428 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
429 $class = defined $class?qq(class="$class" ):'';
430 if (defined $addresses and $addresses ne '') {
431 my @addrs = getparsedaddrs($addresses);
432 my $prefix = (ref $prefixfunc) ?
433 $prefixfunc->(scalar @addrs):$prefixfunc;
436 { sprintf qq(<a ${class}).
438 $urlfunc->($_->address),
439 html_escape($_->format) ||
445 my $prefix = (ref $prefixfunc) ?
446 $prefixfunc->(1) : $prefixfunc;
447 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
448 $prefix, $urlfunc->('');
453 my $addr = getparsedaddrs($_[0] || "");
454 $addr = defined $addr?$addr->address:'';
458 sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); }
459 sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); }
460 sub htmlize_maintlinks {
461 my ($prefixfunc, $maints) = @_;
462 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
470 return () unless defined $addr;
471 return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
472 if exists $_parsedaddrs{$addr};
473 @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
474 return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
480 return $_maintainer if $_maintainer;
482 for my $file (@config{qw(maintainer_file maintainer_file_override)}) {
483 next unless defined $file;
484 my $maintfile = new IO::File $file,'r' or
485 &quitcgi("Unable to open $file: $!");
486 while(<$maintfile>) {
487 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
494 $_maintainer = \%maintainer;
500 return $_pseudodesc if $_pseudodesc;
503 my $pseudo = new IO::File $config{pseudo_desc_file},'r'
504 or &quitcgi("Unable to open $config{pseudo_desc_file}: $!");
506 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
507 $pseudodesc{lc $1} = $2;
510 $_pseudodesc = \%pseudodesc;
518 bug_links($starting_bug,$stoping_bugs,);
520 Creates a set of links to bugs, starting with bug number
521 $starting_bug, and finishing with $stoping_bug; if only one bug is
522 passed, makes a link to only a single bug.
524 The content of the link is the bug number.
526 XXX Use L<Params::Validate>; we want to be able to support query
532 my ($start,$stop,$query_arguments) = @_;
533 $stop = $stop || $start;
534 $query_arguments ||= '';
536 for my $bug ($start..$stop) {
537 push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
539 return join(', ',@output);
544 bug_linklist($separator,$class,@bugs)
546 Creates a set of links to C<@bugs> separated by C<$separator> with
547 link class C<$class>.
549 XXX Use L<Params::Validate>; we want to be able to support query
550 arguments here too; we should be able to combine bug_links and this
551 function into one. [Hell, bug_url should be one function with this one
558 my ($sep,$class,@bugs) = @_;
560 $class = qq(class="$class" );
562 return join($sep,map{qq(<a ${class}href=").
563 bug_url($_).qq(">#$_</a>)