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 width height)],
+ default => {package => 'xterm',
+ found => [],
+ fixed => [],
+ ignore_boring => 1,
+ format => 'png',
+ width => undef,
+ height => undef,
+ },
+ );
# 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 (@{$config{distributions}}) {
$versions{$dist} = [getversions($cgi_var{package},$dist)];
# make version_to_dist
foreach my $version (@{$versions{$dist}}){
push @{$version_to_dist{$version}}, $dist;
}
}
-# then figure out which are affected.
-my $srchash = substr $cgi_var{package}, 0, 1;
+if (defined $cgi_var{width}) {
+ $cgi_var{width} =~ /(\d+)/;
+ $cgi_var{width} = $1;
+}
+if (defined $cgi_var{height}) {
+ $cgi_var{height} =~ /(\d+)/;
+ $cgi_var{height} = $1;
+}
+
+if (defined $cgi_var{format}) {
+ $cgi_var{format} =~ /(png|svg|jpg|gif)/;
+ $cgi_var{format} = $1 || 'png';
+}
+else {
+ $cgi_var{format} = 'png';
+}
+
+# then figure out which are affected.
+# 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}};
+@sources{map {m{(.+)/}; $1} @interesting_versions} = (1) x @interesting_versions;
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}}) {
my %all_states = $version->allstates($cgi_var{found},$cgi_var{fixed});
my $dot = "digraph G {\n";
+if (defined $cgi_var{width} and defined $cgi_var{height}) {
+ $dot .= qq(size="$cgi_var{width},$cgi_var{height}";\n);
+}
my %state = (found => ['fillcolor="salmon"',
'style="filled"',
'shape="diamond"',
'shape="rect"',
],
);
+# TODO: Allow collapsing versions which are at the same state and not
+# in a suite.
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 / blobdiff