--- /dev/null
+# 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 <don@donarmstrong.com>.
+
+
+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} '<p>';
+ print {$output} (@maint > 1? "Maintainer for $showpkg is "
+ : "Maintainers for $showpkg are ") .
+ package_links(maintainer => \@maint);
+ print {$output} ".</p>\n";
+ }
+ else {
+ print {$output} "<p>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. </p>\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} "<p>You may want to refer to the following packages that are part of the same source:\n";
+ }
+ else {
+ print {$output} "<p>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 <a href=\"$config{web_domain}/pseudo-packages$config{html_suffix}\">".
+ "list of other pseudo-packages</a>";
+ }
+ else {
+ if ($package and defined $config{package_pages} and length $config{package_pages}) {
+ push @references, sprintf "to the <a href=\"%s\">%s package page</a>",
+ 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 <a href=").html_escape("$config{package_tracking_domain}/$ptslink").q(">Package Tracking System</a>);
+ }
+ # 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} "<p>You might like to refer ", join(", ", @references), ".</p>\n";
+ }
+ if (@maint) {
+ print {$output} "<p>If you find a bug not listed here, please\n";
+ printf {$output} "<a href=\"%s\">report it</a>.</p>\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 = "<h2 class=\"outstanding\">Summary</h2>\n";
+
+ if ($bugs->count == 0) {
+ return "<HR><H2>No reports found!</H2></HR>\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 = "<li>"; #<a href=\"%s\">#%d: %s</a>\n<br>",
+ $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 .= "<UL class=\"bugs\">\n" . join("", map( { $_->[ 1 ] } @status ) ) . "</UL>\n";
+ }
+ else {
+ $header .= "<div class=\"msgreceived\">\n<ul>\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 .= "<li><a href=\"#$order\">$title</a> ($count $bugs)</li>\n";
+ if ($common{show_list_header}) {
+ my $count = $count{"_$order"};
+ my $bugs = $count == 1 ? "bug" : "bugs";
+ $result .= "<H2 CLASS=\"outstanding\"><a name=\"$order\"></a>$title ($count $bugs)</H2>\n";
+ }
+ else {
+ $result .= "<H2 CLASS=\"outstanding\">$title</H2>\n";
+ }
+ $result .= "<div class=\"msgreceived\">\n<UL class=\"bugs\">\n";
+ $result .= "\n\n\n\n";
+ $result .= $section{$order};
+ $result .= "\n\n\n\n";
+ $result .= "</UL>\n</div>\n";
+ }
+ $header .= "</ul></div>\n";
+
+ $footer .= "<div class=\"msgreceived\">\n<ul>\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 .= "<li>$count $param{title}[$i]->[$key]</li>\n";
+ }
+ if ( $local_result ) {
+ $footer .= "<li>$param{names}[$i]<ul>\n$local_result</ul></li>\n";
+ }
+ }
+ $footer .= "</ul>\n</div>\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>^|,|\+) # joiner
+ (?<field>package|tag|pending|severity) # field
+ = # equals
+ (?<value>[^=|\&,\+]+(?:,[^=|\&,\+])*) #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__
+
+
+
+
+
+
projects / debbugs.git / blobdiff