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 cgi_parameters);
21 use Debbugs::Versions;
22 use Debbugs::Versions::Dpkg;
23 use Debbugs::Packages qw(getversions makesourceversions);
24 use HTML::Entities qw(encode_entities);
25 use File::Temp qw(tempdir);
30 my %img_types = (svg => 'image/svg+xml',
34 my $q = new CGI::Simple;
36 my %cgi_var = cgi_parameters(query => $q,
37 single => [qw(package format ignore_boring)],
38 default => {package => 'xterm',
46 # we want to first load the appropriate file,
47 # then figure out which versions are there in which architectures,
50 for my $dist (qw(oldstable stable testing unstable experimental)) {
51 $versions{$dist} = [getversions($cgi_var{package},$dist)];
52 # make version_to_dist
53 foreach my $version (@{$versions{$dist}}){
54 push @{$version_to_dist{$version}}, $dist;
57 # then figure out which are affected.
58 # turn found and fixed into full versions
59 @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
60 @{$cgi_var{fixed}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{fixed}});
61 my @interesting_versions = makesourceversions($cgi_var{package},undef,keys %version_to_dist);
63 # We need to be able to rip out leaves which the versions that do not affect the current versions of unstable/testing
65 @sources{map {m{(.+)/}; $1} @{$cgi_var{found}}} = (1) x @{$cgi_var{found}};
66 @sources{map {m{(.+)/}; $1} @{$cgi_var{fixed}}} = (1) x @{$cgi_var{fixed}};
67 my $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
68 foreach my $source (keys %sources) {
69 my $srchash = substr $source, 0, 1;
70 my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$source", 'r';
71 $version->load($version_fh);
73 # Here, we need to generate a short version to full version map
75 foreach my $key (keys %{$version->{parent}}) {
76 my ($short_version) = $key =~ m{/(.+)$};
77 next unless length $short_version;
78 # we let the first short version have presidence.
79 $version_map{$short_version} = $key if not exists $version_map{$short_version};
81 # Turn all short versions into long versions
82 for my $found_fixed (qw(found fixed)) {
83 $cgi_var{$found_fixed} =
86 if ($_ !~ m{/}) { # short version
92 } @{$cgi_var{$found_fixed}}
95 my %all_states = $version->allstates($cgi_var{found},$cgi_var{fixed});
97 my $dot = "digraph G {\n";
98 my %state = (found => ['fillcolor="salmon"',
102 absent => ['fillcolor="grey"',
105 fixed => ['fillcolor="chartreuse"',
110 foreach my $key (keys %all_states) {
111 my ($short_version) = $key =~ m{/(.+)$};
112 next if $cgi_var{ignore_boring} and (not defined $all_states{$key}
113 or $all_states{$key} eq 'absent');
114 next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
115 my @attributes = @{$state{$all_states{$key}}};
116 if (length $short_version and exists $version_to_dist{$short_version}) {
117 push @attributes, 'label="'.$key.'\n'."(".join(', ',@{$version_to_dist{$short_version}}).")\"";
119 my $node_attributes = qq("$key" [).join(',',@attributes).qq(]\n);
120 $dot .= $node_attributes;
122 foreach my $key (keys %{$version->{parent}}) {
123 next if not defined $version->{parent}{$key};
124 next if $cgi_var{ignore_boring} and $all_states{$key} eq 'absent';
125 next if $cgi_var{ignore_boring} and (not defined $all_states{$version->{parent}{$key}}
126 or $all_states{$version->{parent}{$key}} eq 'absent');
127 # Ignore branches which are not ancestors of a currently distributed version
128 next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
129 $dot .= qq("$key").'->'.qq("$version->{parent}{$key}" [dir="back"])."\n" if defined $version->{parent}{$key};
133 my $temp_dir = tempdir(CLEANUP => 1);
135 if (not defined $cgi_var{dot}) {
136 my $dot_fh = new IO::File "$temp_dir/temp.dot",'w' or
137 die "Unable to open $temp_dir/temp.dot for writing: $!";
138 print {$dot_fh} $dot or die "Unable to print output to the dot file: $!";
139 close $dot_fh or die "Unable to close the dot file: $!";
140 system('dot','-T'.$cgi_var{format},"$temp_dir/temp.dot",'-o',"$temp_dir/temp.$cgi_var{format}") == 0
141 or print "Content-Type: text\n\nDot failed." and die "Dot failed: $?";
142 my $img_fh = new IO::File "$temp_dir/temp.$cgi_var{format}", 'r' or
143 die "Unable to open $temp_dir/temp.$cgi_var{format} for reading: $!";
144 print "Content-Type: $img_types{$cgi_var{format}}\n\n";
149 print "Content-Type: text\n\n";
154 my %_version_relevant_cache;
155 sub version_relevant {
156 my ($version,$test_version,$relevant_versions) = @_;
157 for my $dist_version (@{$relevant_versions}) {
158 print STDERR "Testing $dist_version against $test_version\n";
159 return 1 if $version->isancestor($test_version,$dist_version);