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