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