X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=lib%2FDebbugs%2FCGI%2FPkgreport.pm;fp=lib%2FDebbugs%2FCGI%2FPkgreport.pm;h=e3dcc1235bc0d4a3f119d6d5593673e0448f33b8;hb=1e6633a3780f4fd53fc4303852e84d13cdad2dc6;hp=0000000000000000000000000000000000000000;hpb=466f7faff129a5699c7674f59900a92aa256175d;p=debbugs.git diff --git a/lib/Debbugs/CGI/Pkgreport.pm b/lib/Debbugs/CGI/Pkgreport.pm new file mode 100644 index 0000000..e3dcc12 --- /dev/null +++ b/lib/Debbugs/CGI/Pkgreport.pm @@ -0,0 +1,654 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# +# [Other people have contributed to this file; their copyrights should +# be listed here too.] +# Copyright 2008 by Don Armstrong . + + +package Debbugs::CGI::Pkgreport; + +=head1 NAME + +Debbugs::CGI::Pkgreport -- specific routines for the pkgreport cgi script + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); + +use IO::Scalar; +use Params::Validate qw(validate_with :types); + +use Debbugs::Collection::Bug; + +use Carp; +use List::AllUtils qw(apply); + +use Debbugs::Config qw(:config :globals); +use Debbugs::CGI qw(:url :html :util); +use Debbugs::Common qw(:misc :util :date); +use Debbugs::Status qw(:status); +use Debbugs::Bugs qw(bug_filter); +use Debbugs::Packages qw(:mapping); + +use Debbugs::Text qw(:templates); +use Encode qw(decode_utf8); + +use POSIX qw(strftime); + + +BEGIN{ + ($VERSION) = q$Revision: 494 $ =~ /^Revision:\s+([^\s+])/; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (html => [qw(short_bug_status_html pkg_htmlizebugs), + ], + misc => [qw(generate_package_info), + qw(determine_ordering), + ], + ); + @EXPORT_OK = (qw()); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +=head2 generate_package_info + + generate_package_info($srcorbin,$package) + +Generates the informational bits for a package and returns it + +=cut + +sub generate_package_info{ + my %param = validate_with(params => \@_, + spec => {binary => {type => BOOLEAN, + default => 1, + }, + package => {type => SCALAR,#|ARRAYREF, + }, + options => {type => HASHREF, + }, + bugs => {type => ARRAYREF, + }, + schema => {type => OBJECT, + optional => 1, + }, + }, + ); + + my $output_scalar = ''; + my $output = globify_scalar(\$output_scalar); + + my $package = $param{package}; + + my %pkgsrc = %{getpkgsrc()}; + my $srcforpkg = $package; + if ($param{binary}) { + $srcforpkg = + binary_to_source(source_only => 1, + scalar_only => 1, + binary => $package, + hash_slice(%param,qw(schema)), + ); + } + + my $showpkg = html_escape($package); + my @maint = package_maintainer($param{binary}?'binary':'source', + $package, + hash_slice(%param,qw(schema)), + ); + if (@maint) { + print {$output} '

'; + print {$output} (@maint > 1? "Maintainer for $showpkg is " + : "Maintainers for $showpkg are ") . + package_links(maintainer => \@maint); + print {$output} ".

\n"; + } + else { + print {$output} "

There is no maintainer for $showpkg. ". + "This means that this package no longer exists (or never existed). ". + "Please do not report new bugs against this package.

\n"; + } + my @pkgs = source_to_binary(source => $srcforpkg, + hash_slice(%param,qw(schema)), + binary_only => 1, + # if there are distributions, only bother to + # show packages which are currently in a + # distribution. + @{$config{distributions}//[]} ? + (dist => [@{$config{distributions}}]) : (), + ) if defined $srcforpkg; + @pkgs = grep( !/^\Q$package\E$/, @pkgs ); + if ( @pkgs ) { + @pkgs = sort @pkgs; + if ($param{binary}) { + print {$output} "

You may want to refer to the following packages that are part of the same source:\n"; + } + else { + print {$output} "

You may want to refer to the following individual bug pages:\n"; + } + #push @pkgs, $src if ( $src && !grep(/^\Q$src\E$/, @pkgs) ); + print {$output} scalar package_links(package=>[@pkgs]); + print {$output} ".\n"; + } + my @references; + my $pseudodesc = getpseudodesc(); + if ($package and defined($pseudodesc) and exists($pseudodesc->{$package})) { + push @references, "to the ". + "list of other pseudo-packages"; + } + else { + if ($package and defined $config{package_pages} and length $config{package_pages}) { + push @references, sprintf "to the %s package page", + html_escape("$config{package_pages}/$package"), html_escape("$package"); + } + if (defined $config{package_tracking_domain} and + length $config{package_tracking_domain}) { + my $ptslink = $param{binary} ? $srcforpkg : $package; + # the pts only wants the source, and doesn't care about src: (#566089) + $ptslink =~ s/^src://; + push @references, q(to the Package Tracking System); + } + # Only output this if the source listing is non-trivial. + if ($param{binary} and $srcforpkg) { + push @references, + "to the source package ". + package_links(src=>$srcforpkg, + options => $param{options}) . + "'s bug page"; + } + } + if (@references) { + $references[$#references] = "or $references[$#references]" if @references > 1; + print {$output} "

