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                               qw(get_status_and_filter),
  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(maint => $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=\"http://$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("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                # 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="http://).html_escape("$config{subscription_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("http://$config{web_domain}/Reporting$config{html_suffix}");
 170      }
 171      return $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 our %_get_status_and_filter_params =
 264     (bugs => {type => ARRAYREF,
 265              },
 266      bugusertags => {type => HASHREF,
 267                      default => {},
 268                     },
 269      repeatmerged => {type => BOOLEAN,
 270                       default => 1,
 271                      },
 272      include => {type => ARRAYREF,
 273                  default => [],
 274                 },
 275      exclude => {type => ARRAYREF,
 276                  default => [],
 277                 },
 278      dist     => {type => SCALAR,
 279                   optional => 1,
 280                  },
 281      version  => {type => SCALAR,
 282                   optional => 1,
 283                  },
 284     );
 285
 286
 287 sub get_status_and_filter {
 288     my %param = validate_with(params => \@_,
 289                               spec   => {%_get_status_and_filter_params},
 290                              );
 291     my %seenmerged;
 292     my %statuses;
 293
 294      my %include;
 295      my %exclude;
 296      for my $include (make_list($param{include})) {
 297           next unless defined $include;
 298           my ($key,$value) = split /\s*:\s*/,$include,2;
 299           unless (defined $value) {
 300                $key = 'tags';
 301                $value = $include;
 302           }
 303           push @{$include{$key}}, split /\s*,\s*/, $value;
 304      }
 305      for my $exclude (make_list($param{exclude})) {
 306           next unless defined $exclude;
 307           my ($key,$value) = split /\s*:\s*/,$exclude,2;
 308           unless (defined $value) {
 309                $key = 'tags';
 310                $value = $exclude;
 311           }
 312           push @{$exclude{$key}}, split /\s*,\s*/, $value;
 313      }
 314
 315     foreach my $bug (@{$param{bugs}}) {
 316         next if exists $statuses{$bug};
 317         my $status = get_bug_status(bug=>$bug,
 318                                     (exists $param{dist}?(dist => $param{dist}):()),
 319                                     bugusertags => $param{bugusertags},
 320                                     (exists $param{version}?(version => $param{version}):()),
 321                                     (exists $param{arch}?(arch => $param{arch}):(arch => $config{default_architectures})),
 322                                    );
 323         next unless keys $status;
 324         next if bug_filter(bug => $bug,
 325                            status => $status,
 326                            repeat_merged => $param{repeatmerged},
 327                            seen_merged => \%seenmerged,
 328                            (keys %include ? (include => \%include):()),
 329                            (keys %exclude ? (exclude => \%exclude):()),
 330                           );
 331         $statuses{$bug} = $status;
 332     }
 333     return \%statuses;
 334
 335 }
 336
 337
 338 sub pkg_htmlizebugs {
 339     my %param = validate_with(params => \@_,
 340                               spec   => {%_get_status_and_filter_params,
 341                                          bugs => {type => ARRAYREF,
 342                                                  },
 343                                          bug_status => {type => HASHREF,
 344                                                        },
 345                                          names => {type => ARRAYREF,
 346                                                   },
 347                                          title => {type => ARRAYREF,
 348                                                   },
 349                                          prior => {type => ARRAYREF,
 350                                                   },
 351                                          order => {type => ARRAYREF,
 352                                                   },
 353                                          ordering => {type => SCALAR,
 354                                                      },
 355                                          bug_rev => {type => BOOLEAN,
 356                                                      default => 0,
 357                                                     },
 358                                          bug_order => {type => SCALAR,
 359                                                       },
 360                                          options  => {type => HASHREF,
 361                                                       default => {},
 362                                                      },
 363                                         }
 364                              );
 365      my @bugs = @{$param{bugs}};
 366
 367      my @status = ();
 368      my %count;
 369      my $header = '';
 370      my $footer = "<h2 class=\"outstanding\">Summary</h2>\n";
 371
 372      if (@bugs == 0) {
 373           return "<HR><H2>No reports found!</H2></HR>\n";
 374      }
 375
 376      if ( $param{bug_rev} ) {
 377           @bugs = sort {$b<=>$a} @bugs;
 378      }
 379      else {
 380           @bugs = sort {$a<=>$b} @bugs;
 381      }
 382      my %seenmerged;
 383
 384      my %common = (
 385                    'show_list_header' => 1,
 386                    'show_list_footer' => 1,
 387                   );
 388
 389      my %section = ();
 390      # Make the include/exclude map
 391      if (not exists $param{bug_status}) {
 392          $param{bug_status} =
 393              get_status_and_filter(map{exists $param{$_}?($_,$param{$_}):()}
 394                                    keys %_get_status_and_filter_params);
 395          @bugs = sort keys %{$param{bug_status}};
 396      }
 397      foreach my $bug (@bugs) {
 398          if (not exists $param{bug_status}{$bug}) {
 399              use Data::Printer;
 400              p $param{bug_status};
 401              die "No status for $bug";
 402          }
 403          my $html = short_bug_status_html(status  => $param{bug_status}{$bug},
 404                                           options => $param{options},
 405                                          ) . "\n";
 406          push @status, [ $bug, $param{bug_status}{$bug}, $html ];
 407      }
 408      if ($param{bug_order} eq 'age') {
 409           # MWHAHAHAHA
 410           @status = sort {$a->[1]{log_modified} <=> $b->[1]{log_modified}} @status;
 411      }
 412      elsif ($param{bug_order} eq 'agerev') {
 413           @status = sort {$b->[1]{log_modified} <=> $a->[1]{log_modified}} @status;
 414      }
 415      for my $entry (@status) {
 416           my $key = "";
 417           for my $i (0..$#{$param{prior}}) {
 418                my $v = get_bug_order_index($param{prior}[$i], $entry->[1]);
 419                $count{"g_${i}_${v}"}++;
 420                $key .= "_$v";
 421           }
 422           push @{$section{$key}}, $entry->[2];
 423           $count{"_$key"}++;
 424      }
 425
 426      my $result = "";
 427      if ($param{ordering} eq "raw") {
 428           $result .= "<UL class=\"bugs\">\n" . join("", map( { "<li>".$_->[ 2 ] } @status ) ) . "</UL>\n";
 429      }
 430      else {
 431           $header .= "<div class=\"msgreceived\">\n<ul>\n";
 432           my @keys_in_order = ("");
 433           for my $o (@{$param{order}}) {
 434                push @keys_in_order, "X";
 435                while ((my $k = shift @keys_in_order) ne "X") {
 436                     for my $k2 (@{$o}) {
 437                          $k2+=0;
 438                          push @keys_in_order, "${k}_${k2}";
 439                     }
 440                }
 441           }
 442           for my $order (@keys_in_order) {
 443                next unless defined $section{$order} and @{$section{$order}};
 444                my @ttl = split /_/, $order;
 445                shift @ttl;
 446                my $title = $param{title}[0]->[$ttl[0]] . " bugs";
 447                if ($#ttl > 0) {
 448                     $title .= " -- ";
 449                     $title .= join("; ", grep {($_ || "") ne ""}
 450                                    map { $param{title}[$_]->[$ttl[$_]] } 1..$#ttl);
 451                }
 452                $title = html_escape($title);
 453
 454                my $count = $count{"_$order"};
 455                my $bugs = $count == 1 ? "bug" : "bugs";
 456
 457                $header .= "<li><a href=\"#$order\">$title</a> ($count $bugs)</li>\n";
 458                if ($common{show_list_header}) {
 459                     my $count = $count{"_$order"};
 460                     my $bugs = $count == 1 ? "bug" : "bugs";
 461                     $result .= "<H2 CLASS=\"outstanding\"><a name=\"$order\"></a>$title ($count $bugs)</H2>\n";
 462                }
 463                else {
 464                     $result .= "<H2 CLASS=\"outstanding\">$title</H2>\n";
 465                }
 466                $result .= "<div class=\"msgreceived\">\n<UL class=\"bugs\">\n";
 467                $result .= "\n\n\n\n";
 468                $result .= join("",@{$section{$order}||[]});
 469                $result .= "\n\n\n\n";
 470                $result .= "</UL>\n</div>\n";
 471           }
 472           $header .= "</ul></div>\n";
 473
 474           $footer .= "<div class=\"msgreceived\">\n<ul>\n";
 475           for my $i (0..$#{$param{prior}}) {
 476                my $local_result = '';
 477                foreach my $key ( @{$param{order}[$i]} ) {
 478                     my $count = $count{"g_${i}_$key"};
 479                     next if !$count or !$param{title}[$i]->[$key];
 480                     $local_result .= "<li>$count $param{title}[$i]->[$key]</li>\n";
 481                }
 482                if ( $local_result ) {
 483                     $footer .= "<li>$param{names}[$i]<ul>\n$local_result</ul></li>\n";
 484                }
 485           }
 486           $footer .= "</ul>\n</div>\n";
 487      }
 488
 489      $result = $header . $result if ( $common{show_list_header} );
 490      $result .= $footer if ( $common{show_list_footer} );
 491      return $result;
 492 }
 493
 494 sub get_bug_order_index {
 495      my $order = shift;
 496      my $status = shift;
 497      my $pos = -1;
 498
 499      my %tags = ();
 500      %tags = map { $_, 1 } split / /, $status->{"tags"}
 501           if defined $status->{"tags"};
 502
 503      for my $el (@${order}) {
 504           $pos++;
 505           my $match = 1;
 506           for my $item (split /[+]/, $el) {
 507                my ($f, $v) = split /=/, $item, 2;
 508                next unless (defined $f and defined $v);
 509                my $isokay = 0;
 510                $isokay = 1 if (defined $status->{$f} and $v eq $status->{$f});
 511                $isokay = 1 if ($f eq "tag" && defined $tags{$v});
 512                unless ($isokay) {
 513                     $match = 0;
 514                     last;
 515                }
 516           }
 517           if ($match) {
 518                return $pos;
 519                last;
 520           }
 521      }
 522      return $pos + 1;
 523 }
 524
 525 # sets: my @names; my @prior; my @title; my @order;
 526
 527 sub determine_ordering {
 528      my %param = validate_with(params => \@_,
 529                               spec => {cats => {type => HASHREF,
 530                                                },
 531                                        param => {type => HASHREF,
 532                                                 },
 533                                        ordering => {type => SCALARREF,
 534                                                    },
 535                                        names    => {type => ARRAYREF,
 536                                                    },
 537                                        pend_rev => {type => BOOLEAN,
 538                                                     default => 0,
 539                                                    },
 540                                        sev_rev  => {type => BOOLEAN,
 541                                                     default => 0,
 542                                                    },
 543                                        prior    => {type => ARRAYREF,
 544                                                    },
 545                                        title    => {type => ARRAYREF,
 546                                                    },
 547                                        order    => {type => ARRAYREF,
 548                                                    },
 549                                       },
 550                              );
 551      $param{cats}{status}[0]{ord} = [ reverse @{$param{cats}{status}[0]{ord}} ]
 552           if ($param{pend_rev});
 553      $param{cats}{severity}[0]{ord} = [ reverse @{$param{cats}{severity}[0]{ord}} ]
 554           if ($param{sev_rev});
 555
 556      my $i;
 557      if (defined $param{param}{"pri0"}) {
 558           my @c = ();
 559           $i = 0;
 560           while (defined $param{param}{"pri$i"}) {
 561                my $h = {};
 562
 563                my ($pri) = make_list($param{param}{"pri$i"});
 564                if ($pri =~ m/^([^:]*):(.*)$/) {
 565                     $h->{"nam"} = $1; # overridden later if necesary
 566                     $h->{"pri"} = [ map { "$1=$_" } (split /,/, $2) ];
 567                }
 568                else {
 569                     $h->{"pri"} = [ split /,/, $pri ];
 570                }
 571
 572                ($h->{"nam"}) = make_list($param{param}{"nam$i"})
 573                     if (defined $param{param}{"nam$i"});
 574                $h->{"ord"} = [ map {split /\s*,\s*/} make_list($param{param}{"ord$i"}) ]
 575                     if (defined $param{param}{"ord$i"});
 576                $h->{"ttl"} = [ map {split /\s*,\s*/} make_list($param{param}{"ttl$i"}) ]
 577                     if (defined $param{param}{"ttl$i"});
 578
 579                push @c, $h;
 580                $i++;
 581           }
 582           $param{cats}{"_"} = [@c];
 583           ${$param{ordering}} = "_";
 584      }
 585
 586      ${$param{ordering}} = "normal" unless defined $param{cats}{${$param{ordering}}};
 587
 588      sub get_ordering {
 589           my @res;
 590           my $cats = shift;
 591           my $o = shift;
 592           for my $c (@{$cats->{$o}}) {
 593                if (ref($c) eq "HASH") {
 594                     push @res, $c;
 595                }
 596                else {
 597                     push @res, get_ordering($cats, $c);
 598                }
 599           }
 600           return @res;
 601      }
 602      my @cats = get_ordering($param{cats}, ${$param{ordering}});
 603
 604      sub toenglish {
 605           my $expr = shift;
 606           $expr =~ s/[+]/ and /g;
 607           $expr =~ s/[a-z]+=//g;
 608           return $expr;
 609      }
 610
 611      $i = 0;
 612      for my $c (@cats) {
 613           $i++;
 614           push @{$param{prior}}, $c->{"pri"};
 615           push @{$param{names}}, ($c->{"nam"} || "Bug attribute #" . $i);
 616           if (defined $c->{"ord"}) {
 617                push @{$param{order}}, $c->{"ord"};
 618           }
 619           else {
 620                push @{$param{order}}, [ 0..$#{$param{prior}[-1]} ];
 621           }
 622           my @t = @{ $c->{"ttl"} } if defined $c->{ttl};
 623           if (@t < $#{$param{prior}[-1]}) {
 624                push @t, map { toenglish($param{prior}[-1][$_]) } @t..($#{$param{prior}[-1]});
 625           }
 626           push @t, $c->{"def"} || "";
 627           push @{$param{title}}, [@t];
 628      }
 629 }
 630
 631
 632
 633
 634 1;
 635
 636
 637 __END__
 638
 639
 640
 641
 642
 643