1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later version. See the
3 # file README and COPYING for more information.
5 # [Other people have contributed to this file; their copyrights should
7 # Copyright 2008 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::CGI::Pkgreport;
14 Debbugs::CGI::Pkgreport -- specific routines for the pkgreport cgi script
30 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
31 use base qw(Exporter);
34 use Params::Validate qw(validate_with :types);
36 use Debbugs::Config qw(:config :globals);
37 use Debbugs::CGI qw(:url :html :util);
38 use Debbugs::Common qw(:misc :util :date);
39 use Debbugs::Status qw(:status);
40 use Debbugs::Bugs qw(bug_filter);
41 use Debbugs::Packages qw(:mapping);
43 use Debbugs::Text qw(:templates);
45 use POSIX qw(strftime);
49 ($VERSION) = q$Revision: 494 $ =~ /^Revision:\s+([^\s+])/;
50 $DEBUG = 0 unless defined $DEBUG;
53 %EXPORT_TAGS = (html => [qw(short_bug_status_html pkg_htmlizebugs),
55 qw(pkg_htmlselectyesno pkg_htmlselectsuite),
56 qw(buglinklist pkg_htmlselectarch)
58 misc => [qw(generate_package_info make_order_list),
60 qw(get_bug_order_index determine_ordering),
64 Exporter::export_ok_tags(keys %EXPORT_TAGS);
65 $EXPORT_TAGS{all} = [@EXPORT_OK];
68 =head2 generate_package_info
70 generate_package_info($srcorbin,$package)
72 Generates the informational bits for a package and returns it
76 sub generate_package_info{
77 my %param = validate_with(params => \@_,
78 spec => {binary => {type => BOOLEAN,
81 package => {type => SCALAR|ARRAYREF,
83 options => {type => HASHREF,
85 bugs => {type => ARRAYREF,
90 my $output_scalar = '';
91 my $output = globify_scalar(\$output_scalar);
93 my $package = $param{package};
95 my %pkgsrc = %{getpkgsrc()};
96 my $srcforpkg = $package;
97 if ($param{binary} and exists $pkgsrc{$package}
98 and defined $pkgsrc{$package}) {
99 $srcforpkg = $pkgsrc{$package};
102 my $showpkg = html_escape($package);
103 my $maintainers = getmaintainers();
104 my $maint = $maintainers->{$srcforpkg};
105 if (defined $maint) {
106 print {$output} '<p>';
107 print {$output} htmlize_maintlinks(sub { $_[0] == 1 ? "Maintainer for $showpkg is "
108 : "Maintainers for $showpkg are "
111 print {$output} ".</p>\n";
114 print {$output} "<p>No maintainer for $showpkg. Please do not report new bugs against this package.</p>\n";
116 my @pkgs = getsrcpkgs($srcforpkg);
117 @pkgs = grep( !/^\Q$package\E$/, @pkgs );
120 if ($param{binary}) {
121 print {$output} "<p>You may want to refer to the following packages that are part of the same source:\n";
124 print {$output} "<p>You may want to refer to the following individual bug pages:\n";
126 #push @pkgs, $src if ( $src && !grep(/^\Q$src\E$/, @pkgs) );
127 print {$output} scalar package_links(package=>[@pkgs]);
128 print {$output} ".\n";
131 my $pseudodesc = getpseudodesc();
132 if ($package and defined($pseudodesc) and exists($pseudodesc->{$package})) {
133 push @references, "to the <a href=\"http://${debbugs::gWebDomain}/pseudo-packages${debbugs::gHTMLSuffix}\">".
134 "list of other pseudo-packages</a>";
137 if ($package and defined $gPackagePages) {
138 push @references, sprintf "to the <a href=\"%s\">%s package page</a>",
139 html_escape("http://${gPackagePages}/$package"), html_escape("$package");
141 if (defined $gSubscriptionDomain) {
142 my $ptslink = $param{binary} ? $srcforpkg : $package;
143 push @references, q(to the <a href="http://).html_escape("$gSubscriptionDomain/$ptslink").q(">Package Tracking System</a>);
145 # Only output this if the source listing is non-trivial.
146 if ($param{binary} and $srcforpkg) {
148 "to the source package ".
149 package_links(src=>$srcforpkg,
150 options => $param{options}) .
155 $references[$#references] = "or $references[$#references]" if @references > 1;
156 print {$output} "<p>You might like to refer ", join(", ", @references), ".</p>\n";
158 if (defined $param{maint} || defined $param{maintenc}) {
159 print {$output} "<p>If you find a bug not listed here, please\n";
160 printf {$output} "<a href=\"%s\">report it</a>.</p>\n",
161 html_escape("http://${debbugs::gWebDomain}/Reporting${debbugs::gHTMLSuffix}");
163 if (not $maint and not @{$param{bugs}}) {
164 print {$output} "<p>There is no record of the " . html_escape($package) .
165 ($param{binary} ? " package" : " source package") .
166 ", and no bugs have been filed against it.</p>";
168 return $output_scalar;
172 =head2 short_bug_status_html
174 print short_bug_status_html(status => read_bug(bug => 5),
180 =item status -- status hashref as returned by read_bug
182 =item options -- hashref of options to pass to package_links (defaults
185 =item bug_options -- hashref of options to pass to bug_links (default
188 =item snippet -- optional snippet of information about the bug to
198 sub short_bug_status_html {
199 my %param = validate_with(params => \@_,
200 spec => {status => {type => HASHREF,
202 options => {type => HASHREF,
205 bug_options => {type => HASHREF,
208 snippet => {type => SCALAR,
214 my %status = %{$param{status}};
216 $status{tags_array} = [sort(split(/\s+/, $status{tags}))];
217 $status{date_text} = strftime('%a, %e %b %Y %T UTC', gmtime($status{date}));
218 $status{mergedwith_array} = [split(/ /,$status{mergedwith})];
220 my @blockedby= split(/ /, $status{blockedby});
221 $status{blockedby_array} = [];
222 if (@blockedby && $status{"pending"} ne 'fixed' && ! length($status{done})) {
223 for my $b (@blockedby) {
224 my %s = %{get_bug_status($b)};
225 next if $s{"pending"} eq 'fixed' || length $s{done};
226 push @{$status{blockedby_array}},{bug_num => $b, subject => $s{subject}, status => \%s};
230 my @blocks= split(/ /, $status{blocks});
231 $status{blocks_array} = [];
232 if (@blocks && $status{"pending"} ne 'fixed' && ! length($status{done})) {
233 for my $b (@blocks) {
234 my %s = %{get_bug_status($b)};
235 next if $s{"pending"} eq 'fixed' || length $s{done};
236 push @{$status{blocks_array}}, {bug_num => $b, subject => $s{subject}, status => \%s};
241 return fill_in_template(template => 'cgi/short_bug_status',
242 variables => {status => \%status,
243 isstrongseverity => \&Debbugs::Status::isstrongseverity,
244 html_escape => \&Debbugs::CGI::html_escape,
245 looks_like_number => \&Scalar::Util::looks_like_number,
247 hole_var => {'&package_links' => \&Debbugs::CGI::package_links,
248 '&bug_links' => \&Debbugs::CGI::bug_links,
249 '&version_url' => \&Debbugs::CGI::version_url,
250 '&secs_to_english' => \&Debbugs::Common::secs_to_english,
251 '&strftime' => \&POSIX::strftime,
258 if ($status{severity} eq 'normal') {
261 elsif (isstrongseverity($status{severity})) {
262 $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
265 $showseverity = "Severity: <em>$status{severity}</em>;\n";
268 $result .= package_links(package => $status{package},
269 options => $param{options},
272 my $showversions = '';
273 if (@{$status{found_versions}}) {
274 my @found = @{$status{found_versions}};
275 $showversions .= join ', ', map {s{/}{ }; html_escape($_)} @found;
277 if (@{$status{fixed_versions}}) {
278 $showversions .= '; ' if length $showversions;
279 $showversions .= '<strong>fixed</strong>: ';
280 my @fixed = @{$status{fixed_versions}};
281 $showversions .= join ', ', map {s{/}{ }; html_escape($_)} @fixed;
283 $result .= ' (<a href="'.
284 version_url(package => $status{package},
285 found => $status{found_versions},
286 fixed => $status{fixed_versions},
287 ).qq{">$showversions</a>)} if length $showversions;
290 $result .= $showseverity;
291 $result .= "Reported by: ".package_links(submitter=>$status{originator},
292 class => "submitter",
294 $result .= ";\nOwned by: " . package_links(owner => $status{owner},
295 class => "submitter",
297 if length $status{owner};
298 $result .= ";\nTags: <strong>"
299 . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
301 if (length($status{tags}));
303 $result .= (length($status{mergedwith})?";\nMerged with ":"") .
304 bug_links(bug => [split(/ /,$status{mergedwith})],
305 class => "submitter",
307 $result .= (length($status{blockedby})?";\nBlocked by ":"") .
308 bug_links(bug => [split(/ /,$status{blockedby})],
309 class => "submitter",
311 $result .= (length($status{blocks})?";\nBlocks ":"") .
312 bug_links(bug => [split(/ /,$status{blocks})],
313 class => "submitter",
316 if (length($status{done})) {
317 $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
318 my $days = bug_archiveable(bug => $status{id},
322 if ($days >= 0 and defined $status{location} and $status{location} ne 'archive') {
323 $result .= ";\n<strong>Can be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
325 elsif (defined $status{location} and $status{location} eq 'archived') {
326 $result .= ";\n<strong>Archived.</strong>";
330 unless (length($status{done})) {
331 if (length($status{forwarded})) {
332 $result .= ";\n<strong>Forwarded</strong> to "
335 split /\,\s+/,$status{forwarded}
338 # Check the age of the logfile
339 my ($days_last,$eng_last) = secs_to_english(time - $status{log_modified});
340 my ($days,$eng) = secs_to_english(time - $status{date});
345 $font = "em" if ($days > 30);
346 $font = "strong" if ($days > 60);
347 $efont = "</$font>" if ($font);
348 $font = "<$font>" if ($font);
350 $result .= ";\n ${font}$eng old$efont";
352 if ($days_last > 7) {
355 $font = "em" if ($days_last > 30);
356 $font = "strong" if ($days_last > 60);
357 $efont = "</$font>" if ($font);
358 $font = "<$font>" if ($font);
360 $result .= ";\n ${font}Modified $eng_last ago$efont";
370 sub pkg_htmlizebugs {
371 my %param = validate_with(params => \@_,
372 spec => {bugs => {type => ARRAYREF,
374 names => {type => ARRAYREF,
376 title => {type => ARRAYREF,
378 prior => {type => ARRAYREF,
380 order => {type => ARRAYREF,
382 ordering => {type => SCALAR,
384 bugusertags => {type => HASHREF,
387 bug_rev => {type => BOOLEAN,
390 bug_order => {type => SCALAR,
392 repeatmerged => {type => BOOLEAN,
395 include => {type => ARRAYREF,
398 exclude => {type => ARRAYREF,
401 this => {type => SCALAR,
404 options => {type => HASHREF,
409 my @bugs = @{$param{bugs}};
414 my $footer = "<h2 class=\"outstanding\">Summary</h2>\n";
416 my @dummy = ($gRemoveAge); #, @gSeverityList, @gSeverityDisplay); #, $gHTMLExpireNote);
419 return "<HR><H2>No reports found!</H2></HR>\n";
422 if ( $param{bug_rev} ) {
423 @bugs = sort {$b<=>$a} @bugs;
426 @bugs = sort {$a<=>$b} @bugs;
431 'show_list_header' => 1,
432 'show_list_footer' => 1,
436 # Make the include/exclude map
439 for my $include (make_list($param{include})) {
440 next unless defined $include;
441 my ($key,$value) = split /\s*:\s*/,$include,2;
442 unless (defined $value) {
446 push @{$include{$key}}, split /\s*,\s*/, $value;
448 for my $exclude (make_list($param{exclude})) {
449 next unless defined $exclude;
450 my ($key,$value) = split /\s*:\s*/,$exclude,2;
451 unless (defined $value) {
455 push @{$exclude{$key}}, split /\s*,\s*/, $value;
458 foreach my $bug (@bugs) {
459 my %status = %{get_bug_status(bug=>$bug,
460 (exists $param{dist}?(dist => $param{dist}):()),
461 bugusertags => $param{bugusertags},
462 (exists $param{version}?(version => $param{version}):()),
463 (exists $param{arch}?(arch => $param{arch}):(arch => $config{default_architectures})),
466 next if bug_filter(bug => $bug,
468 repeat_merged => $param{repeatmerged},
469 seen_merged => \%seenmerged,
470 (keys %include ? (include => \%include):()),
471 (keys %exclude ? (exclude => \%exclude):()),
474 my $html = "<li>"; #<a href=\"%s\">#%d: %s</a>\n<br>",
475 #bug_url($bug), $bug, html_escape($status{subject});
476 $html .= short_bug_status_html(status => \%status,
477 options => $param{options},
479 push @status, [ $bug, \%status, $html ];
481 if ($param{bug_order} eq 'age') {
483 @status = sort {$a->[1]{log_modified} <=> $b->[1]{log_modified}} @status;
485 elsif ($param{bug_order} eq 'agerev') {
486 @status = sort {$b->[1]{log_modified} <=> $a->[1]{log_modified}} @status;
488 for my $entry (@status) {
490 for my $i (0..$#{$param{prior}}) {
491 my $v = get_bug_order_index($param{prior}[$i], $entry->[1]);
492 $count{"g_${i}_${v}"}++;
495 $section{$key} .= $entry->[2];
500 if ($param{ordering} eq "raw") {
501 $result .= "<UL class=\"bugs\">\n" . join("", map( { $_->[ 2 ] } @status ) ) . "</UL>\n";
504 $header .= "<div class=\"msgreceived\">\n<ul>\n";
505 my @keys_in_order = ("");
506 for my $o (@{$param{order}}) {
507 push @keys_in_order, "X";
508 while ((my $k = shift @keys_in_order) ne "X") {
511 push @keys_in_order, "${k}_${k2}";
515 for my $order (@keys_in_order) {
516 next unless defined $section{$order};
517 my @ttl = split /_/, $order;
519 my $title = $param{title}[0]->[$ttl[0]] . " bugs";
522 $title .= join("; ", grep {($_ || "") ne ""}
523 map { $param{title}[$_]->[$ttl[$_]] } 1..$#ttl);
525 $title = html_escape($title);
527 my $count = $count{"_$order"};
528 my $bugs = $count == 1 ? "bug" : "bugs";
530 $header .= "<li><a href=\"#$order\">$title</a> ($count $bugs)</li>\n";
531 if ($common{show_list_header}) {
532 my $count = $count{"_$order"};
533 my $bugs = $count == 1 ? "bug" : "bugs";
534 $result .= "<H2 CLASS=\"outstanding\"><a name=\"$order\"></a>$title ($count $bugs)</H2>\n";
537 $result .= "<H2 CLASS=\"outstanding\">$title</H2>\n";
539 $result .= "<div class=\"msgreceived\">\n<UL class=\"bugs\">\n";
540 $result .= "\n\n\n\n";
541 $result .= $section{$order};
542 $result .= "\n\n\n\n";
543 $result .= "</UL>\n</div>\n";
545 $header .= "</ul></div>\n";
547 $footer .= "<div class=\"msgreceived\">\n<ul>\n";
548 for my $i (0..$#{$param{prior}}) {
549 my $local_result = '';
550 foreach my $key ( @{$param{order}[$i]} ) {
551 my $count = $count{"g_${i}_$key"};
552 next if !$count or !$param{title}[$i]->[$key];
553 $local_result .= "<li>$count $param{title}[$i]->[$key]</li>\n";
555 if ( $local_result ) {
556 $footer .= "<li>$param{names}[$i]<ul>\n$local_result</ul></li>\n";
559 $footer .= "</ul>\n</div>\n";
562 $result = $header . $result if ( $common{show_list_header} );
563 $result .= $footer if ( $common{show_list_footer} );
568 return fill_in_template(template=>'cgi/pkgreport_javascript',
572 sub pkg_htmlselectyesno {
573 my ($name, $n, $y, $default) = @_;
574 return sprintf('<select name="%s"><option value=no%s>%s</option><option value=yes%s>%s</option></select>', $name, ($default ? "" : " selected"), $n, ($default ? " selected" : ""), $y);
577 sub pkg_htmlselectsuite {
578 my $id = sprintf "b_%d_%d_%d", $_[0], $_[1], $_[2];
579 my @suites = ("stable", "testing", "unstable", "experimental");
580 my %suiteaka = ("stable", "etch", "testing", "lenny", "unstable", "sid");
581 my $defaultsuite = "unstable";
583 my $result = sprintf '<select name=dist id="%s">', $id;
584 for my $s (@suites) {
585 $result .= sprintf '<option value="%s"%s>%s%s</option>',
586 $s, ($defaultsuite eq $s ? " selected" : ""),
587 $s, (defined $suiteaka{$s} ? " (" . $suiteaka{$s} . ")" : "");
589 $result .= '</select>';
593 sub pkg_htmlselectarch {
594 my $id = sprintf "b_%d_%d_%d", $_[0], $_[1], $_[2];
595 my @arches = qw(alpha amd64 arm hppa i386 ia64 m68k mips mipsel powerpc s390 sparc);
597 my $result = sprintf '<select name=arch id="%s">', $id;
598 $result .= '<option value="any">any architecture</option>';
599 for my $a (@arches) {
600 $result .= sprintf '<option value="%s">%s</option>', $a, $a;
602 $result .= '</select>';
608 return html_escape(pkg_url(map {exists $param{$_}?($_,$param{$_}):()}
609 qw(archive repeatmerged mindays maxdays),
610 qw(version dist arch package src tag maint submitter)
615 sub make_order_list {
619 if ($vfull =~ m/^([^:]+):(.*)$/) {
621 for my $vv (split /,/, $2) {
626 for my $v (split /,/, $vfull) {
627 next unless $v =~ m/.=./;
631 push @x, ""; # catch all
635 sub get_bug_order_index {
641 %tags = map { $_, 1 } split / /, $status->{"tags"}
642 if defined $status->{"tags"};
644 for my $el (@${order}) {
647 for my $item (split /[+]/, $el) {
648 my ($f, $v) = split /=/, $item, 2;
649 next unless (defined $f and defined $v);
651 $isokay = 1 if (defined $status->{$f} and $v eq $status->{$f});
652 $isokay = 1 if ($f eq "tag" && defined $tags{$v});
667 my ($prefix, $infix, @els) = @_;
668 return '' if not @els;
669 return $prefix . bug_linklist($infix,'submitter',@els);
673 # sets: my @names; my @prior; my @title; my @order;
675 sub determine_ordering {
676 my %param = validate_with(params => \@_,
677 spec => {cats => {type => HASHREF,
679 param => {type => HASHREF,
681 ordering => {type => SCALARREF,
683 names => {type => ARRAYREF,
685 pend_rev => {type => BOOLEAN,
688 sev_rev => {type => BOOLEAN,
691 prior => {type => ARRAYREF,
693 title => {type => ARRAYREF,
695 order => {type => ARRAYREF,
699 $param{cats}{status}[0]{ord} = [ reverse @{$param{cats}{status}[0]{ord}} ]
700 if ($param{pend_rev});
701 $param{cats}{severity}[0]{ord} = [ reverse @{$param{cats}{severity}[0]{ord}} ]
702 if ($param{sev_rev});
705 if (defined $param{param}{"pri0"}) {
708 while (defined $param{param}{"pri$i"}) {
711 my ($pri) = make_list($param{param}{"pri$i"});
712 if ($pri =~ m/^([^:]*):(.*)$/) {
713 $h->{"nam"} = $1; # overridden later if necesary
714 $h->{"pri"} = [ map { "$1=$_" } (split /,/, $2) ];
717 $h->{"pri"} = [ split /,/, $pri ];
720 ($h->{"nam"}) = make_list($param{param}{"nam$i"})
721 if (defined $param{param}{"nam$i"});
722 $h->{"ord"} = [ map {split /\s*,\s*/} make_list($param{param}{"ord$i"}) ]
723 if (defined $param{param}{"ord$i"});
724 $h->{"ttl"} = [ map {split /\s*,\s*/} make_list($param{param}{"ttl$i"}) ]
725 if (defined $param{param}{"ttl$i"});
730 $param{cats}{"_"} = [@c];
731 ${$param{ordering}} = "_";
734 ${$param{ordering}} = "normal" unless defined $param{cats}{${$param{ordering}}};
740 for my $c (@{$cats->{$o}}) {
741 if (ref($c) eq "HASH") {
745 push @res, get_ordering($cats, $c);
750 my @cats = get_ordering($param{cats}, ${$param{ordering}});
754 $expr =~ s/[+]/ and /g;
755 $expr =~ s/[a-z]+=//g;
762 push @{$param{prior}}, $c->{"pri"};
763 push @{$param{names}}, ($c->{"nam"} || "Bug attribute #" . $i);
764 if (defined $c->{"ord"}) {
765 push @{$param{order}}, $c->{"ord"};
768 push @{$param{order}}, [ 0..$#{$param{prior}[-1]} ];
770 my @t = @{ $c->{"ttl"} } if defined $c->{ttl};
771 if (@t < $#{$param{prior}[-1]}) {
772 push @t, map { toenglish($param{prior}[-1][$_]) } @t..($#{$param{prior}[-1]});
774 push @t, $c->{"def"} || "";
775 push @{$param{title}}, [@t];