You might like to refer ", join(", ", @references), ".

\n"; + } + if (@maint) { + print {$output} "

If you find a bug not listed here, please\n"; + printf {$output} "report it.

\n", + html_escape("$config{web_domain}/Reporting$config{html_suffix}"); + } + return decode_utf8($output_scalar); +} + + +=head2 short_bug_status_html + + print short_bug_status_html(status => read_bug(bug => 5), + options => \%param, + ); + +=over + +=item status -- status hashref as returned by read_bug + +=item options -- hashref of options to pass to package_links (defaults +to an empty hashref) + +=item bug_options -- hashref of options to pass to bug_links (default +to an empty hashref) + +=item snippet -- optional snippet of information about the bug to +display below + + +=back + + + +=cut + +sub short_bug_status_html { + my %param = validate_with(params => \@_, + spec => {bug => {type => OBJECT, + isa => 'Debbugs::Bug', + }, + }, + ); + + return fill_in_template(template => 'cgi/short_bug_status', + variables => {bug => $param{bug}, + isstrongseverity => \&Debbugs::Status::isstrongseverity, + html_escape => \&Debbugs::CGI::html_escape, + looks_like_number => \&Scalar::Util::looks_like_number, + }, + hole_var => {'&package_links' => \&Debbugs::CGI::package_links, + '&bug_links' => \&Debbugs::CGI::bug_links, + '&version_url' => \&Debbugs::CGI::version_url, + '&secs_to_english' => \&Debbugs::Common::secs_to_english, + '&strftime' => \&POSIX::strftime, + '&maybelink' => \&Debbugs::CGI::maybelink, + }, + ); +} + + +sub pkg_htmlizebugs { + my %param = validate_with(params => \@_, + spec => {bugs => {type => OBJECT, + }, + names => {type => ARRAYREF, + }, + title => {type => ARRAYREF, + }, + prior => {type => ARRAYREF, + }, + order => {type => ARRAYREF, + }, + ordering => {type => SCALAR, + }, + bugusertags => {type => HASHREF, + default => {}, + }, + bug_rev => {type => BOOLEAN, + default => 0, + }, + bug_order => {type => SCALAR, + }, + repeatmerged => {type => BOOLEAN, + default => 1, + }, + include => {type => ARRAYREF, + default => [], + }, + exclude => {type => ARRAYREF, + default => [], + }, + this => {type => SCALAR, + default => '', + }, + options => {type => HASHREF, + default => {}, + }, + dist => {type => SCALAR, + optional => 1, + }, + schema => {type => OBJECT, + optional => 1, + }, + } + ); + my $bugs = $param{bugs}; + my %count; + my $header = ''; + my $footer = "

Summary

\n"; + + if ($bugs->count == 0) { + return "

No reports found!

