6 # Hack to work on merkel where suexec is in place
8 if ($ENV{HTTP_HOST} eq 'merkel.debian.org') {
9 unshift @INC, qw(/home/don/perl/usr/share/perl5 /home/don/perl/usr/lib/perl5 /home/don/source);
10 $ENV{DEBBUGS_CONFIG_FILE}="/home/don/config_internal";
17 use CGI::Alert 'don@donarmstrong.com';
19 use Debbugs::Config qw(:config);
20 use Debbugs::CGI qw(htmlize_packagelinks html_escape);
21 use Debbugs::Versions;
22 use Debbugs::Versions::Dpkg;
23 use Debbugs::Packages qw(getversions);
24 use HTML::Entities qw(encode_entities);
25 use File::Temp qw(tempdir);
31 my $q = new CGI::Simple;
33 my %cgi_var = cgi_parameters($q);
35 $cgi_var{package} = ['xterm'] if not defined $cgi_var{package};
36 $cgi_var{found} = [] if not defined $cgi_var{found};
37 $cgi_var{fixed} = [] if not defined $cgi_var{fixed};
39 # we only care about one package
40 $cgi_var{package} = $cgi_var{package}[0];
42 # we want to first load the appropriate file,
43 # then figure out which versions are there in which architectures,
46 for my $dist (qw(oldstable stable testing unstable)) {
47 $versions{$dist} = [getversions($cgi_var{package},$dist)];
48 # make version_to_dist
49 foreach my $version (@{$versions{$dist}}){
50 push @{$version_to_dist{$version}}, $dist;
53 # then figure out which are affected.
55 my $srchash = substr $cgi_var{package}, 0, 1;
56 my $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
57 my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$cgi_var{package}", 'r';
58 $version->load($version_fh);
59 # Here, we need to generate a short version to full version map
61 foreach my $key (keys %{$version->{parent}}) {
62 my ($short_version) = $key =~ m{/(.+)$};
63 next unless length $short_version;
64 # we let the first short version have presidence.
65 $version_map{$short_version} = $key if not exists $version_map{$short_version};
67 # Turn all short versions into long versions
68 for my $found_fixed (qw(found fixed)) {
69 $cgi_var{$found_fixed} =
72 if ($_ !~ m{/}) { # short version
78 } @{$cgi_var{$found_fixed}}
81 my %all_states = $version->allstates($cgi_var{found},$cgi_var{fixed});
83 my $dot = "digraph G {\n";
84 my %state = (found => ['fillcolor="salmon"',
88 absent => ['fillcolor="grey"',
91 fixed => ['fillcolor="chartreuse"',
96 foreach my $key (keys %all_states) {
97 my ($short_version) = $key =~ m{/(.+)$};
98 my @attributes = @{$state{$all_states{$key}}};
99 if (length $short_version and exists $version_to_dist{$short_version}) {
100 push @attributes, 'label="'.$key.'\n'."(".join(', ',@{$version_to_dist{$short_version}}).")\"";
102 my $node_attributes = qq("$key" [).join(',',@attributes).qq(]\n);
103 $dot .= $node_attributes;
105 foreach my $key (keys %{$version->{parent}}) {
106 $dot .= qq("$key").'->'.qq("$version->{parent}{$key}" [dir="back"])."\n" if defined $version->{parent}{$key};
110 my $temp_dir = tempdir(CLEANUP => 1);
112 if (not defined $cgi_var{dot}) {
113 my $dot_fh = new IO::File "$temp_dir/temp.dot",'w' or
114 die "Unable to open $temp_dir/temp.dot for writing: $!";
115 print {$dot_fh} $dot or die "Unable to print output to the dot file: $!";
116 close $dot_fh or die "Unable to close the dot file: $!";
117 system('dot','-Tpng',"$temp_dir/temp.dot",'-o',"$temp_dir/temp.png") == 0
118 or print "Content-Type: text\n\nDot failed." and die "Dot failed: $?";
119 my $png_fh = new IO::File "$temp_dir/temp.png", 'r' or
120 die "Unable to open $temp_dir/temp.png for reading: $!";
121 print "Content-Type: image/png\n\n";
126 print "Content-Type: text\n\n";
134 foreach my $paramname ($q->param) {
135 $param{$paramname} = [$q->param($paramname)]