]> git.donarmstrong.com Git - debbugs.git/blob - Debbugs/CGI/Pkgreport.pm
Merge branch 'database'
[debbugs.git] / Debbugs / CGI / Pkgreport.pm
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.
4 #
5 # [Other people have contributed to this file; their copyrights should
6 # be listed here too.]
7 # Copyright 2008 by Don Armstrong <don@donarmstrong.com>.
8
9
10 package Debbugs::CGI::Pkgreport;
11
12 =head1 NAME
13
14 Debbugs::CGI::Pkgreport -- specific routines for the pkgreport cgi script
15
16 =head1 SYNOPSIS
17
18
19 =head1 DESCRIPTION
20
21
22 =head1 BUGS
23
24 None known.
25
26 =cut
27
28 use warnings;
29 use strict;
30 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
31 use Exporter qw(import);
32
33 use IO::Scalar;
34 use Params::Validate qw(validate_with :types);
35
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);
42
43 use Debbugs::Text qw(:templates);
44 use Encode qw(decode_utf8);
45
46 use POSIX qw(strftime);
47
48
49 BEGIN{
50      ($VERSION) = q$Revision: 494 $ =~ /^Revision:\s+([^\s+])/;
51      $DEBUG = 0 unless defined $DEBUG;
52
53      @EXPORT = ();
54      %EXPORT_TAGS = (html => [qw(short_bug_status_html pkg_htmlizebugs),
55                              ],
56                      misc => [qw(generate_package_info),
57                               qw(determine_ordering),
58                              ],
59                     );
60      @EXPORT_OK = (qw());
61      Exporter::export_ok_tags(keys %EXPORT_TAGS);
62      $EXPORT_TAGS{all} = [@EXPORT_OK];
63 }
64
65 =head2 generate_package_info
66
67      generate_package_info($srcorbin,$package)
68
69 Generates the informational bits for a package and returns it
70
71 =cut
72
73 sub generate_package_info{
74      my %param = validate_with(params => \@_,
75                                spec  => {binary => {type => BOOLEAN,
76                                                     default => 1,
77                                                    },
78                                          package => {type => SCALAR,#|ARRAYREF,
79                                                     },
80                                          options => {type => HASHREF,
81                                                     },
82                                          bugs    => {type => ARRAYREF,
83                                                     },
84                                         },
85                               );
86
87      my $output_scalar = '';
88      my $output = globify_scalar(\$output_scalar);
89
90      my $package = $param{package};
91
92      my %pkgsrc = %{getpkgsrc()};
93      my $srcforpkg = $package;
94      if ($param{binary} and exists $pkgsrc{$package}
95          and defined $pkgsrc{$package}) {
96           $srcforpkg = $pkgsrc{$package};
97      }
98
99      my $showpkg = html_escape($package);
100      my $maintainers = getmaintainers();
101      my $maint = $maintainers->{$srcforpkg};
102      if (defined $maint) {
103           print {$output} '<p>';
104           print {$output} (($maint =~ /,/)? "Maintainer for $showpkg is "
105                            : "Maintainers for $showpkg are ") .
106                                 package_links(maintainer => $maint);
107           print {$output} ".</p>\n";
108      }
109      else {
110           print {$output} "<p>There is no maintainer for $showpkg. ".
111                "This means that this package no longer exists (or never existed). ".
112                    "Please do not report new bugs against this package. </p>\n";
113      }
114      my @pkgs = getsrcpkgs($srcforpkg);
115      @pkgs = grep( !/^\Q$package\E$/, @pkgs );
116      if ( @pkgs ) {
117           @pkgs = sort @pkgs;
118           if ($param{binary}) {
119                print {$output} "<p>You may want to refer to the following packages that are part of the same source:\n";
120           }
121           else {
122                print {$output} "<p>You may want to refer to the following individual bug pages:\n";
123           }
124           #push @pkgs, $src if ( $src && !grep(/^\Q$src\E$/, @pkgs) );
125           print {$output} scalar package_links(package=>[@pkgs]);
126           print {$output} ".\n";
127      }
128      my @references;
129      my $pseudodesc = getpseudodesc();
130      if ($package and defined($pseudodesc) and exists($pseudodesc->{$package})) {
131           push @references, "to the <a href=\"$config{web_domain}/pseudo-packages$config{html_suffix}\">".
132                "list of other pseudo-packages</a>";
133      }
134      elsif (not defined $maint and not @{$param{bugs}}) {
135         # don't bother printing out this information, because it's
136         # already present above.
137         #  print {$output} "<p>There is no record of the " . html_escape($package) .
138         #       ($param{binary} ? " package" : " source package") .
139         #           ", and no bugs have been filed against it.</p>";
140      }
141      else {
142           if ($package and defined $config{package_pages} and length $config{package_pages}) {
143                push @references, sprintf "to the <a href=\"%s\">%s package page</a>",
144                     html_escape("$config{package_pages}/$package"), html_escape("$package");
145           }
146           if (defined $config{package_tracking_domain} and
147               length $config{package_tracking_domain}) {
148                my $ptslink = $param{binary} ? $srcforpkg : $package;
149                # the pts only wants the source, and doesn't care about src: (#566089)
150                $ptslink =~ s/^src://;
151                push @references, q(to the <a href=").html_escape("$config{package_tracking_domain}/$ptslink").q(">Package Tracking System</a>);
152           }
153           # Only output this if the source listing is non-trivial.
154           if ($param{binary} and $srcforpkg) {
155                push @references,
156                     "to the source package ".
157                          package_links(src=>$srcforpkg,
158                                        options => $param{options}) .
159                               "'s bug page";
160           }
161      }
162      if (@references) {
163           $references[$#references] = "or $references[$#references]" if @references > 1;
164           print {$output} "<p>You might like to refer ", join(", ", @references), ".</p>\n";
165      }
166      if (defined $maint) {
167           print {$output} "<p>If you find a bug not listed here, please\n";
168           printf {$output} "<a href=\"%s\">report it</a>.</p>\n",
169                html_escape("$config{web_domain}/Reporting$config{html_suffix}");
170      }
171      return decode_utf8($output_scalar);
172 }
173
174
175 =head2 short_bug_status_html
176
177      print short_bug_status_html(status => read_bug(bug => 5),
178                                  options => \%param,
179                                 );
180
181 =over
182
183 =item status -- status hashref as returned by read_bug
184
185 =item options -- hashref of options to pass to package_links (defaults
186 to an empty hashref)
187
188 =item bug_options -- hashref of options to pass to bug_links (default
189 to an empty hashref)
190
191 =item snippet -- optional snippet of information about the bug to
192 display below
193
194
195 =back
196
197
198
199 =cut
200
201 sub short_bug_status_html {
202      my %param = validate_with(params => \@_,
203                                spec   => {status => {type => HASHREF,
204                                                     },
205                                           options => {type => HASHREF,
206                                                       default => {},
207                                                      },
208                                           bug_options => {type => HASHREF,
209                                                           default => {},
210                                                          },
211                                           snippet => {type => SCALAR,
212                                                       default => '',
213                                                      },
214                                          },
215                               );
216
217      my %status = %{$param{status}};
218
219      $status{tags_array} = [sort(split(/\s+/, $status{tags}))];
220      $status{date_text} = strftime('%a, %e %b %Y %T UTC', gmtime($status{date}));
221      $status{mergedwith_array} = [split(/ /,$status{mergedwith})];
222
223      my @blockedby= split(/ /, $status{blockedby});
224      $status{blockedby_array} = [];
225      if (@blockedby && $status{"pending"} ne 'fixed' && ! length($status{done})) {
226           for my $b (@blockedby) {
227                my %s = %{get_bug_status($b)};
228                next if (defined $s{pending} and $s{pending} eq 'fixed') or (defined $s{done} and length $s{done});
229                push @{$status{blockedby_array}},{bug_num => $b, subject => $s{subject}, status => \%s};
230           }
231      }
232
233      my @blocks= split(/ /, $status{blocks});
234      $status{blocks_array} = [];
235      if (@blocks && $status{"pending"} ne 'fixed' && ! length($status{done})) {
236           for my $b (@blocks) {
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{blocks_array}}, {bug_num => $b, subject => $s{subject}, status => \%s};
240           }
241      }
242      my $days = bug_archiveable(bug => $status{id},
243                                 status => \%status,
244                                 days_until => 1,
245                                );
246      $status{archive_days} = $days;
247      return fill_in_template(template => 'cgi/short_bug_status',
248                              variables => {status => \%status,
249                                            isstrongseverity => \&Debbugs::Status::isstrongseverity,
250                                            html_escape   => \&Debbugs::CGI::html_escape,
251                                            looks_like_number => \&Scalar::Util::looks_like_number,
252                                           },
253                              hole_var  => {'&package_links' => \&Debbugs::CGI::package_links,
254                                            '&bug_links'     => \&Debbugs::CGI::bug_links,
255                                            '&version_url'   => \&Debbugs::CGI::version_url,
256                                            '&secs_to_english' => \&Debbugs::Common::secs_to_english,
257                                            '&strftime'      => \&POSIX::strftime,
258                                            '&maybelink'     => \&Debbugs::CGI::maybelink,
259                                           },
260                             );
261 }
262
263
264 sub pkg_htmlizebugs {
265      my %param = validate_with(params => \@_,
266                                spec   => {bugs => {type => ARRAYREF,
267                                                   },
268                                           names => {type => ARRAYREF,
269                                                    },
270                                           title => {type => ARRAYREF,
271                                                    },
272                                           prior => {type => ARRAYREF,
273                                                    },
274                                           order => {type => ARRAYREF,
275                                                    },
276                                           ordering => {type => SCALAR,
277                                                       },
278                                           bugusertags => {type => HASHREF,
279                                                           default => {},
280                                                          },
281                                           bug_rev => {type => BOOLEAN,
282                                                       default => 0,
283                                                      },
284                                           bug_order => {type => SCALAR,
285                                                        },
286                                           repeatmerged => {type => BOOLEAN,
287                                                            default => 1,
288                                                           },
289                                           include => {type => ARRAYREF,
290                                                       default => [],
291                                                      },
292                                           exclude => {type => ARRAYREF,
293                                                       default => [],
294                                                      },
295                                           this     => {type => SCALAR,
296                                                        default => '',
297                                                       },
298                                           options  => {type => HASHREF,
299                                                        default => {},
300                                                       },
301                                           dist     => {type => SCALAR,
302                                                        optional => 1,
303                                                       },
304                                           schema   => {type => OBJECT,
305                                                        optional => 1,
306                                                       },
307                                          }
308                               );
309      my @bugs = @{$param{bugs}};
310
311      my @status = ();
312      my %count;
313      my $header = '';
314      my $footer = "<h2 class=\"outstanding\">Summary</h2>\n";
315
316      if (@bugs == 0) {
317           return "<HR><H2>No reports found!</H2></HR>\n";
318      }
319
320      if ( $param{bug_rev} ) {
321           @bugs = sort {$b<=>$a} @bugs;
322      }
323      else {
324           @bugs = sort {$a<=>$b} @bugs;
325      }
326      my %seenmerged;
327
328      my %common = (
329                    'show_list_header' => 1,
330                    'show_list_footer' => 1,
331                   );
332
333      my %section = ();
334      # Make the include/exclude map
335      my %include;
336      my %exclude;
337      for my $include (make_list($param{include})) {
338           next unless defined $include;
339           my ($key,$value) = split /\s*:\s*/,$include,2;
340           unless (defined $value) {
341                $key = 'tags';
342                $value = $include;
343           }
344           push @{$include{$key}}, split /\s*,\s*/, $value;
345      }
346      for my $exclude (make_list($param{exclude})) {
347           next unless defined $exclude;
348           my ($key,$value) = split /\s*:\s*/,$exclude,2;
349           unless (defined $value) {
350                $key = 'tags';
351                $value = $exclude;
352           }
353           push @{$exclude{$key}}, split /\s*,\s*/, $value;
354      }
355
356      my $binary_to_source_cache = {};
357      foreach my $bug (@bugs) {
358          my %status = %{get_bug_status(bug=>$bug,
359                                        (map {exists $param{$_}?($_,$param{$_}):()}
360                                         qw(dist version schema bugusertags)
361                                        ),
362                                         (exists $param{arch}?(arch => $param{arch}):(arch => $config{default_architectures})),
363                                         binary_to_source_cache => $binary_to_source_cache,
364                                        )};
365           next unless %status;
366           next if bug_filter(bug => $bug,
367                              status => \%status,
368                              repeat_merged => $param{repeatmerged},
369                              seen_merged => \%seenmerged,
370                              (keys %include ? (include => \%include):()),
371                              (keys %exclude ? (exclude => \%exclude):()),
372                             );
373
374           my $html = "<li>"; #<a href=\"%s\">#%d: %s</a>\n<br>",
375           $html .= short_bug_status_html(status  => \%status,
376                                          options => $param{options},
377                                         ) . "\n";
378           push @status, [ $bug, \%status, $html ];
379      }
380      if ($param{bug_order} eq 'age') {
381           # MWHAHAHAHA
382           @status = sort {$a->[1]{log_modified} <=> $b->[1]{log_modified}} @status;
383      }
384      elsif ($param{bug_order} eq 'agerev') {
385           @status = sort {$b->[1]{log_modified} <=> $a->[1]{log_modified}} @status;
386      }
387      for my $entry (@status) {
388           my $key = "";
389           for my $i (0..$#{$param{prior}}) {
390                my $v = get_bug_order_index($param{prior}[$i], $entry->[1]);
391                $count{"g_${i}_${v}"}++;
392                $key .= "_$v";
393           }
394           $section{$key} .= $entry->[2];
395           $count{"_$key"}++;
396      }
397
398      my $result = "";
399      if ($param{ordering} eq "raw") {
400           $result .= "<UL class=\"bugs\">\n" . join("", map( { $_->[ 2 ] } @status ) ) . "</UL>\n";
401      }
402      else {
403           $header .= "<div class=\"msgreceived\">\n<ul>\n";
404           my @keys_in_order = ("");
405           for my $o (@{$param{order}}) {
406                push @keys_in_order, "X";
407                while ((my $k = shift @keys_in_order) ne "X") {
408                     for my $k2 (@{$o}) {
409                          $k2+=0;
410                          push @keys_in_order, "${k}_${k2}";
411                     }
412                }
413           }
414           for my $order (@keys_in_order) {
415                next unless defined $section{$order};
416                my @ttl = split /_/, $order;
417                shift @ttl;
418                my $title = $param{title}[0]->[$ttl[0]] . " bugs";
419                if ($#ttl > 0) {
420                     $title .= " -- ";
421                     $title .= join("; ", grep {($_ || "") ne ""}
422                                    map { $param{title}[$_]->[$ttl[$_]] } 1..$#ttl);
423                }
424                $title = html_escape($title);
425
426                my $count = $count{"_$order"};
427                my $bugs = $count == 1 ? "bug" : "bugs";
428
429                $header .= "<li><a href=\"#$order\">$title</a> ($count $bugs)</li>\n";
430                if ($common{show_list_header}) {
431                     my $count = $count{"_$order"};
432                     my $bugs = $count == 1 ? "bug" : "bugs";
433                     $result .= "<H2 CLASS=\"outstanding\"><a name=\"$order\"></a>$title ($count $bugs)</H2>\n";
434                }
435                else {
436                     $result .= "<H2 CLASS=\"outstanding\">$title</H2>\n";
437                }
438                $result .= "<div class=\"msgreceived\">\n<UL class=\"bugs\">\n";
439                $result .= "\n\n\n\n";
440                $result .= $section{$order};
441                $result .= "\n\n\n\n";
442                $result .= "</UL>\n</div>\n";
443           } 
444           $header .= "</ul></div>\n";
445
446           $footer .= "<div class=\"msgreceived\">\n<ul>\n";
447           for my $i (0..$#{$param{prior}}) {
448                my $local_result = '';
449                foreach my $key ( @{$param{order}[$i]} ) {
450                     my $count = $count{"g_${i}_$key"};
451                     next if !$count or !$param{title}[$i]->[$key];
452                     $local_result .= "<li>$count $param{title}[$i]->[$key]</li>\n";
453                }
454                if ( $local_result ) {
455                     $footer .= "<li>$param{names}[$i]<ul>\n$local_result</ul></li>\n";
456                }
457           }
458           $footer .= "</ul>\n</div>\n";
459      }
460
461      $result = $header . $result if ( $common{show_list_header} );
462      $result .= $footer if ( $common{show_list_footer} );
463      return $result;
464 }
465
466 sub parse_order_statement_into_boolean {
467     my ($statement,$status,$tags) = @_;
468
469     if (not defined $tags) {
470         $tags = {map { $_, 1 } split / /, $status->{"tags"}
471                 }
472             if defined $status->{"tags"};
473
474     }
475     # replace all + with &&
476     $statement =~ s/\+/&&/g;
477     # replace all , with ||
478     $statement =~ s/,/||/g;
479     $statement =~ s{([^\&\|\=]+) # field
480                     =
481                     ([^\&\|\=]+) # value
482               }{
483                   my $ok = 0;
484                   if ($1 eq 'tag') {
485                       $ok = 1 if defined $tags->{$2};
486                   } else {
487                       $ok = 1 if defined $status->{$1} and
488                           $status->{$1} eq $2;
489                   }
490                   $ok;
491               }exg;
492     # check that the parsed statement is just valid boolean statements
493     if ($statement =~ /^([01\(\)\&\|]+)$/) {
494         return eval "$1";
495     } else {
496         # this is an invalid boolean statement
497         return 0;
498     }
499 }
500
501 sub get_bug_order_index {
502      my $order = shift;
503      my $status = shift;
504      my $pos = 0;
505      my $tags = {map { $_, 1 } split / /, $status->{"tags"}
506                 }
507          if defined $status->{"tags"};
508      for my $el (@${order}) {
509          if (not length $el or
510              parse_order_statement_into_boolean($el,$status,$tags)
511             ) {
512              return $pos;
513          }
514          $pos++;
515      }
516      return $pos;
517 }
518
519 # sets: my @names; my @prior; my @title; my @order;
520
521 sub determine_ordering {
522      my %param = validate_with(params => \@_,
523                               spec => {cats => {type => HASHREF,
524                                                },
525                                        param => {type => HASHREF,
526                                                 },
527                                        ordering => {type => SCALARREF,
528                                                    },
529                                        names    => {type => ARRAYREF,
530                                                    },
531                                        pend_rev => {type => BOOLEAN,
532                                                     default => 0,
533                                                    },
534                                        sev_rev  => {type => BOOLEAN,
535                                                     default => 0,
536                                                    },
537                                        prior    => {type => ARRAYREF,
538                                                    },
539                                        title    => {type => ARRAYREF,
540                                                    },
541                                        order    => {type => ARRAYREF,
542                                                    },
543                                       },
544                              );
545      $param{cats}{status}[0]{ord} = [ reverse @{$param{cats}{status}[0]{ord}} ]
546           if ($param{pend_rev});
547      $param{cats}{severity}[0]{ord} = [ reverse @{$param{cats}{severity}[0]{ord}} ]
548           if ($param{sev_rev});
549
550      my $i;
551      if (defined $param{param}{"pri0"}) {
552           my @c = ();
553           $i = 0;
554           while (defined $param{param}{"pri$i"}) {
555                my $h = {};
556
557                my ($pri) = make_list($param{param}{"pri$i"});
558                if ($pri =~ m/^([^:]*):(.*)$/) {
559                     $h->{"nam"} = $1; # overridden later if necesary
560                     $h->{"pri"} = [ map { "$1=$_" } (split /,/, $2) ];
561                }
562                else {
563                     $h->{"pri"} = [ split /,/, $pri ];
564                }
565
566                ($h->{"nam"}) = make_list($param{param}{"nam$i"})
567                     if (defined $param{param}{"nam$i"});
568                $h->{"ord"} = [ map {split /\s*,\s*/} make_list($param{param}{"ord$i"}) ]
569                     if (defined $param{param}{"ord$i"});
570                $h->{"ttl"} = [ map {split /\s*,\s*/} make_list($param{param}{"ttl$i"}) ]
571                     if (defined $param{param}{"ttl$i"});
572
573                push @c, $h;
574                $i++;
575           }
576           $param{cats}{"_"} = [@c];
577           ${$param{ordering}} = "_";
578      }
579
580      ${$param{ordering}} = "normal" unless defined $param{cats}{${$param{ordering}}};
581
582      sub get_ordering {
583           my @res;
584           my $cats = shift;
585           my $o = shift;
586           for my $c (@{$cats->{$o}}) {
587                if (ref($c) eq "HASH") {
588                     push @res, $c;
589                }
590                else {
591                     push @res, get_ordering($cats, $c);
592                }
593           }
594           return @res;
595      }
596      my @cats = get_ordering($param{cats}, ${$param{ordering}});
597
598      sub toenglish {
599           my $expr = shift;
600           $expr =~ s/[+]/ and /g;
601           $expr =~ s/[a-z]+=//g;
602           return $expr;
603      }
604  
605      $i = 0;
606      for my $c (@cats) {
607           $i++;
608           push @{$param{prior}}, $c->{"pri"};
609           push @{$param{names}}, ($c->{"nam"} || "Bug attribute #" . $i);
610           if (defined $c->{"ord"}) {
611                push @{$param{order}}, $c->{"ord"};
612           }
613           else {
614                push @{$param{order}}, [ 0..$#{$param{prior}[-1]} ];
615           }
616           my @t = @{ $c->{"ttl"} } if defined $c->{ttl};
617           if (@t < $#{$param{prior}[-1]}) {
618                push @t, map { toenglish($param{prior}[-1][$_]) } @t..($#{$param{prior}[-1]});
619           }
620           push @t, $c->{"def"} || "";
621           push @{$param{title}}, [@t];
622      }
623 }
624
625
626
627
628 1;
629
630
631 __END__
632
633
634
635
636
637