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 Exporter qw(import);
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);
44 use Encode qw(decode_utf8);
46 use POSIX qw(strftime);
50 ($VERSION) = q$Revision: 494 $ =~ /^Revision:\s+([^\s+])/;
51 $DEBUG = 0 unless defined $DEBUG;
54 %EXPORT_TAGS = (html => [qw(short_bug_status_html pkg_htmlizebugs),
56 misc => [qw(generate_package_info),
57 qw(determine_ordering),
61 Exporter::export_ok_tags(keys %EXPORT_TAGS);
62 $EXPORT_TAGS{all} = [@EXPORT_OK];
65 =head2 generate_package_info
67 generate_package_info($srcorbin,$package)
69 Generates the informational bits for a package and returns it
73 sub generate_package_info{
74 my %param = validate_with(params => \@_,
75 spec => {binary => {type => BOOLEAN,
78 package => {type => SCALAR,#|ARRAYREF,
80 options => {type => HASHREF,
82 bugs => {type => ARRAYREF,
84 schema => {type => OBJECT,
90 my $output_scalar = '';
91 my $output = globify_scalar(\$output_scalar);
93 my $package = $param{package};
95 my %pkgsrc = %{getpkgsrc()};
96 my $srcforpkg = $package;
99 binary_to_source(source_only => 1,
102 hash_slice(%param,qw(schema)),
106 my $showpkg = html_escape($package);
107 my @maint = package_maintainer($param{binary}?'binary':'source',
109 hash_slice(%param,qw(schema)),
112 print {$output} '<p>';
113 print {$output} (@maint > 1? "Maintainer for $showpkg is "
114 : "Maintainers for $showpkg are ") .
115 package_links(maintainer => \@maint);
116 print {$output} ".</p>\n";
119 print {$output} "<p>There is no maintainer for $showpkg. ".
120 "This means that this package no longer exists (or never existed). ".
121 "Please do not report new bugs against this package. </p>\n";
123 my @pkgs = source_to_binary(source => $srcforpkg,
124 hash_slice(%param,qw(schema)),
126 # if there are distributions, only bother to
127 # show packages which are currently in a
129 @{$config{distributions}//[]} ?
130 (dist => [@{$config{distributions}}]) : (),
132 @pkgs = grep( !/^\Q$package\E$/, @pkgs );
135 if ($param{binary}) {
136 print {$output} "<p>You may want to refer to the following packages that are part of the same source:\n";
139 print {$output} "<p>You may want to refer to the following individual bug pages:\n";
141 #push @pkgs, $src if ( $src && !grep(/^\Q$src\E$/, @pkgs) );
142 print {$output} scalar package_links(package=>[@pkgs]);
143 print {$output} ".\n";
146 my $pseudodesc = getpseudodesc();
147 if ($package and defined($pseudodesc) and exists($pseudodesc->{$package})) {
148 push @references, "to the <a href=\"$config{web_domain}/pseudo-packages$config{html_suffix}\">".
149 "list of other pseudo-packages</a>";
152 if ($package and defined $config{package_pages} and length $config{package_pages}) {
153 push @references, sprintf "to the <a href=\"%s\">%s package page</a>",
154 html_escape("$config{package_pages}/$package"), html_escape("$package");
156 if (defined $config{package_tracking_domain} and
157 length $config{package_tracking_domain}) {
158 my $ptslink = $param{binary} ? $srcforpkg : $package;
159 # the pts only wants the source, and doesn't care about src: (#566089)
160 $ptslink =~ s/^src://;
161 push @references, q(to the <a href=").html_escape("$config{package_tracking_domain}/$ptslink").q(">Package Tracking System</a>);
163 # Only output this if the source listing is non-trivial.
164 if ($param{binary} and $srcforpkg) {
166 "to the source package ".
167 package_links(src=>$srcforpkg,
168 options => $param{options}) .
173 $references[$#references] = "or $references[$#references]" if @references > 1;
174 print {$output} "<p>You might like to refer ", join(", ", @references), ".</p>\n";
177 print {$output} "<p>If you find a bug not listed here, please\n";
178 printf {$output} "<a href=\"%s\">report it</a>.</p>\n",
179 html_escape("$config{web_domain}/Reporting$config{html_suffix}");
181 return decode_utf8($output_scalar);
185 =head2 short_bug_status_html
187 print short_bug_status_html(status => read_bug(bug => 5),
193 =item status -- status hashref as returned by read_bug
195 =item options -- hashref of options to pass to package_links (defaults
198 =item bug_options -- hashref of options to pass to bug_links (default
201 =item snippet -- optional snippet of information about the bug to
211 sub short_bug_status_html {
212 my %param = validate_with(params => \@_,
213 spec => {status => {type => HASHREF,
215 options => {type => HASHREF,
218 bug_options => {type => HASHREF,
221 snippet => {type => SCALAR,
227 my %status = %{$param{status}};
229 $status{tags_array} = [sort(split(/\s+/, $status{tags}))];
230 $status{date_text} = strftime('%a, %e %b %Y %T UTC', gmtime($status{date}));
231 $status{mergedwith_array} = [split(/ /,$status{mergedwith})];
233 my @blockedby= split(/ /, $status{blockedby});
234 $status{blockedby_array} = [];
235 if (@blockedby && $status{"pending"} ne 'fixed' && ! length($status{done})) {
236 for my $b (@blockedby) {
237 my %s = %{get_bug_status($b)};
238 next if (defined $s{pending} and $s{pending} eq 'fixed') or (defined $s{done} and length $s{done});
239 push @{$status{blockedby_array}},{bug_num => $b, subject => $s{subject}, status => \%s};
243 my @blocks= split(/ /, $status{blocks});
244 $status{blocks_array} = [];
245 if (@blocks && $status{"pending"} ne 'fixed' && ! length($status{done})) {
246 for my $b (@blocks) {
247 my %s = %{get_bug_status($b)};
248 next if (defined $s{pending} and $s{pending} eq 'fixed') or (defined $s{done} and length $s{done});
249 push @{$status{blocks_array}}, {bug_num => $b, subject => $s{subject}, status => \%s};
252 my $days = bug_archiveable(bug => $status{id},
256 $status{archive_days} = $days;
257 return fill_in_template(template => 'cgi/short_bug_status',
258 variables => {status => \%status,
259 isstrongseverity => \&Debbugs::Status::isstrongseverity,
260 html_escape => \&Debbugs::CGI::html_escape,
261 looks_like_number => \&Scalar::Util::looks_like_number,
263 hole_var => {'&package_links' => \&Debbugs::CGI::package_links,
264 '&bug_links' => \&Debbugs::CGI::bug_links,
265 '&version_url' => \&Debbugs::CGI::version_url,
266 '&secs_to_english' => \&Debbugs::Common::secs_to_english,
267 '&strftime' => \&POSIX::strftime,
268 '&maybelink' => \&Debbugs::CGI::maybelink,
274 sub pkg_htmlizebugs {
275 my %param = validate_with(params => \@_,
276 spec => {bugs => {type => ARRAYREF,
278 names => {type => ARRAYREF,
280 title => {type => ARRAYREF,
282 prior => {type => ARRAYREF,
284 order => {type => ARRAYREF,
286 ordering => {type => SCALAR,
288 bugusertags => {type => HASHREF,
291 bug_rev => {type => BOOLEAN,
294 bug_order => {type => SCALAR,
296 repeatmerged => {type => BOOLEAN,
299 include => {type => ARRAYREF,
302 exclude => {type => ARRAYREF,
305 this => {type => SCALAR,
308 options => {type => HASHREF,
311 dist => {type => SCALAR,
314 schema => {type => OBJECT,
319 my @bugs = @{$param{bugs}};
324 my $footer = "<h2 class=\"outstanding\">Summary</h2>\n";
327 return "<HR><H2>No reports found!</H2></HR>\n";
330 if ( $param{bug_rev} ) {
331 @bugs = sort {$b<=>$a} @bugs;
334 @bugs = sort {$a<=>$b} @bugs;
339 'show_list_header' => 1,
340 'show_list_footer' => 1,
344 # Make the include/exclude map
347 for my $include (make_list($param{include})) {
348 next unless defined $include;
349 my ($key,$value) = split /\s*:\s*/,$include,2;
350 unless (defined $value) {
354 push @{$include{$key}}, split /\s*,\s*/, $value;
356 for my $exclude (make_list($param{exclude})) {
357 next unless defined $exclude;
358 my ($key,$value) = split /\s*:\s*/,$exclude,2;
359 unless (defined $value) {
363 push @{$exclude{$key}}, split /\s*,\s*/, $value;
366 my $binary_to_source_cache = {};
368 get_bug_statuses(bug => \@bugs,
370 qw(dist version schema bugusertags),
372 (exists $param{arch}?(arch => $param{arch}):(arch => $config{default_architectures})),
373 binary_to_source_cache => $binary_to_source_cache,
375 for my $bug (sort {$a <=> $b} keys %{$statuses}) {
376 next unless %{$statuses->{$bug}};
377 next if bug_filter(bug => $bug,
378 status => $statuses->{$bug},
379 repeat_merged => $param{repeatmerged},
380 seen_merged => \%seenmerged,
381 (keys %include ? (include => \%include):()),
382 (keys %exclude ? (exclude => \%exclude):()),
385 my $html = "<li>"; #<a href=\"%s\">#%d: %s</a>\n<br>",
386 $html .= short_bug_status_html(status => $statuses->{$bug},
387 options => $param{options},
389 push @status, [ $bug, $statuses->{$bug}, $html ];
391 if ($param{bug_order} eq 'age') {
393 @status = sort {$a->[1]{log_modified} <=> $b->[1]{log_modified}} @status;
395 elsif ($param{bug_order} eq 'agerev') {
396 @status = sort {$b->[1]{log_modified} <=> $a->[1]{log_modified}} @status;
398 for my $entry (@status) {
400 for my $i (0..$#{$param{prior}}) {
401 my $v = get_bug_order_index($param{prior}[$i], $entry->[1]);
402 $count{"g_${i}_${v}"}++;
405 $section{$key} .= $entry->[2];
410 if ($param{ordering} eq "raw") {
411 $result .= "<UL class=\"bugs\">\n" . join("", map( { $_->[ 2 ] } @status ) ) . "</UL>\n";
414 $header .= "<div class=\"msgreceived\">\n<ul>\n";
415 my @keys_in_order = ("");
416 for my $o (@{$param{order}}) {
417 push @keys_in_order, "X";
418 while ((my $k = shift @keys_in_order) ne "X") {
421 push @keys_in_order, "${k}_${k2}";
425 for my $order (@keys_in_order) {
426 next unless defined $section{$order};
427 my @ttl = split /_/, $order;
429 my $title = $param{title}[0]->[$ttl[0]] . " bugs";
432 $title .= join("; ", grep {($_ || "") ne ""}
433 map { $param{title}[$_]->[$ttl[$_]] } 1..$#ttl);
435 $title = html_escape($title);
437 my $count = $count{"_$order"};
438 my $bugs = $count == 1 ? "bug" : "bugs";
440 $header .= "<li><a href=\"#$order\">$title</a> ($count $bugs)</li>\n";
441 if ($common{show_list_header}) {
442 my $count = $count{"_$order"};
443 my $bugs = $count == 1 ? "bug" : "bugs";
444 $result .= "<H2 CLASS=\"outstanding\"><a name=\"$order\"></a>$title ($count $bugs)</H2>\n";
447 $result .= "<H2 CLASS=\"outstanding\">$title</H2>\n";
449 $result .= "<div class=\"msgreceived\">\n<UL class=\"bugs\">\n";
450 $result .= "\n\n\n\n";
451 $result .= $section{$order};
452 $result .= "\n\n\n\n";
453 $result .= "</UL>\n</div>\n";
455 $header .= "</ul></div>\n";
457 $footer .= "<div class=\"msgreceived\">\n<ul>\n";
458 for my $i (0..$#{$param{prior}}) {
459 my $local_result = '';
460 foreach my $key ( @{$param{order}[$i]} ) {
461 my $count = $count{"g_${i}_$key"};
462 next if !$count or !$param{title}[$i]->[$key];
463 $local_result .= "<li>$count $param{title}[$i]->[$key]</li>\n";
465 if ( $local_result ) {
466 $footer .= "<li>$param{names}[$i]<ul>\n$local_result</ul></li>\n";
469 $footer .= "</ul>\n</div>\n";
472 $result = $header . $result if ( $common{show_list_header} );
473 $result .= $footer if ( $common{show_list_footer} );
477 sub parse_order_statement_into_boolean {
478 my ($statement,$status,$tags) = @_;
480 if (not defined $tags) {
481 $tags = {map { $_, 1 } split / /, $status->{"tags"}
483 if defined $status->{"tags"};
486 # replace all + with &&
487 $statement =~ s/\+/&&/g;
488 # replace all , with ||
489 $statement =~ s/,/||/g;
490 $statement =~ s{([^\&\|\=]+) # field
496 $ok = 1 if defined $tags->{$2};
498 $ok = 1 if defined $status->{$1} and
503 # check that the parsed statement is just valid boolean statements
504 if ($statement =~ /^([01\(\)\&\|]+)$/) {
507 # this is an invalid boolean statement
512 sub get_bug_order_index {
516 my $tags = {map { $_, 1 } split / /, $status->{"tags"}
518 if defined $status->{"tags"};
519 for my $el (@${order}) {
520 if (not length $el or
521 parse_order_statement_into_boolean($el,$status,$tags)
530 # sets: my @names; my @prior; my @title; my @order;
532 sub determine_ordering {
533 my %param = validate_with(params => \@_,
534 spec => {cats => {type => HASHREF,
536 param => {type => HASHREF,
538 ordering => {type => SCALARREF,
540 names => {type => ARRAYREF,
542 pend_rev => {type => BOOLEAN,
545 sev_rev => {type => BOOLEAN,
548 prior => {type => ARRAYREF,
550 title => {type => ARRAYREF,
552 order => {type => ARRAYREF,
556 $param{cats}{status}[0]{ord} = [ reverse @{$param{cats}{status}[0]{ord}} ]
557 if ($param{pend_rev});
558 $param{cats}{severity}[0]{ord} = [ reverse @{$param{cats}{severity}[0]{ord}} ]
559 if ($param{sev_rev});
562 if (defined $param{param}{"pri0"}) {
565 while (defined $param{param}{"pri$i"}) {
568 my ($pri) = make_list($param{param}{"pri$i"});
569 if ($pri =~ m/^([^:]*):(.*)$/) {
570 $h->{"nam"} = $1; # overridden later if necesary
571 $h->{"pri"} = [ map { "$1=$_" } (split /,/, $2) ];
574 $h->{"pri"} = [ split /,/, $pri ];
577 ($h->{"nam"}) = make_list($param{param}{"nam$i"})
578 if (defined $param{param}{"nam$i"});
579 $h->{"ord"} = [ map {split /\s*,\s*/} make_list($param{param}{"ord$i"}) ]
580 if (defined $param{param}{"ord$i"});
581 $h->{"ttl"} = [ map {split /\s*,\s*/} make_list($param{param}{"ttl$i"}) ]
582 if (defined $param{param}{"ttl$i"});
587 $param{cats}{"_"} = [@c];
588 ${$param{ordering}} = "_";
591 ${$param{ordering}} = "normal" unless defined $param{cats}{${$param{ordering}}};
597 for my $c (@{$cats->{$o}}) {
598 if (ref($c) eq "HASH") {
602 push @res, get_ordering($cats, $c);
607 my @cats = get_ordering($param{cats}, ${$param{ordering}});
611 $expr =~ s/[+]/ and /g;
612 $expr =~ s/[a-z]+=//g;
619 push @{$param{prior}}, $c->{"pri"};
620 push @{$param{names}}, ($c->{"nam"} || "Bug attribute #" . $i);
621 if (defined $c->{"ord"}) {
622 push @{$param{order}}, $c->{"ord"};
625 push @{$param{order}}, [ 0..$#{$param{prior}[-1]} ];
627 my @t = @{ $c->{"ttl"} } if defined $c->{ttl};
628 if (@t < $#{$param{prior}[-1]}) {
629 push @t, map { toenglish($param{prior}[-1][$_]) } @t..($#{$param{prior}[-1]});
631 push @t, $c->{"def"} || "";
632 push @{$param{title}}, [@t];