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);
42 ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
43 $DEBUG = 0 unless defined $DEBUG;
46 %EXPORT_TAGS = (url => [qw(bug_url bug_links bug_linklist maybelink),
47 qw(set_url_params pkg_url version_url),
49 html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
50 qw(maybelink htmlize_addresslinks),
52 util => [qw(getparsedaddrs)]
53 #status => [qw(getbugstatus)],
56 Exporter::export_ok_tags(qw(url html util));
57 $EXPORT_TAGS{all} = [@EXPORT_OK];
67 Sets the url params which will be used to generate urls.
76 my $url = Debbugs::URI->new($_[0]||'');
77 %URL_PARAMS = %{$url->query_form_hash};
84 bug_url($ref,mbox=>'yes',mboxstat=>'yes');
86 Constructs urls which point to a specific
88 XXX use Params::Validate
97 %params = (%URL_PARAMS,@_);
102 my $url = Debbugs::URI->new('bugreport.cgi?');
103 $url->query_form(bug=>$ref,%params);
104 return $url->as_string;
111 %params = (%URL_PARAMS,@_);
116 my $url = Debbugs::URI->new('pkgreport.cgi?');
117 $url->query_form(%params);
118 return $url->as_string;
123 version_url($package,$found,$fixed)
125 Creates a link to the version cgi script
130 my ($package,$found,$fixed) = @_;
131 my $url = Debbugs::URI->new('version.cgi?');
132 $url->query_form(package => $package,
136 return $url->as_string;
143 Escapes html entities by calling HTML::Entities::encode_entities;
150 return HTML::Entities::encode_entities($string)
153 my %common_bugusertags;
155 # =head2 get_bug_status
157 # my $status = getbugstatus($bug_num)
159 # my $status = getbugstatus($bug_num,$bug_index)
164 # sub get_bug_status {
165 # my ($bugnum,$bugidx) = @_;
169 # if (defined $bugidx and exists $bugidx->{$bugnum}) {
170 # %status = %{ $bugidx->{$bugnum} };
171 # $status{pending} = $status{ status };
172 # $status{id} = $bugnum;
176 # my $location = getbuglocation($bugnum, 'summary');
177 # return {} if not length $location;
178 # %status = %{ readbug( $bugnum, $location ) };
179 # $status{id} = $bugnum;
182 # if (defined $common_bugusertags{$bugnum}) {
183 # $status{keywords} = "" unless defined $status{keywords};
184 # $status{keywords} .= " " unless $status{keywords} eq "";
185 # $status{keywords} .= join(" ", @{$common_bugusertags{$bugnum}});
187 # $status{tags} = $status{keywords};
188 # my %tags = map { $_ => 1 } split ' ', $status{tags};
190 # $status{"package"} =~ s/\s*$//;
191 # $status{"package"} = 'unknown' if ($status{"package"} eq '');
192 # $status{"severity"} = 'normal' if ($status{"severity"} eq '');
194 # $status{"pending"} = 'pending';
195 # $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
196 # $status{"pending"} = 'pending-fixed' if ($tags{pending});
197 # $status{"pending"} = 'fixed' if ($tags{fixed});
200 # if (defined $common_version) {
201 # @versions = ($common_version);
202 # } elsif (defined $common_dist) {
203 # @versions = getversions($status{package}, $common_dist, $common_arch);
206 # # TODO: This should probably be handled further out for efficiency and
207 # # for more ease of distinguishing between pkg= and src= queries.
208 # my @sourceversions = makesourceversions($status{package}, $common_arch,
211 # if (@sourceversions) {
212 # # Resolve bugginess states (we might be looking at multiple
213 # # architectures, say). Found wins, then fixed, then absent.
214 # my $maxbuggy = 'absent';
215 # for my $version (@sourceversions) {
216 # my $buggy = buggyversion($bugnum, $version, \%status);
217 # if ($buggy eq 'found') {
218 # $maxbuggy = 'found';
220 # } elsif ($buggy eq 'fixed' and $maxbuggy ne 'found') {
221 # $maxbuggy = 'fixed';
224 # if ($maxbuggy eq 'absent') {
225 # $status{"pending"} = 'absent';
226 # } elsif ($maxbuggy eq 'fixed') {
227 # $status{"pending"} = 'done';
231 # if (length($status{done}) and
232 # (not @sourceversions or not @{$status{fixed_versions}})) {
233 # $status{"pending"} = 'done';
240 # htmlize_bugs(bugs=>[@bugs]);
243 htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}});
245 Turns a list of bugs into an html snippit of the bugs.
253 for my $bug (@bugs) {
254 my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
255 bug_url($bug->{bug}), $bug->{bug}, html_escape($bug->{status}{subject});
256 $html .= htmlize_bugstatus($bug->{status}) . "\n";
262 sub htmlize_bugstatus {
263 my %status = %{$_[0]};
268 if ($status{severity} eq $config{default_severity}) {
270 } elsif (isstrongseverity($status{severity})) {
271 $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
273 $showseverity = "Severity: <em>$status{severity}</em>;\n";
276 $result .= htmlize_packagelinks($status{"package"}, 1);
278 my $showversions = '';
279 if (@{$status{found_versions}}) {
280 my @found = @{$status{found_versions}};
282 s{/}{ } foreach @found;
283 $showversions .= join ', ', map html_escape($_), @found;
285 if (@{$status{fixed_versions}}) {
286 $showversions .= '; ' if length $showversions;
287 $showversions .= '<strong>fixed</strong>: ';
288 my @fixed = @{$status{fixed_versions}};
289 $showversions .= join ', ', map {s#/##; html_escape($_)} @fixed;
291 $result .= " ($showversions)" if length $showversions;
294 $result .= $showseverity;
295 $result .= htmlize_addresslinks("Reported by: ", \&submitterurl,
296 $status{originator});
297 $result .= ";\nOwned by: " . html_escape($status{owner})
298 if length $status{owner};
299 $result .= ";\nTags: <strong>"
300 . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
302 if (length($status{tags}));
304 $result .= ";\nMerged with ".
307 split(/ /,$status{mergedwith}))
308 if length $status{mergedwith};
309 $result .= ";\nBlocked by ".
312 split(/ /,$status{blockedby}))
313 if length $status{blockedby};
314 $result .= ";\nBlocks ".
317 split(/ /,$status{blocks})
319 if length $status{blocks};
322 if (length($status{done})) {
323 $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
324 $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
326 $result .= ";\n<strong>Will be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
328 $result .= ";\n<strong>Archived</strong>";
332 if (length($status{forwarded})) {
333 $result .= ";\n<strong>Forwarded</strong> to "
334 . maybelink($status{forwarded});
336 my $daysold = int((time - $status{date}) / 86400); # seconds to days
340 $font = "em" if ($daysold > 30);
341 $font = "strong" if ($daysold > 60);
342 $efont = "</$font>" if ($font);
343 $font = "<$font>" if ($font);
345 my $yearsold = int($daysold / 365);
346 $daysold -= $yearsold * 365;
348 $result .= ";\n $font";
350 push @age, "1 year" if ($yearsold == 1);
351 push @age, "$yearsold years" if ($yearsold > 1);
352 push @age, "1 day" if ($daysold == 1);
353 push @age, "$daysold days" if ($daysold > 1);
354 $result .= join(" and ", @age);
355 $result .= " old$efont";
364 # Split a package string from the status file into a list of package names.
367 return unless defined $pkgs;
368 return map lc, split /[ \t?,()]+/, $pkgs;
372 =head2 htmlize_packagelinks
376 Given a scalar containing a list of packages separated by something
377 that L<Debbugs::CGI/splitpackages> can separate, returns a
378 formatted set of links to packages.
382 sub htmlize_packagelinks {
383 my ($pkgs,$strong) = @_;
384 return unless defined $pkgs and $pkgs ne '';
385 my @pkglist = splitpackages($pkgs);
388 my $openstrong = $strong ? '<strong>' : '';
389 my $closestrong = $strong ? '</strong>' : '';
391 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
394 '<a class="submitter" href="' . pkg_url(pkg=>$_||'') . '">' .
395 $openstrong . html_escape($_) . $closestrong . '</a>'
404 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
405 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
408 In the first form, links the link if it looks like a link. In the
409 second form, first splits based on the regex, then reassembles the
410 link, linking things that look like links. In the third form, rejoins
411 the split links with commas and spaces.
416 my ($links,$regex,$join) = @_;
417 $join = ' ' if not defined $join;
420 if (defined $regex) {
421 @segments = split $regex, $links;
424 @segments = ($links);
426 for my $in (@segments) {
427 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
428 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
430 push @return, html_escape($in);
433 return @return?join($join,@return):'';
437 =head2 htmlize_addresslinks
439 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
442 Generate a comma-separated list of HTML links to each address given in
443 $addresses, which should be a comma-separated list of RFC822
444 addresses. $urlfunc should be a reference to a function like mainturl
445 or submitterurl which returns the URL for each individual address.
450 sub htmlize_addresslinks {
451 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
452 $class = defined $class?qq(class="$class" ):'';
453 if (defined $addresses and $addresses ne '') {
454 my @addrs = getparsedaddrs($addresses);
455 my $prefix = (ref $prefixfunc) ?
456 $prefixfunc->(scalar @addrs):$prefixfunc;
459 { sprintf qq(<a ${class}).
461 $urlfunc->($_->address),
462 html_escape($_->format) ||
467 my $prefix = (ref $prefixfunc) ?
468 $prefixfunc->(1) : $prefixfunc;
469 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
470 $prefix, $urlfunc->('');
479 return () unless defined $addr;
480 return @{$_parsedaddrs{$addr}} if exists $_parsedaddrs{$addr};
481 @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
482 return @{$_parsedaddrs{$addr}};
489 bug_links($starting_bug,$stoping_bugs,);
491 Creates a set of links to bugs, starting with bug number
492 $starting_bug, and finishing with $stoping_bug; if only one bug is
493 passed, makes a link to only a single bug.
495 The content of the link is the bug number.
497 XXX Use L<Params::Validate>; we want to be able to support query
503 my ($start,$stop,$query_arguments) = @_;
504 $stop = $stop || $start;
505 $query_arguments ||= '';
507 for my $bug ($start..$stop) {
508 push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
510 return join(', ',@output);
515 bug_linklist($separator,$class,@bugs)
517 Creates a set of links to C<@bugs> separated by C<$separator> with
518 link class C<$class>.
520 XXX Use L<Params::Validate>; we want to be able to support query
521 arguments here too; we should be able to combine bug_links and this
522 function into one. [Hell, bug_url should be one function with this one
529 my ($sep,$class,@bugs) = @_;
531 $class = qq(class="$class" );
533 return join($sep,map{qq(<a ${class}href=").
534 bug_url($_).qq(">#$_</a>)