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::Collection::Bug;
39 use List::AllUtils qw(apply);
41 use Debbugs::Config qw(:config :globals);
42 use Debbugs::CGI qw(:url :html :util);
43 use Debbugs::Common qw(:misc :util :date);
44 use Debbugs::Status qw(:status);
45 use Debbugs::Bugs qw(bug_filter);
46 use Debbugs::Packages qw(:mapping);
48 use Debbugs::Text qw(:templates);
49 use Encode qw(decode_utf8);
51 use POSIX qw(strftime);
55 ($VERSION) = q$Revision: 494 $ =~ /^Revision:\s+([^\s+])/;
56 $DEBUG = 0 unless defined $DEBUG;
59 %EXPORT_TAGS = (html => [qw(short_bug_status_html pkg_htmlizebugs),
61 misc => [qw(generate_package_info),
62 qw(determine_ordering),
66 Exporter::export_ok_tags(keys %EXPORT_TAGS);
67 $EXPORT_TAGS{all} = [@EXPORT_OK];
70 =head2 generate_package_info
72 generate_package_info($srcorbin,$package)
74 Generates the informational bits for a package and returns it
78 sub generate_package_info{
79 my %param = validate_with(params => \@_,
80 spec => {binary => {type => BOOLEAN,
83 package => {type => SCALAR,#|ARRAYREF,
85 options => {type => HASHREF,
87 bugs => {type => ARRAYREF,
89 schema => {type => OBJECT,
95 my $output_scalar = '';
96 my $output = globify_scalar(\$output_scalar);
98 my $package = $param{package};
100 my %pkgsrc = %{getpkgsrc()};
101 my $srcforpkg = $package;
102 if ($param{binary}) {
104 binary_to_source(source_only => 1,
107 hash_slice(%param,qw(schema)),
111 my $showpkg = html_escape($package);
112 my @maint = package_maintainer($param{binary}?'binary':'source',
114 hash_slice(%param,qw(schema)),
117 print {$output} '<p>';
118 print {$output} (@maint > 1? "Maintainer for $showpkg is "
119 : "Maintainers for $showpkg are ") .
120 package_links(maintainer => \@maint);
121 print {$output} ".</p>\n";
124 print {$output} "<p>There is no maintainer for $showpkg. ".
125 "This means that this package no longer exists (or never existed). ".
126 "Please do not report new bugs against this package. </p>\n";
128 my @pkgs = source_to_binary(source => $srcforpkg,
129 hash_slice(%param,qw(schema)),
131 # if there are distributions, only bother to
132 # show packages which are currently in a
134 @{$config{distributions}//[]} ?
135 (dist => [@{$config{distributions}}]) : (),
137 @pkgs = grep( !/^\Q$package\E$/, @pkgs );
140 if ($param{binary}) {
141 print {$output} "<p>You may want to refer to the following packages that are part of the same source:\n";
144 print {$output} "<p>You may want to refer to the following individual bug pages:\n";
146 #push @pkgs, $src if ( $src && !grep(/^\Q$src\E$/, @pkgs) );
147 print {$output} scalar package_links(package=>[@pkgs]);
148 print {$output} ".\n";
151 my $pseudodesc = getpseudodesc();
152 if ($package and defined($pseudodesc) and exists($pseudodesc->{$package})) {
153 push @references, "to the <a href=\"$config{web_domain}/pseudo-packages$config{html_suffix}\">".
154 "list of other pseudo-packages</a>";
157 if ($package and defined $config{package_pages} and length $config{package_pages}) {
158 push @references, sprintf "to the <a href=\"%s\">%s package page</a>",
159 html_escape("$config{package_pages}/$package"), html_escape("$package");
161 if (defined $config{package_tracking_domain} and
162 length $config{package_tracking_domain}) {
163 my $ptslink = $param{binary} ? $srcforpkg : $package;
164 # the pts only wants the source, and doesn't care about src: (#566089)
165 $ptslink =~ s/^src://;
166 push @references, q(to the <a href=").html_escape("$config{package_tracking_domain}/$ptslink").q(">Package Tracking System</a>);
168 # Only output this if the source listing is non-trivial.
169 if ($param{binary} and $srcforpkg) {
171 "to the source package ".
172 package_links(src=>$srcforpkg,
173 options => $param{options}) .
178 $references[$#references] = "or $references[$#references]" if @references > 1;
179 print {$output} "<p>You might like to refer ", join(", ", @references), ".</p>\n";
182 print {$output} "<p>If you find a bug not listed here, please\n";
183 printf {$output} "<a href=\"%s\">report it</a>.</p>\n",
184 html_escape("$config{web_domain}/Reporting$config{html_suffix}");
186 return decode_utf8($output_scalar);
190 =head2 short_bug_status_html
192 print short_bug_status_html(status => read_bug(bug => 5),
198 =item status -- status hashref as returned by read_bug
200 =item options -- hashref of options to pass to package_links (defaults
203 =item bug_options -- hashref of options to pass to bug_links (default
206 =item snippet -- optional snippet of information about the bug to
216 sub short_bug_status_html {
217 my %param = validate_with(params => \@_,
218 spec => {bug => {type => OBJECT,
219 isa => 'Debbugs::Bug',
224 return fill_in_template(template => 'cgi/short_bug_status',
225 variables => {bug => $param{bug},
226 isstrongseverity => \&Debbugs::Status::isstrongseverity,
227 html_escape => \&Debbugs::CGI::html_escape,
228 looks_like_number => \&Scalar::Util::looks_like_number,
230 hole_var => {'&package_links' => \&Debbugs::CGI::package_links,
231 '&bug_links' => \&Debbugs::CGI::bug_links,
232 '&version_url' => \&Debbugs::CGI::version_url,
233 '&secs_to_english' => \&Debbugs::Common::secs_to_english,
234 '&strftime' => \&POSIX::strftime,
235 '&maybelink' => \&Debbugs::CGI::maybelink,
241 sub pkg_htmlizebugs {
242 my %param = validate_with(params => \@_,
243 spec => {bugs => {type => OBJECT,
245 names => {type => ARRAYREF,
247 title => {type => ARRAYREF,
249 prior => {type => ARRAYREF,
251 order => {type => ARRAYREF,
253 ordering => {type => SCALAR,
255 bugusertags => {type => HASHREF,
258 bug_rev => {type => BOOLEAN,
261 bug_order => {type => SCALAR,
263 repeatmerged => {type => BOOLEAN,
266 include => {type => ARRAYREF,
269 exclude => {type => ARRAYREF,
272 this => {type => SCALAR,
275 options => {type => HASHREF,
278 dist => {type => SCALAR,
281 schema => {type => OBJECT,
286 my $bugs = $param{bugs};
289 my $footer = "<h2 class=\"outstanding\">Summary</h2>\n";
291 if ($bugs->count == 0) {
292 return "<HR><H2>No reports found!</H2></HR>\n";
298 'show_list_header' => 1,
299 'show_list_footer' => 1,
303 # Make the include/exclude map
306 for my $include (make_list($param{include})) {
307 next unless defined $include;
308 my ($key,$value) = split /\s*:\s*/,$include,2;
309 unless (defined $value) {
313 push @{$include{$key}}, split /\s*,\s*/, $value;
315 for my $exclude (make_list($param{exclude})) {
316 next unless defined $exclude;
317 my ($key,$value) = split /\s*:\s*/,$exclude,2;
318 unless (defined $value) {
322 push @{$exclude{$key}}, split /\s*,\s*/, $value;
325 my $sorter = sub {$_[0]->id <=> $_[1]->id};
326 if ($param{bug_rev}) {
327 $sorter = sub {$_[1]->id <=> $_[0]->id}
329 elsif ($param{bug_order} eq 'age') {
330 $sorter = sub {$_[0]->modified->epoch <=> $_[1]->modified->epoch};
332 elsif ($param{bug_order} eq 'agerev') {
333 $sorter = sub {$_[1]->modified->epoch <=> $_[0]->modified->epoch};
336 for my $bug ($bugs->sort($sorter)) {
338 $bug->filter(repeat_merged => $param{repeatmerged},
339 seen_merged => \%seenmerged,
340 (keys %include ? (include => \%include):()),
341 (keys %exclude ? (exclude => \%exclude):()),
344 my $html = "<li>"; #<a href=\"%s\">#%d: %s</a>\n<br>",
345 $html .= short_bug_status_html(bug => $bug,
347 push @status, [ $bug, $html ];
349 # parse bug order indexes into subroutines
353 [map {parse_order_statement_to_subroutine($_)} @{$a}];
355 for my $entry (@status) {
357 for my $i (0..$#order_subs) {
358 my $v = get_bug_order_index($order_subs[$i], $entry->[0]);
359 $count{"g_${i}_${v}"}++;
362 $section{$key} .= $entry->[1];
367 if ($param{ordering} eq "raw") {
368 $result .= "<UL class=\"bugs\">\n" . join("", map( { $_->[ 1 ] } @status ) ) . "</UL>\n";
371 $header .= "<div class=\"msgreceived\">\n<ul>\n";
372 my @keys_in_order = ("");
373 for my $o (@{$param{order}}) {
374 push @keys_in_order, "X";
375 while ((my $k = shift @keys_in_order) ne "X") {
378 push @keys_in_order, "${k}_${k2}";
382 for my $order (@keys_in_order) {
383 next unless defined $section{$order};
384 my @ttl = split /_/, $order;
386 my $title = $param{title}[0]->[$ttl[0]] . " bugs";
389 $title .= join("; ", grep {($_ || "") ne ""}
390 map { $param{title}[$_]->[$ttl[$_]] } 1..$#ttl);
392 $title = html_escape($title);
394 my $count = $count{"_$order"};
395 my $bugs = $count == 1 ? "bug" : "bugs";
397 $header .= "<li><a href=\"#$order\">$title</a> ($count $bugs)</li>\n";
398 if ($common{show_list_header}) {
399 my $count = $count{"_$order"};
400 my $bugs = $count == 1 ? "bug" : "bugs";
401 $result .= "<H2 CLASS=\"outstanding\"><a name=\"$order\"></a>$title ($count $bugs)</H2>\n";
404 $result .= "<H2 CLASS=\"outstanding\">$title</H2>\n";
406 $result .= "<div class=\"msgreceived\">\n<UL class=\"bugs\">\n";
407 $result .= "\n\n\n\n";
408 $result .= $section{$order};
409 $result .= "\n\n\n\n";
410 $result .= "</UL>\n</div>\n";
412 $header .= "</ul></div>\n";
414 $footer .= "<div class=\"msgreceived\">\n<ul>\n";
415 for my $i (0..$#{$param{prior}}) {
416 my $local_result = '';
417 foreach my $key ( @{$param{order}[$i]} ) {
418 my $count = $count{"g_${i}_$key"};
419 next if !$count or !$param{title}[$i]->[$key];
420 $local_result .= "<li>$count $param{title}[$i]->[$key]</li>\n";
422 if ( $local_result ) {
423 $footer .= "<li>$param{names}[$i]<ul>\n$local_result</ul></li>\n";
426 $footer .= "</ul>\n</div>\n";
429 $result = $header . $result if ( $common{show_list_header} );
430 $result .= $footer if ( $common{show_list_footer} );
434 sub parse_order_statement_to_subroutine {
435 my ($statement) = @_;
436 if (not defined $statement or not length $statement) {
437 return sub {return 1};
439 croak "invalid statement '$statement'" unless
440 $statement =~ /^(?:(package|tag|pending|severity) # field
442 ([^=|\&,\+]+(?:,[^=|\&,+])*) #value
443 (\+|,|$) # joiner or end
444 )+ # one or more of these statements
447 while ($statement =~ /(?<joiner>^|,|\+) # joiner
448 (?<field>package|tag|pending|severity) # field
450 (?<value>[^=|\&,\+]+(?:,[^=|\&,\+])*) #value
452 my $field = $+{field};
453 my $value = $+{value};
454 my $joiner = $+{joiner} // '';
455 my @vals = apply {quotemeta($_)} split /,/,$value;
456 if (length $joiner) {
457 if ($joiner eq '+') {
458 push @sub_bits, ' and ';
461 push @sub_bits, ' or ';
465 for my $val (@vals) {
466 if ($field =~ /package|severity/o) {
467 push @vals_bits, '$_[0]->status->'.$field.
469 } elsif ($field eq 'tag') {
470 push @vals_bits, '$_[0]->tags->is_set('.
472 } elsif ($field eq 'pending') {
473 push @vals_bits, '$_[0]->'.$field.
477 push @sub_bits ,' ('.join(' or ',@vals_bits).') ';
479 # return a subroutine reference which determines whether an order statement
481 my $sub = 'sub { return ('.join ("\n",@sub_bits).');};';
482 my $subref = eval $sub;
484 croak "Unable to generate subroutine: $@; $sub";
489 sub parse_order_statement_into_boolean {
490 my ($statement,$status,$tags) = @_;
492 if (not defined $tags) {
493 $tags = {map { $_, 1 } split / /, $status->{"tags"}
495 if defined $status->{"tags"};
498 # replace all + with &&
499 $statement =~ s/\+/&&/g;
500 # replace all , with ||
501 $statement =~ s/,/||/g;
502 $statement =~ s{([^\&\|\=]+) # field
508 $ok = 1 if defined $tags->{$2};
510 $ok = 1 if defined $status->{$1} and
515 # check that the parsed statement is just valid boolean statements
516 if ($statement =~ /^([01\(\)\&\|]+)$/) {
519 # this is an invalid boolean statement
524 sub get_bug_order_index {
525 my ($order,$bug) = @_;
527 for my $el (@{$order}) {
536 # sets: my @names; my @prior; my @title; my @order;
538 sub determine_ordering {
539 my %param = validate_with(params => \@_,
540 spec => {cats => {type => HASHREF,
542 param => {type => HASHREF,
544 ordering => {type => SCALARREF,
546 names => {type => ARRAYREF,
548 pend_rev => {type => BOOLEAN,
551 sev_rev => {type => BOOLEAN,
554 prior => {type => ARRAYREF,
556 title => {type => ARRAYREF,
558 order => {type => ARRAYREF,
562 $param{cats}{status}[0]{ord} = [ reverse @{$param{cats}{status}[0]{ord}} ]
563 if ($param{pend_rev});
564 $param{cats}{severity}[0]{ord} = [ reverse @{$param{cats}{severity}[0]{ord}} ]
565 if ($param{sev_rev});
568 if (defined $param{param}{"pri0"}) {
571 while (defined $param{param}{"pri$i"}) {
574 my ($pri) = make_list($param{param}{"pri$i"});
575 if ($pri =~ m/^([^:]*):(.*)$/) {
576 $h->{"nam"} = $1; # overridden later if necesary
577 $h->{"pri"} = [ map { "$1=$_" } (split /,/, $2) ];
580 $h->{"pri"} = [ split /,/, $pri ];
583 ($h->{"nam"}) = make_list($param{param}{"nam$i"})
584 if (defined $param{param}{"nam$i"});
585 $h->{"ord"} = [ map {split /\s*,\s*/} make_list($param{param}{"ord$i"}) ]
586 if (defined $param{param}{"ord$i"});
587 $h->{"ttl"} = [ map {split /\s*,\s*/} make_list($param{param}{"ttl$i"}) ]
588 if (defined $param{param}{"ttl$i"});
593 $param{cats}{"_"} = [@c];
594 ${$param{ordering}} = "_";
597 ${$param{ordering}} = "normal" unless defined $param{cats}{${$param{ordering}}};
603 for my $c (@{$cats->{$o}}) {
604 if (ref($c) eq "HASH") {
608 push @res, get_ordering($cats, $c);
613 my @cats = get_ordering($param{cats}, ${$param{ordering}});
617 $expr =~ s/[+]/ and /g;
618 $expr =~ s/[a-z]+=//g;
625 push @{$param{prior}}, $c->{"pri"};
626 push @{$param{names}}, ($c->{"nam"} || "Bug attribute #" . $i);
627 if (defined $c->{"ord"}) {
628 push @{$param{order}}, $c->{"ord"};
631 push @{$param{order}}, [ 0..$#{$param{prior}[-1]} ];
633 my @t = @{ $c->{"ttl"} } if defined $c->{ttl};
634 if (@t < $#{$param{prior}[-1]}) {
635 push @t, map { toenglish($param{prior}[-1][$_]) } @t..($#{$param{prior}[-1]});
637 push @t, $c->{"def"} || "";
638 push @{$param{title}}, [@t];