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),
50 html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
51 qw(maybelink htmlize_addresslinks),
53 util => [qw(getparsedaddrs cgi_parameters)]
54 #status => [qw(getbugstatus)],
57 Exporter::export_ok_tags(qw(url html util));
58 $EXPORT_TAGS{all} = [@EXPORT_OK];
68 Sets the url params which will be used to generate urls.
77 my $url = Debbugs::URI->new($_[0]||'');
78 %URL_PARAMS = %{$url->query_form_hash};
85 bug_url($ref,mbox=>'yes',mboxstat=>'yes');
87 Constructs urls which point to a specific
89 XXX use Params::Validate
98 %params = (%URL_PARAMS,@_);
103 my $url = Debbugs::URI->new('bugreport.cgi?');
104 $url->query_form(bug=>$ref,%params);
105 return $url->as_string;
112 %params = (%URL_PARAMS,@_);
117 my $url = Debbugs::URI->new('pkgreport.cgi?');
118 $url->query_form(%params);
119 return $url->as_string;
124 version_url($package,$found,$fixed)
126 Creates a link to the version cgi script
131 my ($package,$found,$fixed) = @_;
132 my $url = Debbugs::URI->new('version.cgi?');
133 $url->query_form(package => $package,
137 return $url->as_string;
144 Escapes html entities by calling HTML::Entities::encode_entities;
151 return HTML::Entities::encode_entities($string)
154 =head2 cgi_parameters
158 Returns all of the cgi_parameters from a CGI script using CGI::Simple
163 my %options = validate_with(params => \@_,
164 spec => {query => {type => OBJECT,
167 single => {type => ARRAYREF,
170 default => {type => HASHREF,
175 my $q = $options{query};
177 @single{@{$options{single}}} = (1) x @{$options{single}};
179 for my $paramname ($q->param) {
180 if ($single{$paramname}) {
181 $param{$paramname} = $q->param($paramname);
184 $param{$paramname} = [$q->param($paramname)];
187 for my $default (keys %{$options{default}}) {
188 if (not exists $param{$default}) {
189 # We'll clone the reference here to avoid surprises later.
190 $param{$default} = ref($options{default}{$default})?
191 dclone($options{default}{$default}):$options{default}{$default};
199 my %common_bugusertags;
201 # =head2 get_bug_status
203 # my $status = getbugstatus($bug_num)
205 # my $status = getbugstatus($bug_num,$bug_index)
210 # sub get_bug_status {
211 # my ($bugnum,$bugidx) = @_;
215 # if (defined $bugidx and exists $bugidx->{$bugnum}) {
216 # %status = %{ $bugidx->{$bugnum} };
217 # $status{pending} = $status{ status };
218 # $status{id} = $bugnum;
222 # my $location = getbuglocation($bugnum, 'summary');
223 # return {} if not length $location;
224 # %status = %{ readbug( $bugnum, $location ) };
225 # $status{id} = $bugnum;
228 # if (defined $common_bugusertags{$bugnum}) {
229 # $status{keywords} = "" unless defined $status{keywords};
230 # $status{keywords} .= " " unless $status{keywords} eq "";
231 # $status{keywords} .= join(" ", @{$common_bugusertags{$bugnum}});
233 # $status{tags} = $status{keywords};
234 # my %tags = map { $_ => 1 } split ' ', $status{tags};
236 # $status{"package"} =~ s/\s*$//;
237 # $status{"package"} = 'unknown' if ($status{"package"} eq '');
238 # $status{"severity"} = 'normal' if ($status{"severity"} eq '');
240 # $status{"pending"} = 'pending';
241 # $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
242 # $status{"pending"} = 'pending-fixed' if ($tags{pending});
243 # $status{"pending"} = 'fixed' if ($tags{fixed});
246 # if (defined $common_version) {
247 # @versions = ($common_version);
248 # } elsif (defined $common_dist) {
249 # @versions = getversions($status{package}, $common_dist, $common_arch);
252 # # TODO: This should probably be handled further out for efficiency and
253 # # for more ease of distinguishing between pkg= and src= queries.
254 # my @sourceversions = makesourceversions($status{package}, $common_arch,
257 # if (@sourceversions) {
258 # # Resolve bugginess states (we might be looking at multiple
259 # # architectures, say). Found wins, then fixed, then absent.
260 # my $maxbuggy = 'absent';
261 # for my $version (@sourceversions) {
262 # my $buggy = buggyversion($bugnum, $version, \%status);
263 # if ($buggy eq 'found') {
264 # $maxbuggy = 'found';
266 # } elsif ($buggy eq 'fixed' and $maxbuggy ne 'found') {
267 # $maxbuggy = 'fixed';
270 # if ($maxbuggy eq 'absent') {
271 # $status{"pending"} = 'absent';
272 # } elsif ($maxbuggy eq 'fixed') {
273 # $status{"pending"} = 'done';
277 # if (length($status{done}) and
278 # (not @sourceversions or not @{$status{fixed_versions}})) {
279 # $status{"pending"} = 'done';
286 # htmlize_bugs(bugs=>[@bugs]);
289 htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}});
291 Turns a list of bugs into an html snippit of the 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 # Split a package string from the status file into a list of package names.
413 return unless defined $pkgs;
414 return map lc, split /[ \t?,()]+/, $pkgs;
418 =head2 htmlize_packagelinks
422 Given a scalar containing a list of packages separated by something
423 that L<Debbugs::CGI/splitpackages> can separate, returns a
424 formatted set of links to packages.
428 sub htmlize_packagelinks {
429 my ($pkgs,$strong) = @_;
430 return unless defined $pkgs and $pkgs ne '';
431 my @pkglist = splitpackages($pkgs);
434 my $openstrong = $strong ? '<strong>' : '';
435 my $closestrong = $strong ? '</strong>' : '';
437 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
440 '<a class="submitter" href="' . pkg_url(pkg=>$_||'') . '">' .
441 $openstrong . html_escape($_) . $closestrong . '</a>'
450 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
451 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
454 In the first form, links the link if it looks like a link. In the
455 second form, first splits based on the regex, then reassembles the
456 link, linking things that look like links. In the third form, rejoins
457 the split links with commas and spaces.
462 my ($links,$regex,$join) = @_;
463 $join = ' ' if not defined $join;
466 if (defined $regex) {
467 @segments = split $regex, $links;
470 @segments = ($links);
472 for my $in (@segments) {
473 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
474 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
476 push @return, html_escape($in);
479 return @return?join($join,@return):'';
483 =head2 htmlize_addresslinks
485 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
488 Generate a comma-separated list of HTML links to each address given in
489 $addresses, which should be a comma-separated list of RFC822
490 addresses. $urlfunc should be a reference to a function like mainturl
491 or submitterurl which returns the URL for each individual address.
496 sub htmlize_addresslinks {
497 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
498 $class = defined $class?qq(class="$class" ):'';
499 if (defined $addresses and $addresses ne '') {
500 my @addrs = getparsedaddrs($addresses);
501 my $prefix = (ref $prefixfunc) ?
502 $prefixfunc->(scalar @addrs):$prefixfunc;
505 { sprintf qq(<a ${class}).
507 $urlfunc->($_->address),
508 html_escape($_->format) ||
513 my $prefix = (ref $prefixfunc) ?
514 $prefixfunc->(1) : $prefixfunc;
515 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
516 $prefix, $urlfunc->('');
525 return () unless defined $addr;
526 return @{$_parsedaddrs{$addr}} if exists $_parsedaddrs{$addr};
527 @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
528 return @{$_parsedaddrs{$addr}};
535 bug_links($starting_bug,$stoping_bugs,);
537 Creates a set of links to bugs, starting with bug number
538 $starting_bug, and finishing with $stoping_bug; if only one bug is
539 passed, makes a link to only a single bug.
541 The content of the link is the bug number.
543 XXX Use L<Params::Validate>; we want to be able to support query
549 my ($start,$stop,$query_arguments) = @_;
550 $stop = $stop || $start;
551 $query_arguments ||= '';
553 for my $bug ($start..$stop) {
554 push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
556 return join(', ',@output);
561 bug_linklist($separator,$class,@bugs)
563 Creates a set of links to C<@bugs> separated by C<$separator> with
564 link class C<$class>.
566 XXX Use L<Params::Validate>; we want to be able to support query
567 arguments here too; we should be able to combine bug_links and this
568 function into one. [Hell, bug_url should be one function with this one
575 my ($sep,$class,@bugs) = @_;
577 $class = qq(class="$class" );
579 return join($sep,map{qq(<a ${class}href=").
580 bug_url($_).qq(">#$_</a>)