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