\n"; + } + + my %seenmerged; + + my %common = ( + 'show_list_header' => 1, + 'show_list_footer' => 1, + ); + + my %section = (); + # Make the include/exclude map + my %include; + my %exclude; + for my $include (make_list($param{include})) { + next unless defined $include; + my ($key,$value) = split /\s*:\s*/,$include,2; + unless (defined $value) { + $key = 'tags'; + $value = $include; + } + push @{$include{$key}}, split /\s*,\s*/, $value; + } + for my $exclude (make_list($param{exclude})) { + next unless defined $exclude; + my ($key,$value) = split /\s*:\s*/,$exclude,2; + unless (defined $value) { + $key = 'tags'; + $value = $exclude; + } + push @{$exclude{$key}}, split /\s*,\s*/, $value; + } + + my $sorter = sub {$_[0]->id <=> $_[1]->id}; + if ($param{bug_rev}) { + $sorter = sub {$_[1]->id <=> $_[0]->id} + } + elsif ($param{bug_order} eq 'age') { + $sorter = sub {$_[0]->modified->epoch <=> $_[1]->modified->epoch}; + } + elsif ($param{bug_order} eq 'agerev') { + $sorter = sub {$_[1]->modified->epoch <=> $_[0]->modified->epoch}; + } + my @status; + for my $bug ($bugs->sort($sorter)) { + next if + $bug->filter(repeat_merged => $param{repeatmerged}, + seen_merged => \%seenmerged, + (keys %include ? (include => \%include):()), + (keys %exclude ? (exclude => \%exclude):()), + ); + + my $html = "
  • "; ##%d: %s\n
    ", + $html .= short_bug_status_html(bug => $bug, + ) . "\n"; + push @status, [ $bug, $html ]; + } + # parse bug order indexes into subroutines + my @order_subs = + map { + my $a = $_; + [map {parse_order_statement_to_subroutine($_)} @{$a}]; + } @{$param{prior}}; + for my $entry (@status) { + my $key = ""; + for my $i (0..$#order_subs) { + my $v = get_bug_order_index($order_subs[$i], $entry->[0]); + $count{"g_${i}_${v}"}++; + $key .= "_$v"; + } + $section{$key} .= $entry->[1]; + $count{"_$key"}++; + } + + my $result = ""; + if ($param{ordering} eq "raw") { + $result .= "\n"; + } + else { + $header .= "
    \n
      \n"; + my @keys_in_order = (""); + for my $o (@{$param{order}}) { + push @keys_in_order, "X"; + while ((my $k = shift @keys_in_order) ne "X") { + for my $k2 (@{$o}) { + $k2+=0; + push @keys_in_order, "${k}_${k2}"; + } + } + } + for my $order (@keys_in_order) { + next unless defined $section{$order}; + my @ttl = split /_/, $order; + shift @ttl; + my $title = $param{title}[0]->[$ttl[0]] . " bugs"; + if ($#ttl > 0) { + $title .= " -- "; + $title .= join("; ", grep {($_ || "") ne ""} + map { $param{title}[$_]->[$ttl[$_]] } 1..$#ttl); + } + $title = html_escape($title); + + my $count = $count{"_$order"}; + my $bugs = $count == 1 ? "bug" : "bugs"; + + $header .= "
    • $title ($count $bugs)
      • \n"; + if ($common{show_list_header}) { + my $count = $count{"_$order"}; + my $bugs = $count == 1 ? "bug" : "bugs"; + $result .= "

      $title ($count $bugs)

      \n"; + } + else { + $result .= "

      $title

      \n"; + } + $result .= "
      \n
        \n"; + $result .= "\n\n\n\n"; + $result .= $section{$order}; + $result .= "\n\n\n\n"; + $result .= "
      \n
      \n"; + } + $header .= "
    \n"; + + $footer .= "
    \n
      \n"; + for my $i (0..$#{$param{prior}}) { + my $local_result = ''; + foreach my $key ( @{$param{order}[$i]} ) { + my $count = $count{"g_${i}_$key"}; + next if !$count or !$param{title}[$i]->[$key]; + $local_result .= "
    • $count $param{title}[$i]->[$key]
      • \n"; + } + if ( $local_result ) { + $footer .= "
    • $param{names}[$i]
        \n$local_result
      • \n"; + } + } + $footer .= "
    \n
    \n"; + } + + $result = $header . $result if ( $common{show_list_header} ); + $result .= $footer if ( $common{show_list_footer} ); + return $result; +} + +sub parse_order_statement_to_subroutine { + my ($statement) = @_; + if (not defined $statement or not length $statement) { + return sub {return 1}; + } + croak "invalid statement '$statement'" unless + $statement =~ /^(?:(package|tag|pending|severity) # field + = # equals + ([^=|\&,\+]+(?:,[^=|\&,+])*) #value + (\+|,|$) # joiner or end + )+ # one or more of these statements + /x; + my @sub_bits; + while ($statement =~ /(?^|,|\+) # joiner + (?package|tag|pending|severity) # field + = # equals + (?[^=|\&,\+]+(?:,[^=|\&,\+])*) #value + /xg) { + my $field = $+{field}; + my $value = $+{value}; + my $joiner = $+{joiner} // ''; + my @vals = apply {quotemeta($_)} split /,/,$value; + if (length $joiner) { + if ($joiner eq '+') { + push @sub_bits, ' and '; + } + else { + push @sub_bits, ' or '; + } + } + my @vals_bits; + for my $val (@vals) { + if ($field =~ /package|severity/o) { + push @vals_bits, '$_[0]->status->'.$field. + ' eq q('.$val.')'; + } elsif ($field eq 'tag') { + push @vals_bits, '$_[0]->tags->is_set('. + 'q('.$val.'))'; + } elsif ($field eq 'pending') { + push @vals_bits, '$_[0]->'.$field. + ' eq q('.$val.')'; + } + } + push @sub_bits ,' ('.join(' or ',@vals_bits).') '; + } + # return a subroutine reference which determines whether an order statement + # matches this bug + my $sub = 'sub { return ('.join ("\n",@sub_bits).');};'; + my $subref = eval $sub; + if ($@) { + croak "Unable to generate subroutine: $@; $sub"; + } + return $subref; +} + +sub parse_order_statement_into_boolean { + my ($statement,$status,$tags) = @_; + + if (not defined $tags) { + $tags = {map { $_, 1 } split / /, $status->{"tags"} + } + if defined $status->{"tags"}; + + } + # replace all + with && + $statement =~ s/\+/&&/g; + # replace all , with || + $statement =~ s/,/||/g; + $statement =~ s{([^\&\|\=]+) # field + = + ([^\&\|\=]+) # value + }{ + my $ok = 0; + if ($1 eq 'tag') { + $ok = 1 if defined $tags->{$2}; + } else { + $ok = 1 if defined $status->{$1} and + $status->{$1} eq $2; + } + $ok; + }exg; + # check that the parsed statement is just valid boolean statements + if ($statement =~ /^([01\(\)\&\|]+)$/) { + return eval "$1"; + } else { + # this is an invalid boolean statement + return 0; + } +} + +sub get_bug_order_index { + my ($order,$bug) = @_; + my $pos = 0; + for my $el (@{$order}) { + if ($el->($bug)) { + return $pos; + } + $pos++; + } + return $pos; +} + +# sets: my @names; my @prior; my @title; my @order; + +sub determine_ordering { + my %param = validate_with(params => \@_, + spec => {cats => {type => HASHREF, + }, + param => {type => HASHREF, + }, + ordering => {type => SCALARREF, + }, + names => {type => ARRAYREF, + }, + pend_rev => {type => BOOLEAN, + default => 0, + }, + sev_rev => {type => BOOLEAN, + default => 0, + }, + prior => {type => ARRAYREF, + }, + title => {type => ARRAYREF, + }, + order => {type => ARRAYREF, + }, + }, + ); + $param{cats}{status}[0]{ord} = [ reverse @{$param{cats}{status}[0]{ord}} ] + if ($param{pend_rev}); + $param{cats}{severity}[0]{ord} = [ reverse @{$param{cats}{severity}[0]{ord}} ] + if ($param{sev_rev}); + + my $i; + if (defined $param{param}{"pri0"}) { + my @c = (); + $i = 0; + while (defined $param{param}{"pri$i"}) { + my $h = {}; + + my ($pri) = make_list($param{param}{"pri$i"}); + if ($pri =~ m/^([^:]*):(.*)$/) { + $h->{"nam"} = $1; # overridden later if necesary + $h->{"pri"} = [ map { "$1=$_" } (split /,/, $2) ]; + } + else { + $h->{"pri"} = [ split /,/, $pri ]; + } + + ($h->{"nam"}) = make_list($param{param}{"nam$i"}) + if (defined $param{param}{"nam$i"}); + $h->{"ord"} = [ map {split /\s*,\s*/} make_list($param{param}{"ord$i"}) ] + if (defined $param{param}{"ord$i"}); + $h->{"ttl"} = [ map {split /\s*,\s*/} make_list($param{param}{"ttl$i"}) ] + if (defined $param{param}{"ttl$i"}); + + push @c, $h; + $i++; + } + $param{cats}{"_"} = [@c]; + ${$param{ordering}} = "_"; + } + + ${$param{ordering}} = "normal" unless defined $param{cats}{${$param{ordering}}}; + + sub get_ordering { + my @res; + my $cats = shift; + my $o = shift; + for my $c (@{$cats->{$o}}) { + if (ref($c) eq "HASH") { + push @res, $c; + } + else { + push @res, get_ordering($cats, $c); + } + } + return @res; + } + my @cats = get_ordering($param{cats}, ${$param{ordering}}); + + sub toenglish { + my $expr = shift; + $expr =~ s/[+]/ and /g; + $expr =~ s/[a-z]+=//g; + return $expr; + } + + $i = 0; + for my $c (@cats) { + $i++; + push @{$param{prior}}, $c->{"pri"}; + push @{$param{names}}, ($c->{"nam"} || "Bug attribute #" . $i); + if (defined $c->{"ord"}) { + push @{$param{order}}, $c->{"ord"}; + } + else { + push @{$param{order}}, [ 0..$#{$param{prior}[-1]} ]; + } + my @t = @{ $c->{"ttl"} } if defined $c->{ttl}; + if (@t < $#{$param{prior}[-1]}) { + push @t, map { toenglish($param{prior}[-1][$_]) } @t..($#{$param{prior}[-1]}); + } + push @t, $c->{"def"} || ""; + push @{$param{title}}, [@t]; + } +} + + + + +1; + + +__END__ + + + + + +