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);
35 use Debbugs::Status qw(splitpackages);
38 use Storable qw(dclone);
44 ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
45 $DEBUG = 0 unless defined $DEBUG;
48 %EXPORT_TAGS = (url => [qw(bug_url bug_links bug_linklist maybelink),
49 qw(set_url_params pkg_url version_url),
50 qw(submitterurl mainturl)
52 html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
53 qw(maybelink htmlize_addresslinks htmlize_maintlinks),
55 util => [qw(cgi_parameters quitcgi),
58 #status => [qw(getbugstatus)],
61 Exporter::export_ok_tags(qw(url html util));
62 $EXPORT_TAGS{all} = [@EXPORT_OK];
72 Sets the url params which will be used to generate urls.
81 my $url = Debbugs::URI->new($_[0]||'');
82 %URL_PARAMS = %{$url->query_form_hash};
89 bug_url($ref,mbox=>'yes',mboxstat=>'yes');
91 Constructs urls which point to a specific
93 XXX use Params::Validate
102 %params = (%URL_PARAMS,@_);
107 my $url = Debbugs::URI->new('bugreport.cgi?');
108 $url->query_form(bug=>$ref,%params);
109 return $url->as_string;
116 %params = (%URL_PARAMS,@_);
121 my $url = Debbugs::URI->new('pkgreport.cgi?');
122 $url->query_form(%params);
123 return $url->as_string;
128 version_url($package,$found,$fixed)
130 Creates a link to the version cgi script
135 my ($package,$found,$fixed,$width,$height) = @_;
136 my $url = Debbugs::URI->new('version.cgi?');
137 $url->query_form(package => $package,
140 (defined $width)?(width => $width):(),
141 (defined $height)?(height => $height):(),
142 (defined $width or defined $height)?(collapse => 1):(),
144 return $url->as_string;
151 Escapes html entities by calling HTML::Entities::encode_entities;
158 return HTML::Entities::encode_entities($string,q(<>&"'));
161 =head2 cgi_parameters
165 Returns all of the cgi_parameters from a CGI script using CGI::Simple
170 my %options = validate_with(params => \@_,
171 spec => {query => {type => OBJECT,
174 single => {type => ARRAYREF,
177 default => {type => HASHREF,
182 my $q = $options{query};
184 @single{@{$options{single}}} = (1) x @{$options{single}};
186 for my $paramname ($q->param) {
187 if ($single{$paramname}) {
188 $param{$paramname} = $q->param($paramname);
191 $param{$paramname} = [$q->param($paramname)];
194 for my $default (keys %{$options{default}}) {
195 if (not exists $param{$default}) {
196 # We'll clone the reference here to avoid surprises later.
197 $param{$default} = ref($options{default}{$default})?
198 dclone($options{default}{$default}):$options{default}{$default};
207 print "Content-Type: text/html\n\n";
208 print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
209 print "An error occurred. Dammit.\n";
210 print "Error was: $msg.\n";
211 print "</BODY></HTML>\n";
216 my %common_bugusertags;
224 htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}});
226 Turns a list of bugs into an html snippit of the bugs.
229 # htmlize_bugs(bugs=>[@bugs]);
234 for my $bug (@bugs) {
235 my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
236 bug_url($bug->{bug}), $bug->{bug}, html_escape($bug->{status}{subject});
237 $html .= htmlize_bugstatus($bug->{status}) . "\n";
243 sub htmlize_bugstatus {
244 my %status = %{$_[0]};
249 if ($status{severity} eq $config{default_severity}) {
251 } elsif (isstrongseverity($status{severity})) {
252 $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
254 $showseverity = "Severity: <em>$status{severity}</em>;\n";
257 $result .= htmlize_packagelinks($status{"package"}, 1);
259 my $showversions = '';
260 if (@{$status{found_versions}}) {
261 my @found = @{$status{found_versions}};
263 s{/}{ } foreach @found;
264 $showversions .= join ', ', map html_escape($_), @found;
266 if (@{$status{fixed_versions}}) {
267 $showversions .= '; ' if length $showversions;
268 $showversions .= '<strong>fixed</strong>: ';
269 my @fixed = @{$status{fixed_versions}};
270 $showversions .= join ', ', map {s#/##; html_escape($_)} @fixed;
272 $result .= " ($showversions)" if length $showversions;
275 $result .= $showseverity;
276 $result .= htmlize_addresslinks("Reported by: ", \&submitterurl,
277 $status{originator});
278 $result .= ";\nOwned by: " . html_escape($status{owner})
279 if length $status{owner};
280 $result .= ";\nTags: <strong>"
281 . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
283 if (length($status{tags}));
285 $result .= ";\nMerged with ".
288 split(/ /,$status{mergedwith}))
289 if length $status{mergedwith};
290 $result .= ";\nBlocked by ".
293 split(/ /,$status{blockedby}))
294 if length $status{blockedby};
295 $result .= ";\nBlocks ".
298 split(/ /,$status{blocks})
300 if length $status{blocks};
303 if (length($status{done})) {
304 $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
305 $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
307 $result .= ";\n<strong>Will be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
309 $result .= ";\n<strong>Archived</strong>";
313 if (length($status{forwarded})) {
314 $result .= ";\n<strong>Forwarded</strong> to "
315 . maybelink($status{forwarded});
317 my $daysold = int((time - $status{date}) / 86400); # seconds to days
321 $font = "em" if ($daysold > 30);
322 $font = "strong" if ($daysold > 60);
323 $efont = "</$font>" if ($font);
324 $font = "<$font>" if ($font);
326 my $yearsold = int($daysold / 365);
327 $daysold -= $yearsold * 365;
329 $result .= ";\n $font";
331 push @age, "1 year" if ($yearsold == 1);
332 push @age, "$yearsold years" if ($yearsold > 1);
333 push @age, "1 day" if ($daysold == 1);
334 push @age, "$daysold days" if ($daysold > 1);
335 $result .= join(" and ", @age);
336 $result .= " old$efont";
345 =head2 htmlize_packagelinks
349 Given a scalar containing a list of packages separated by something
350 that L<Debbugs::CGI/splitpackages> can separate, returns a
351 formatted set of links to packages.
355 sub htmlize_packagelinks {
356 my ($pkgs,$strong) = @_;
357 return unless defined $pkgs and $pkgs ne '';
358 my @pkglist = splitpackages($pkgs);
361 my $openstrong = $strong ? '<strong>' : '';
362 my $closestrong = $strong ? '</strong>' : '';
364 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
367 '<a class="submitter" href="' . pkg_url(pkg=>$_||'') . '">' .
368 $openstrong . html_escape($_) . $closestrong . '</a>'
377 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
378 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
381 In the first form, links the link if it looks like a link. In the
382 second form, first splits based on the regex, then reassembles the
383 link, linking things that look like links. In the third form, rejoins
384 the split links with commas and spaces.
389 my ($links,$regex,$join) = @_;
390 $join = ' ' if not defined $join;
393 if (defined $regex) {
394 @segments = split $regex, $links;
397 @segments = ($links);
399 for my $in (@segments) {
400 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
401 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
403 push @return, html_escape($in);
406 return @return?join($join,@return):'';
410 =head2 htmlize_addresslinks
412 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
415 Generate a comma-separated list of HTML links to each address given in
416 $addresses, which should be a comma-separated list of RFC822
417 addresses. $urlfunc should be a reference to a function like mainturl
418 or submitterurl which returns the URL for each individual address.
423 sub htmlize_addresslinks {
424 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
425 $class = defined $class?qq(class="$class" ):'';
426 if (defined $addresses and $addresses ne '') {
427 my @addrs = getparsedaddrs($addresses);
428 my $prefix = (ref $prefixfunc) ?
429 $prefixfunc->(scalar @addrs):$prefixfunc;
432 { sprintf qq(<a ${class}).
434 $urlfunc->($_->address),
435 html_escape($_->format) ||
441 my $prefix = (ref $prefixfunc) ?
442 $prefixfunc->(1) : $prefixfunc;
443 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
444 $prefix, $urlfunc->('');
449 my $addr = getparsedaddrs($_[0] || "");
450 $addr = defined $addr?$addr->address:'';
454 sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); }
455 sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); }
456 sub htmlize_maintlinks {
457 my ($prefixfunc, $maints) = @_;
458 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
467 return $_pseudodesc if $_pseudodesc;
470 my $pseudo = new IO::File $config{pseudo_desc_file},'r'
471 or &quitcgi("Unable to open $config{pseudo_desc_file}: $!");
473 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
474 $pseudodesc{lc $1} = $2;
477 $_pseudodesc = \%pseudodesc;
485 bug_links($starting_bug,$stoping_bugs,);
487 Creates a set of links to bugs, starting with bug number
488 $starting_bug, and finishing with $stoping_bug; if only one bug is
489 passed, makes a link to only a single bug.
491 The content of the link is the bug number.
493 XXX Use L<Params::Validate>; we want to be able to support query
499 my ($start,$stop,$query_arguments) = @_;
500 $stop = $stop || $start;
501 $query_arguments ||= '';
503 for my $bug ($start..$stop) {
504 push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
506 return join(', ',@output);
511 bug_linklist($separator,$class,@bugs)
513 Creates a set of links to C<@bugs> separated by C<$separator> with
514 link class C<$class>.
516 XXX Use L<Params::Validate>; we want to be able to support query
517 arguments here too; we should be able to combine bug_links and this
518 function into one. [Hell, bug_url should be one function with this one
525 my ($sep,$class,@bugs) = @_;
527 $class = qq(class="$class" );
529 return join($sep,map{qq(<a ${class}href=").
530 bug_url($_).qq(">#$_</a>)