use Debbugs::Config qw(:config);
use Mail::Address;
use POSIX qw(ceil);
+use Storable qw(dclone);
my %URL_PARAMS = ();
html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
qw(maybelink htmlize_addresslinks),
],
- util => [qw(getparsedaddrs)]
+ util => [qw(getparsedaddrs cgi_parameters)]
#status => [qw(getbugstatus)],
);
@EXPORT_OK = ();
return HTML::Entities::encode_entities($string)
}
+=head2 cgi_parameters
+
+ cgi_parameters
+
+Returns all of the cgi_parameters from a CGI script using CGI::Simple
+
+=cut
+
+sub cgi_parameters {
+ my %options = validate_with(params => \@_,
+ spec => {query => {type => OBJECT,
+ can => 'param',
+ },
+ single => {type => ARRAYREF,
+ default => [],
+ },
+ default => {type => HASHREF,
+ default => {},
+ },
+ },
+ );
+ my $q = $options{query};
+ my %single;
+ @single{@{$options{single}}} = (1) x @{$options{single}};
+ my %param;
+ for my $paramname ($q->param) {
+ if ($single{$paramname}) {
+ $param{$paramname} = $q->param($paramname);
+ }
+ else {
+ $param{$paramname} = [$q->param($paramname)];
+ }
+ }
+ for my $default (keys %{$options{default}}) {
+ if (not exists $param{$default}) {
+ # We'll clone the reference here to avoid surprises later.
+ $param{$default} = ref($options{default}{$default})?
+ dclone($options{default}{$default}):$options{default}{$default};
+ }
+ }
+ return %param;
+}
+
+
+
my %common_bugusertags;
# =head2 get_bug_status
#!/usr/bin/perl -wT
-package debbugs;
-
+use warnings;
use strict;
-use POSIX qw(strftime tzset nice);
+use POSIX qw(strftime nice);
-#require '/usr/lib/debbugs/errorlib';
+use Debbugs::Config;
+use CGI::Simple;
+use Debbugs::CGI qw(cgi_parameters);
require './common.pl';
-require '/etc/debbugs/config';
-require '/etc/debbugs/text';
-
nice(5);
-my %param = readparse();
+my $q = new CGI::Simple;
+my %param = cgi_parameters(query => $q,
+ single => [qw(indexon repeatmerged archive sortby),
+ qw(skip max_results first),
+ ],
+ default => {indexon => 'pkg',
+ repeatmerged => 'yes',
+ archive => 'no',
+ sortby => 'alpha',
+ skip => 0,
+ max_results => 100,
+ },
+ );
+
+if (defined $param{first}) {
+ # rip out all non-words from first
+ $param{first} =~ s/\W//g;
+}
+if (defined $param{next}) {
+ $param{skip}+=$param{max_results};
+}
+elsif (defined $param{prev}) {
+ $param{skip}-=$param{max_results};
+ $param{skip} = 0 if $param{skip} < 0;
+}
-my $indexon = $param{'indexon'} || 'pkg';
-if ($indexon !~ m/^(pkg|src|maint|submitter|tag)$/) {
+my $indexon = $param{indexon};
+if ($param{indexon} !~ m/^(pkg|src|maint|submitter|tag)$/) {
quitcgi("You have to choose something to index on");
}
-my $repeatmerged = ($param{'repeatmerged'} || "yes") eq "yes";
-my $archive = ($param{'archive'} || "no") eq "yes";
-my $sortby = $param{'sortby'} || 'alpha';
+my $repeatmerged = $param{repeatmerged} eq 'yes';
+my $archive = $param{archive} eq "yes";
+my $sortby = $param{sortby};
if ($sortby !~ m/^(alpha|count)$/) {
quitcgi("Don't know how to sort like that");
}
-#my $include = $param{'include'} || "";
-#my $exclude = $param{'exclude'} || "";
-
my $Archived = $archive ? " Archived" : "";
my %maintainers = %{&getmaintainers()};
my %strings = ();
-$ENV{"TZ"} = 'UTC';
-tzset();
-
-my $dtime = strftime "%a, %e %b %Y %T UTC", localtime;
-my $tail_html = $debbugs::gHTMLTail;
-$tail_html = $debbugs::gHTMLTail;
+my $dtime = strftime "%a, %e %b %Y %T UTC", gmtime;
+my $tail_html = '';#$gHTMLTail;
+$tail_html = '';#$gHTMLTail;
$tail_html =~ s/SUBSTITUTE_DTIME/$dtime/;
-set_option("repeatmerged", $repeatmerged);
-set_option("archive", $archive);
-#set_option("include", { map {($_,1)} (split /[\s,]+/, $include) })
-# if ($include);
-#set_option("exclude", { map {($_,1)} (split /[\s,]+/, $exclude) })
-# if ($exclude);
-
my %count;
my $tag;
my $note;
if ($indexon eq "pkg") {
$tag = "package";
%count = countbugs(sub {my %d=@_; return splitpackages($d{"pkg"})});
+ if (defined $param{first}) {
+ %count = map {
+ if (/^\Q$param{first}\E/) {
+ ($_,$count{$_});
+ }
+ else {
+ ();
+ }
+ } keys %count;
+ }
$note = "<p>Note that with multi-binary packages there may be other\n";
$note .= "reports filed under the different binary package names.</p>\n";
foreach my $pkg (keys %count) {
} elsif ($indexon eq "src") {
$tag = "source package";
my $pkgsrc = getpkgsrc();
+ if (defined $param{first}) {
+ %count = map {
+ if (/^\Q$param{first}\E/) {
+ ($_,$count{$_});
+ }
+ else {
+ ();
+ }
+ } keys %count;
+ }
%count = countbugs(sub {my %d=@_;
return map {
$pkgsrc->{$_} || $_
map { $_->address } @me;
} splitpackages($d{"pkg"});
});
+ if (defined $param{first}) {
+ %count = map {
+ if (/^\Q$param{first}\E/) {
+ ($_,$count{$_});
+ }
+ else {
+ ();
+ }
+ } keys %count;
+ }
$note = "<p>Note that maintainers may use different Maintainer fields for\n";
$note .= "different packages, so there may be other reports filed under\n";
$note .= "different addresses.</p>\n";
}
map { $_->address } @se;
});
+ if (defined $param{first}) {
+ %count = map {
+ if (/^\Q$param{first}\E/) {
+ ($_,$count{$_});
+ }
+ else {
+ ();
+ }
+ } keys %count;
+ }
foreach my $sub (keys %count) {
$sortkey{$sub} = lc $fullname{$sub};
$htmldescrip{$sub} = sprintf('<a href="%s">%s</a>',
} elsif ($indexon eq "tag") {
$tag = "tag";
%count = countbugs(sub {my %d=@_; return split ' ', $d{tags}; });
+ if (defined $param{first}) {
+ %count = map {
+ if (/^\Q$param{first}\E/) {
+ ($_,$count{$_});
+ }
+ else {
+ ();
+ }
+ } keys %count;
+ }
$note = "";
foreach my $keyword (keys %count) {
$sortkey{$keyword} = lc $keyword;
} else { # sortby alpha
@orderedentries = sort { $sortkey{$a} cmp $sortkey{$b} } keys %count;
}
+my $skip = $param{skip};
+my $max_results = $param{max_results};
foreach my $x (@orderedentries) {
+ if (not defined $param{first}) {
+ $skip-- and next if $skip > 0;
+ last if --$max_results < 0;
+ }
$result .= "<li>" . $htmldescrip{$x} . " has $count{$x} " .
($count{$x} == 1 ? "bug" : "bugs") . "</li>\n";
}
"</H1>\n";
print $note;
+print <<END;
+<form>
+<input type="hidden" name="skip" value="$param{skip}">
+<input type="hidden" name="max_results" value="$param{max_results}">
+<input type="hidden" name="indexon" value="$param{indexon}">
+<input type="hidden" name="repeatmerged" value="$param{repeatmerged}">
+<input type="hidden" name="archive" value="$param{archive}">
+<input type="hidden" name="sortby" value="$param{sortby}">
+END
+if (defined $param{first}) {
+ print qq(<input type="hidden" name="first" value="$param{first}">\n);
+}
+else {
+ print q(<p>);
+ if ($param{skip} > 0) {
+ print q(<input type="submit" name="prev" value="Prev">);
+ }
+ if (keys %count > ($param{skip} + $param{max_results})) {
+ print q(<input type="submit" name="next" value="Next">);
+ }
+ print qq(</p>\n);
+}
print $result;
print "<hr>\n";
use Search::Estraier;
use Debbugs::Config qw(:config);
use Debbugs::Estraier;
-use Debbugs::CGI qw(htmlize_packagelinks html_escape);
+use Debbugs::CGI qw(htmlize_packagelinks html_escape cgi_parameters);
use HTML::Entities qw(encode_entities);
my $q = new CGI::Simple;
#my %var_defaults = (attr => 1,);
-my %cgi_var = cgi_parameters($q);
+my %cgi_var = cgi_parameters(query => $q,
+ single => [qw(phrase max_results order_field order_operator),
+ qw(skip prev next),
+ ],
+ default => {phrase => '',
+ max_results => 10,
+ skip => 0,
+ }.
+ );
-$cgi_var{phrase} = '' if not defined $cgi_var{phrase};
-$cgi_var{max_results} = 10 if not defined $cgi_var{max_results};
$cgi_var{attribute} = parse_attribute(\%cgi_var) || [];
-$cgi_var{skip} = 0 if not defined $cgi_var{skip};
my @results;
}
return \@attributes;
}
-
-
-sub cgi_parameters {
- my ($q) = @_;
-
- my %param;
- foreach my $paramname ($q->param) {
- my @value = $q->param($paramname);
- $param{$paramname} = @value > 1 ? [@value] : $value[0];
- }
- return %param;
-}
use CGI::Alert 'don@donarmstrong.com';
use Debbugs::Config qw(:config);
-use Debbugs::CGI qw(htmlize_packagelinks html_escape);
+use Debbugs::CGI qw(htmlize_packagelinks html_escape cgi_parameters);
use Debbugs::Versions;
use Debbugs::Versions::Dpkg;
-use Debbugs::Packages qw(getversions);
+use Debbugs::Packages qw(getversions makesourceversions);
use HTML::Entities qw(encode_entities);
use File::Temp qw(tempdir);
use IO::File;
use IO::Handle;
+my %img_types = (svg => 'image/svg+xml',
+ png => 'image/png',
+ );
my $q = new CGI::Simple;
-my %cgi_var = cgi_parameters($q);
-
-$cgi_var{package} = ['xterm'] if not defined $cgi_var{package};
-$cgi_var{found} = [] if not defined $cgi_var{found};
-$cgi_var{fixed} = [] if not defined $cgi_var{fixed};
-
-# we only care about one package
-$cgi_var{package} = $cgi_var{package}[0];
+my %cgi_var = cgi_parameters(query => $q,
+ single => [qw(package format ignore_boring)],
+ default => {package => 'xterm',
+ found => [],
+ fixed => [],
+ ignore_boring => 1,
+ format => 'png',
+ },
+ );
# we want to first load the appropriate file,
# then figure out which versions are there in which architectures,
my %versions;
my %version_to_dist;
-for my $dist (qw(oldstable stable testing unstable)) {
+for my $dist (qw(oldstable stable testing unstable experimental)) {
$versions{$dist} = [getversions($cgi_var{package},$dist)];
# make version_to_dist
foreach my $version (@{$versions{$dist}}){
}
}
# then figure out which are affected.
-
-my $srchash = substr $cgi_var{package}, 0, 1;
+# turn found and fixed into full versions
+@{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
+@{$cgi_var{fixed}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{fixed}});
+my @interesting_versions = makesourceversions($cgi_var{package},undef,keys %version_to_dist);
+
+# We need to be able to rip out leaves which the versions that do not affect the current versions of unstable/testing
+my %sources;
+@sources{map {m{(.+)/}; $1} @{$cgi_var{found}}} = (1) x @{$cgi_var{found}};
+@sources{map {m{(.+)/}; $1} @{$cgi_var{fixed}}} = (1) x @{$cgi_var{fixed}};
my $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
-my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$cgi_var{package}", 'r';
-$version->load($version_fh);
+foreach my $source (keys %sources) {
+ my $srchash = substr $source, 0, 1;
+ my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$source", 'r';
+ $version->load($version_fh);
+}
# Here, we need to generate a short version to full version map
my %version_map;
foreach my $key (keys %{$version->{parent}}) {
);
foreach my $key (keys %all_states) {
my ($short_version) = $key =~ m{/(.+)$};
+ next if $cgi_var{ignore_boring} and (not defined $all_states{$key}
+ or $all_states{$key} eq 'absent');
+ next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
my @attributes = @{$state{$all_states{$key}}};
if (length $short_version and exists $version_to_dist{$short_version}) {
push @attributes, 'label="'.$key.'\n'."(".join(', ',@{$version_to_dist{$short_version}}).")\"";
$dot .= $node_attributes;
}
foreach my $key (keys %{$version->{parent}}) {
+ next if not defined $version->{parent}{$key};
+ next if $cgi_var{ignore_boring} and $all_states{$key} eq 'absent';
+ next if $cgi_var{ignore_boring} and (not defined $all_states{$version->{parent}{$key}}
+ or $all_states{$version->{parent}{$key}} eq 'absent');
+ # Ignore branches which are not ancestors of a currently distributed version
+ next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
$dot .= qq("$key").'->'.qq("$version->{parent}{$key}" [dir="back"])."\n" if defined $version->{parent}{$key};
}
$dot .= "}\n";
die "Unable to open $temp_dir/temp.dot for writing: $!";
print {$dot_fh} $dot or die "Unable to print output to the dot file: $!";
close $dot_fh or die "Unable to close the dot file: $!";
- system('dot','-Tpng',"$temp_dir/temp.dot",'-o',"$temp_dir/temp.png") == 0
+ system('dot','-T'.$cgi_var{format},"$temp_dir/temp.dot",'-o',"$temp_dir/temp.$cgi_var{format}") == 0
or print "Content-Type: text\n\nDot failed." and die "Dot failed: $?";
- my $png_fh = new IO::File "$temp_dir/temp.png", 'r' or
- die "Unable to open $temp_dir/temp.png for reading: $!";
- print "Content-Type: image/png\n\n";
- print <$png_fh>;
- close $png_fh;
+ my $img_fh = new IO::File "$temp_dir/temp.$cgi_var{format}", 'r' or
+ die "Unable to open $temp_dir/temp.$cgi_var{format} for reading: $!";
+ print "Content-Type: $img_types{$cgi_var{format}}\n\n";
+ print <$img_fh>;
+ close $img_fh;
}
else {
print "Content-Type: text\n\n";
print $dot;
}
-sub cgi_parameters {
- my ($q) = @_;
- my %param;
- foreach my $paramname ($q->param) {
- $param{$paramname} = [$q->param($paramname)]
+my %_version_relevant_cache;
+sub version_relevant {
+ my ($version,$test_version,$relevant_versions) = @_;
+ for my $dist_version (@{$relevant_versions}) {
+ print STDERR "Testing $dist_version against $test_version\n";
+ return 1 if $version->isancestor($test_version,$dist_version);
}
- return %param;
+ return 0;
}
+
+
projects / debbugs.git / commitdiff