]> git.donarmstrong.com Git - debbugs.git/blob - Debbugs/CGI/Pkgreport.pm
84663ed8fcc27b17aa0562282c5d734b69eef730
[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 base qw(Exporter);
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
45 use POSIX qw(strftime);
46
47
48 BEGIN{
49      ($VERSION) = q$Revision: 494 $ =~ /^Revision:\s+([^\s+])/;
50      $DEBUG = 0 unless defined $DEBUG;
51
52      @EXPORT = ();
53      %EXPORT_TAGS = (html => [qw(short_bug_status_html pkg_htmlizebugs),
54                               qw(pkg_javascript),
55                               qw(pkg_htmlselectyesno pkg_htmlselectsuite),
56                               qw(buglinklist pkg_htmlselectarch)
57                              ],
58                      misc => [qw(generate_package_info make_order_list),
59                               qw(myurl),
60                               qw(get_bug_order_index determine_ordering),
61                              ],
62                     );
63      @EXPORT_OK = (qw());
64      Exporter::export_ok_tags(keys %EXPORT_TAGS);
65      $EXPORT_TAGS{all} = [@EXPORT_OK];
66 }
67
68 =head2 generate_package_info
69
70      generate_package_info($srcorbin,$package)
71
72 Generates the informational bits for a package and returns it
73
74 =cut
75
76 sub generate_package_info{
77      my %param = validate_with(params => \@_,
78                                spec  => {binary => {type => BOOLEAN,
79                                                     default => 1,
80                                                    },
81                                          package => {type => SCALAR|ARRAYREF,
82                                                     },
83                                          options => {type => HASHREF,
84                                                     },
85                                          bugs    => {type => ARRAYREF,
86                                                     },
87                                         },
88                               );
89
90      my $output_scalar = '';
91      my $output = globify_scalar(\$output_scalar);
92
93      my $package = $param{package};
94
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};
100      }
101
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} (($maint =~ /,/)? "Maintainer for $showpkg is "
108                            : "Maintainers for $showpkg are ") .
109                                 package_links(maint => $maint);
110           print {$output} ".</p>\n";
111      }
112      else {
113           print {$output} "<p>There is no maintainer for $showpkg. ".
114                "Please do not report new bugs against this package.</p>\n";
115      }
116      my @pkgs = getsrcpkgs($srcforpkg);
117      @pkgs = grep( !/^\Q$package\E$/, @pkgs );
118      if ( @pkgs ) {
119           @pkgs = sort @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";
122           }
123           else {
124                print {$output} "<p>You may want to refer to the following individual bug pages:\n";
125           }
126           #push @pkgs, $src if ( $src && !grep(/^\Q$src\E$/, @pkgs) );
127           print {$output} scalar package_links(package=>[@pkgs]);
128           print {$output} ".\n";
129      }
130      my @references;
131      my $pseudodesc = getpseudodesc();
132      if ($package and defined($pseudodesc) and exists($pseudodesc->{$package})) {
133           push @references, "to the <a href=\"http://$config{web_domain}/pseudo-packages$config{html_suffix}\">".
134                "list of other pseudo-packages</a>";
135      }
136      elsif (not defined $maint and not @{$param{bugs}}) {
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("http://$config{package_pages}/$package"), html_escape("$package");
145           }
146           if (defined $config{subscription_domain} and
147               length $config{subscription_domain}) {
148                my $ptslink = $param{binary} ? $srcforpkg : $package;
149                push @references, q(to the <a href="http://).html_escape("$config{subscription_domain}/$ptslink").q(">Package Tracking System</a>);
150           }
151           # Only output this if the source listing is non-trivial.
152           if ($param{binary} and $srcforpkg) {
153                push @references,
154                     "to the source package ".
155                          package_links(src=>$srcforpkg,
156                                        options => $param{options}) .
157                               "'s bug page";
158           }
159      }
160      if (@references) {
161           $references[$#references] = "or $references[$#references]" if @references > 1;
162           print {$output} "<p>You might like to refer ", join(", ", @references), ".</p>\n";
163      }
164      if (defined $maint) {
165           print {$output} "<p>If you find a bug not listed here, please\n";
166           printf {$output} "<a href=\"%s\">report it</a>.</p>\n",
167                html_escape("http://$config{web_domain}/Reporting$config{html_suffix}");
168      }
169      return $output_scalar;
170 }
171
172
173 =head2 short_bug_status_html
174
175      print short_bug_status_html(status => read_bug(bug => 5),
176                                  options => \%param,
177                                 );
178
179 =over
180
181 =item status -- status hashref as returned by read_bug
182
183 =item options -- hashref of options to pass to package_links (defaults
184 to an empty hashref)
185
186 =item bug_options -- hashref of options to pass to bug_links (default
187 to an empty hashref)
188
189 =item snippet -- optional snippet of information about the bug to
190 display below
191
192
193 =back
194
195
196
197 =cut
198
199 sub short_bug_status_html {
200      my %param = validate_with(params => \@_,
201                                spec   => {status => {type => HASHREF,
202                                                     },
203                                           options => {type => HASHREF,
204                                                       default => {},
205                                                      },
206                                           bug_options => {type => HASHREF,
207                                                           default => {},
208                                                          },
209                                           snippet => {type => SCALAR,
210                                                       default => '',
211                                                      },
212                                          },
213                               );
214
215      my %status = %{$param{status}};
216
217      $status{tags_array} = [sort(split(/\s+/, $status{tags}))];
218      $status{date_text} = strftime('%a, %e %b %Y %T UTC', gmtime($status{date}));
219      $status{mergedwith_array} = [split(/ /,$status{mergedwith})];
220
221      my @blockedby= split(/ /, $status{blockedby});
222      $status{blockedby_array} = [];
223      if (@blockedby && $status{"pending"} ne 'fixed' && ! length($status{done})) {
224           for my $b (@blockedby) {
225                my %s = %{get_bug_status($b)};
226                next if $s{"pending"} eq 'fixed' || length $s{done};
227                push @{$status{blockedby_array}},{bug_num => $b, subject => $s{subject}, status => \%s};
228           }
229      }
230
231      my @blocks= split(/ /, $status{blocks});
232      $status{blocks_array} = [];
233      if (@blocks && $status{"pending"} ne 'fixed' && ! length($status{done})) {
234           for my $b (@blocks) {
235                my %s = %{get_bug_status($b)};
236                next if $s{"pending"} eq 'fixed' || length $s{done};
237                push @{$status{blocks_array}}, {bug_num => $b, subject => $s{subject}, status => \%s};
238           }
239      }
240      my $days = bug_archiveable(bug => $status{id},
241                                 status => \%status,
242                                 days_until => 1,
243                                );
244      $status{archive_days} = $days;
245      return fill_in_template(template => 'cgi/short_bug_status',
246                              variables => {status => \%status,
247                                            isstrongseverity => \&Debbugs::Status::isstrongseverity,
248                                            html_escape   => \&Debbugs::CGI::html_escape,
249                                            looks_like_number => \&Scalar::Util::looks_like_number,
250                                           },
251                              hole_var  => {'&package_links' => \&Debbugs::CGI::package_links,
252                                            '&bug_links'     => \&Debbugs::CGI::bug_links,
253                                            '&version_url'   => \&Debbugs::CGI::version_url,
254                                            '&secs_to_english' => \&Debbugs::Common::secs_to_english,
255                                            '&strftime'      => \&POSIX::strftime,
256                                            '&maybelink'     => \&Debbugs::CGI::maybelink,
257                                           },
258                             );
259 }
260
261
262 sub pkg_htmlizebugs {
263      my %param = validate_with(params => \@_,
264                                spec   => {bugs => {type => ARRAYREF,
265                                                   },
266                                           names => {type => ARRAYREF,
267                                                    },
268                                           title => {type => ARRAYREF,
269                                                    },
270                                           prior => {type => ARRAYREF,
271                                                    },
272                                           order => {type => ARRAYREF,
273                                                    },
274                                           ordering => {type => SCALAR,
275                                                       },
276                                           bugusertags => {type => HASHREF,
277                                                           default => {},
278                                                          },
279                                           bug_rev => {type => BOOLEAN,
280                                                       default => 0,
281                                                      },
282                                           bug_order => {type => SCALAR,
283                                                        },
284                                           repeatmerged => {type => BOOLEAN,
285                                                            default => 1,
286                                                           },
287                                           include => {type => ARRAYREF,
288                                                       default => [],
289                                                      },
290                                           exclude => {type => ARRAYREF,
291                                                       default => [],
292                                                      },
293                                           this     => {type => SCALAR,
294                                                        default => '',
295                                                       },
296                                           options  => {type => HASHREF,
297                                                        default => {},
298                                                       },
299                                           dist     => {type => SCALAR,
300                                                        optional => 1,
301                                                       },
302                                          }
303                               );
304      my @bugs = @{$param{bugs}};
305
306      my @status = ();
307      my %count;
308      my $header = '';
309      my $footer = "<h2 class=\"outstanding\">Summary</h2>\n";
310
311      if (@bugs == 0) {
312           return "<HR><H2>No reports found!</H2></HR>\n";
313      }
314
315      if ( $param{bug_rev} ) {
316           @bugs = sort {$b<=>$a} @bugs;
317      }
318      else {
319           @bugs = sort {$a<=>$b} @bugs;
320      }
321      my %seenmerged;
322
323      my %common = (
324                    'show_list_header' => 1,
325                    'show_list_footer' => 1,
326                   );
327
328      my %section = ();
329      # Make the include/exclude map
330      my %include;
331      my %exclude;
332      for my $include (make_list($param{include})) {
333           next unless defined $include;
334           my ($key,$value) = split /\s*:\s*/,$include,2;
335           unless (defined $value) {
336                $key = 'tags';
337                $value = $include;
338           }
339           push @{$include{$key}}, split /\s*,\s*/, $value;
340      }
341      for my $exclude (make_list($param{exclude})) {
342           next unless defined $exclude;
343           my ($key,$value) = split /\s*:\s*/,$exclude,2;
344           unless (defined $value) {
345                $key = 'tags';
346                $value = $exclude;
347           }
348           push @{$exclude{$key}}, split /\s*,\s*/, $value;
349      }
350
351      foreach my $bug (@bugs) {
352           my %status = %{get_bug_status(bug=>$bug,
353                                         (exists $param{dist}?(dist => $param{dist}):()),
354                                         bugusertags => $param{bugusertags},
355                                         (exists $param{version}?(version => $param{version}):()),
356                                         (exists $param{arch}?(arch => $param{arch}):(arch => $config{default_architectures})),
357                                        )};
358           next unless %status;
359           next if bug_filter(bug => $bug,
360                              status => \%status,
361                              repeat_merged => $param{repeatmerged},
362                              seen_merged => \%seenmerged,
363                              (keys %include ? (include => \%include):()),
364                              (keys %exclude ? (exclude => \%exclude):()),
365                             );
366
367           my $html = "<li>"; #<a href=\"%s\">#%d: %s</a>\n<br>",
368                #bug_url($bug), $bug, html_escape($status{subject});
369           $html .= short_bug_status_html(status  => \%status,
370                                          options => $param{options},
371                                         ) . "\n";
372           push @status, [ $bug, \%status, $html ];
373      }
374      if ($param{bug_order} eq 'age') {
375           # MWHAHAHAHA
376           @status = sort {$a->[1]{log_modified} <=> $b->[1]{log_modified}} @status;
377      }
378      elsif ($param{bug_order} eq 'agerev') {
379           @status = sort {$b->[1]{log_modified} <=> $a->[1]{log_modified}} @status;
380      }
381      for my $entry (@status) {
382           my $key = "";
383           for my $i (0..$#{$param{prior}}) {
384                my $v = get_bug_order_index($param{prior}[$i], $entry->[1]);
385                $count{"g_${i}_${v}"}++;
386                $key .= "_$v";
387           }
388           $section{$key} .= $entry->[2];
389           $count{"_$key"}++;
390      }
391
392      my $result = "";
393      if ($param{ordering} eq "raw") {
394           $result .= "<UL class=\"bugs\">\n" . join("", map( { $_->[ 2 ] } @status ) ) . "</UL>\n";
395      }
396      else {
397           $header .= "<div class=\"msgreceived\">\n<ul>\n";
398           my @keys_in_order = ("");
399           for my $o (@{$param{order}}) {
400                push @keys_in_order, "X";
401                while ((my $k = shift @keys_in_order) ne "X") {
402                     for my $k2 (@{$o}) {
403                          $k2+=0;
404                          push @keys_in_order, "${k}_${k2}";
405                     }
406                }
407           }
408           for my $order (@keys_in_order) {
409                next unless defined $section{$order};
410                my @ttl = split /_/, $order;
411                shift @ttl;
412                my $title = $param{title}[0]->[$ttl[0]] . " bugs";
413                if ($#ttl > 0) {
414                     $title .= " -- ";
415                     $title .= join("; ", grep {($_ || "") ne ""}
416                                    map { $param{title}[$_]->[$ttl[$_]] } 1..$#ttl);
417                }
418                $title = html_escape($title);
419
420                my $count = $count{"_$order"};
421                my $bugs = $count == 1 ? "bug" : "bugs";
422
423                $header .= "<li><a href=\"#$order\">$title</a> ($count $bugs)</li>\n";
424                if ($common{show_list_header}) {
425                     my $count = $count{"_$order"};
426                     my $bugs = $count == 1 ? "bug" : "bugs";
427                     $result .= "<H2 CLASS=\"outstanding\"><a name=\"$order\"></a>$title ($count $bugs)</H2>\n";
428                }
429                else {
430                     $result .= "<H2 CLASS=\"outstanding\">$title</H2>\n";
431                }
432                $result .= "<div class=\"msgreceived\">\n<UL class=\"bugs\">\n";
433                $result .= "\n\n\n\n";
434                $result .= $section{$order};
435                $result .= "\n\n\n\n";
436                $result .= "</UL>\n</div>\n";
437           } 
438           $header .= "</ul></div>\n";
439
440           $footer .= "<div class=\"msgreceived\">\n<ul>\n";
441           for my $i (0..$#{$param{prior}}) {
442                my $local_result = '';
443                foreach my $key ( @{$param{order}[$i]} ) {
444                     my $count = $count{"g_${i}_$key"};
445                     next if !$count or !$param{title}[$i]->[$key];
446                     $local_result .= "<li>$count $param{title}[$i]->[$key]</li>\n";
447                }
448                if ( $local_result ) {
449                     $footer .= "<li>$param{names}[$i]<ul>\n$local_result</ul></li>\n";
450                }
451           }
452           $footer .= "</ul>\n</div>\n";
453      }
454
455      $result = $header . $result if ( $common{show_list_header} );
456      $result .= $footer if ( $common{show_list_footer} );
457      return $result;
458 }
459
460 sub pkg_javascript {
461      return fill_in_template(template=>'cgi/pkgreport_javascript',
462                             );
463 }
464
465 sub pkg_htmlselectyesno {
466      my ($name, $n, $y, $default) = @_;
467      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);
468 }
469
470 sub pkg_htmlselectsuite {
471      my $id = sprintf "b_%d_%d_%d", $_[0], $_[1], $_[2];
472      my @suites = ("stable", "testing", "unstable", "experimental");
473      my %suiteaka = ("stable", "etch", "testing", "lenny", "unstable", "sid");
474      my $defaultsuite = "unstable";
475
476      my $result = sprintf '<select name=dist id="%s">', $id;
477      for my $s (@suites) {
478           $result .= sprintf '<option value="%s"%s>%s%s</option>',
479                $s, ($defaultsuite eq $s ? " selected" : ""),
480                     $s, (defined $suiteaka{$s} ? " (" . $suiteaka{$s} . ")" : "");
481      }
482      $result .= '</select>';
483      return $result;
484 }
485
486 sub pkg_htmlselectarch {
487      my $id = sprintf "b_%d_%d_%d", $_[0], $_[1], $_[2];
488      my @arches = qw(alpha amd64 arm hppa i386 ia64 m68k mips mipsel powerpc s390 sparc);
489
490      my $result = sprintf '<select name=arch id="%s">', $id;
491      $result .= '<option value="any">any architecture</option>';
492      for my $a (@arches) {
493           $result .= sprintf '<option value="%s">%s</option>', $a, $a;
494      }
495      $result .= '</select>';
496      return $result;
497 }
498
499 sub myurl {
500      my %param = @_;
501      return html_escape(pkg_url(map {exists $param{$_}?($_,$param{$_}):()}
502                                 qw(archive repeatmerged mindays maxdays),
503                                 qw(version dist arch package src tag maint submitter)
504                                )
505                        );
506 }
507
508 sub make_order_list {
509      my $vfull = shift;
510      my @x = ();
511
512      if ($vfull =~ m/^([^:]+):(.*)$/) {
513           my $v = $1;
514           for my $vv (split /,/, $2) {
515                push @x, "$v=$vv";
516           }
517      }
518      else {
519           for my $v (split /,/, $vfull) {
520                next unless $v =~ m/.=./;
521                push @x, $v;
522           }
523      }
524      push @x, "";               # catch all
525      return @x;
526 }
527
528 sub get_bug_order_index {
529      my $order = shift;
530      my $status = shift;
531      my $pos = -1;
532
533      my %tags = ();
534      %tags = map { $_, 1 } split / /, $status->{"tags"}
535           if defined $status->{"tags"};
536
537      for my $el (@${order}) {
538           $pos++;
539           my $match = 1;
540           for my $item (split /[+]/, $el) {
541                my ($f, $v) = split /=/, $item, 2;
542                next unless (defined $f and defined $v);
543                my $isokay = 0;
544                $isokay = 1 if (defined $status->{$f} and $v eq $status->{$f});
545                $isokay = 1 if ($f eq "tag" && defined $tags{$v});
546                unless ($isokay) {
547                     $match = 0;
548                     last;
549                }
550           }
551           if ($match) {
552                return $pos;
553                last;
554           }
555      }
556      return $pos + 1;
557 }
558
559 sub buglinklist {
560      my ($prefix, $infix, @els) = @_;
561      return '' if not @els;
562      return $prefix . bug_linklist($infix,'submitter',@els);
563 }
564
565
566 # sets: my @names; my @prior; my @title; my @order;
567
568 sub determine_ordering {
569      my %param = validate_with(params => \@_,
570                               spec => {cats => {type => HASHREF,
571                                                },
572                                        param => {type => HASHREF,
573                                                 },
574                                        ordering => {type => SCALARREF,
575                                                    },
576                                        names    => {type => ARRAYREF,
577                                                    },
578                                        pend_rev => {type => BOOLEAN,
579                                                     default => 0,
580                                                    },
581                                        sev_rev  => {type => BOOLEAN,
582                                                     default => 0,
583                                                    },
584                                        prior    => {type => ARRAYREF,
585                                                    },
586                                        title    => {type => ARRAYREF,
587                                                    },
588                                        order    => {type => ARRAYREF,
589                                                    },
590                                       },
591                              );
592      $param{cats}{status}[0]{ord} = [ reverse @{$param{cats}{status}[0]{ord}} ]
593           if ($param{pend_rev});
594      $param{cats}{severity}[0]{ord} = [ reverse @{$param{cats}{severity}[0]{ord}} ]
595           if ($param{sev_rev});
596
597      my $i;
598      if (defined $param{param}{"pri0"}) {
599           my @c = ();
600           $i = 0;
601           while (defined $param{param}{"pri$i"}) {
602                my $h = {};
603
604                my ($pri) = make_list($param{param}{"pri$i"});
605                if ($pri =~ m/^([^:]*):(.*)$/) {
606                     $h->{"nam"} = $1; # overridden later if necesary
607                     $h->{"pri"} = [ map { "$1=$_" } (split /,/, $2) ];
608                }
609                else {
610                     $h->{"pri"} = [ split /,/, $pri ];
611                }
612
613                ($h->{"nam"}) = make_list($param{param}{"nam$i"})
614                     if (defined $param{param}{"nam$i"});
615                $h->{"ord"} = [ map {split /\s*,\s*/} make_list($param{param}{"ord$i"}) ]
616                     if (defined $param{param}{"ord$i"});
617                $h->{"ttl"} = [ map {split /\s*,\s*/} make_list($param{param}{"ttl$i"}) ]
618                     if (defined $param{param}{"ttl$i"});
619
620                push @c, $h;
621                $i++;
622           }
623           $param{cats}{"_"} = [@c];
624           ${$param{ordering}} = "_";
625      }
626
627      ${$param{ordering}} = "normal" unless defined $param{cats}{${$param{ordering}}};
628
629      sub get_ordering {
630           my @res;
631           my $cats = shift;
632           my $o = shift;
633           for my $c (@{$cats->{$o}}) {
634                if (ref($c) eq "HASH") {
635                     push @res, $c;
636                }
637                else {
638                     push @res, get_ordering($cats, $c);
639                }
640           }
641           return @res;
642      }
643      my @cats = get_ordering($param{cats}, ${$param{ordering}});
644
645      sub toenglish {
646           my $expr = shift;
647           $expr =~ s/[+]/ and /g;
648           $expr =~ s/[a-z]+=//g;
649           return $expr;
650      }
651  
652      $i = 0;
653      for my $c (@cats) {
654           $i++;
655           push @{$param{prior}}, $c->{"pri"};
656           push @{$param{names}}, ($c->{"nam"} || "Bug attribute #" . $i);
657           if (defined $c->{"ord"}) {
658                push @{$param{order}}, $c->{"ord"};
659           }
660           else {
661                push @{$param{order}}, [ 0..$#{$param{prior}[-1]} ];
662           }
663           my @t = @{ $c->{"ttl"} } if defined $c->{ttl};
664           if (@t < $#{$param{prior}[-1]}) {
665                push @t, map { toenglish($param{prior}[-1][$_]) } @t..($#{$param{prior}[-1]});
666           }
667           push @t, $c->{"def"} || "";
668           push @{$param{title}}, [@t];
669      }
670 }
671
672
673
674
675 1;
676
677
678 __END__
679
680
681
682
683
684