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 munge_url);
21 use Debbugs::Versions;
22 use Debbugs::Versions::Dpkg;
23 use Debbugs::Packages qw(get_versions 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 width height collapse info)],
38 default => {package => 'spamass-milter',
49 my $this = munge_url('version.cgi?',
53 # we want to first load the appropriate file,
54 # then figure out which versions are there in which architectures,
57 for my $dist (@{$config{distributions}}) {
58 $versions{$dist} = [get_versions(package => [split /\s*,\s*/, $cgi_var{package}],
62 # make version_to_dist
63 foreach my $version (@{$versions{$dist}}){
64 push @{$version_to_dist{$version}}, $dist;
68 if (defined $cgi_var{width}) {
69 $cgi_var{width} =~ /(\d+)/;
72 if (defined $cgi_var{height}) {
73 $cgi_var{height} =~ /(\d+)/;
74 $cgi_var{height} = $1;
77 if (defined $cgi_var{format}) {
78 $cgi_var{format} =~ /(png|svg|jpg|gif)/;
79 $cgi_var{format} = $1 || 'png';
82 $cgi_var{format} = 'png';
85 if ($cgi_var{info} and not defined $cgi_var{dot}) {
86 print "Content-Type: text/html\n\n";
88 <!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
90 <head><title>$cgi_var{package} Version Graph</title></head>
93 print '<a href="'.html_escape(munge_url($this,ignore_boring=>$cgi_var{ignore_boring}?0:1)).
94 '">['.($cgi_var{ignore_boring}?"Don't i":'I').'gnore boring]</a> ';
95 print '<a href="'.html_escape(munge_url($this,collapse=>$cgi_var{collapse}?0:1)).
96 '">['.($cgi_var{collapse}?"Don't c":'C').'ollapse]</a> ';
97 print '<a href="'.html_escape(munge_url($this,dot=>1)).
99 print '<img src="'.html_escape(munge_url($this,info=>0)).'">';
107 # then figure out which are affected.
108 # turn found and fixed into full versions
109 @{$cgi_var{found}} = map {makesourceversions($_,undef,@{$cgi_var{found}})} split/\s*,\s*/, $cgi_var{package};
110 @{$cgi_var{fixed}} = map {makesourceversions($_,undef,@{$cgi_var{fixed}})} split/\s*,\s*/, $cgi_var{package};
111 my @interesting_versions = map {makesourceversions($_,undef,keys %version_to_dist)} split/\s*,\s*/, $cgi_var{package};
113 # We need to be able to rip out leaves which the versions that do not affect the current versions of unstable/testing
115 @sources{map {m{(.+)/}; $1} @{$cgi_var{found}}} = (1) x @{$cgi_var{found}};
116 @sources{map {m{(.+)/}; $1} @{$cgi_var{fixed}}} = (1) x @{$cgi_var{fixed}};
117 @sources{map {m{(.+)/}; $1} @interesting_versions} = (1) x @interesting_versions;
118 my $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
119 foreach my $source (keys %sources) {
120 my $srchash = substr $source, 0, 1;
121 my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$source", 'r';
122 $version->load($version_fh);
124 # Here, we need to generate a short version to full version map
126 foreach my $key (keys %{$version->{parent}}) {
127 my ($short_version) = $key =~ m{/(.+)$};
128 next unless length $short_version;
129 # we let the first short version have presidence.
130 $version_map{$short_version} = $key if not exists $version_map{$short_version};
132 # Turn all short versions into long versions
133 for my $found_fixed (qw(found fixed)) {
134 $cgi_var{$found_fixed} =
137 if ($_ !~ m{/}) { # short version
140 else { # long version
143 } @{$cgi_var{$found_fixed}}
146 my %all_states = $version->allstates($cgi_var{found},$cgi_var{fixed});
148 my $dot = "digraph G {\n";
149 if (defined $cgi_var{width} and defined $cgi_var{height}) {
150 $dot .= qq(size="$cgi_var{width},$cgi_var{height}";\n);
152 my %state = (found => ['fillcolor="salmon"',
156 absent => ['fillcolor="grey"',
160 fixed => ['fillcolor="chartreuse"',
165 # TODO: Allow collapsing versions which are at the same state and not
169 if ($cgi_var{collapse}) {
171 foreach my $key (keys %{$version->{parent}}) {
172 next if $cgi_var{ignore_boring} and (not defined $all_states{$key}
173 or $all_states{$key} eq 'absent');
174 next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
175 if (defined $version->{parent}{$key}) {
176 next if $cgi_var{ignore_boring} and (not defined $all_states{$version->{parent}{$key}}
177 or $all_states{$version->{parent}{$key}} eq 'absent');
178 next if $cgi_var{ignore_boring} and not version_relevant($version,$version->{parent}{$key},\@interesting_versions);
179 push @{$reversed_nodes{$version->{parent}{$key}}},$key;
182 $reversed_nodes{$key} ||=[];
185 # nodes that can be collapsed are those that have one child
186 # are in the same state as their parent, and are not in a suite
187 foreach my $key (keys %reversed_nodes) {
188 my ($short_version) = $key =~ m{/(.+)$};
189 if (not exists $version_to_dist{$short_version}
190 and @{$reversed_nodes{$key}} <= 1
191 and defined $version->{parent}{$key}
192 and $all_states{$key} eq $all_states{$version->{parent}{$key}}
194 # check to see if there is an entry for the parent or child of this node
196 if ((@{$reversed_nodes{$key}} and exists $collapsed_nodes{$reversed_nodes{$key}[0]})) {
197 $group_node = $collapsed_nodes{$reversed_nodes{$key}[0]};
198 if ($group_nodes{$group_node}{parent} eq $key) {
199 $group_nodes{$group_node}{parent} = $version->{parent}{$key};
202 if (defined $version->{parent}{$key} and exists $collapsed_nodes{$version->{parent}{$key}}) {
203 if (defined $group_node) {
205 my $collapser = $group_nodes{$collapsed_nodes{$version->{parent}{$key}}};
206 push @{$collapser->{collapsed_nodes}},@{$group_nodes{$group_node}{collapsed_nodes}},$group_node;
207 foreach (@{$collapser->{collapsed_nodes}}) {
208 if (exists $group_nodes{$_}) {
209 $group_nodes{$_} = $collapser;
213 $group_node = $collapsed_nodes{$version->{parent}{$key}};
215 if (not defined $group_node) {
216 $group_node = "group_$key";
217 $group_nodes{$group_node} = {attr => qq("$group_node" [).join(',','label="some versions"',
218 @{$state{$all_states{$key}}},
219 'style="bold,filled"',
222 parent => $version->{parent}{$key},
223 collapsed_nodes => [],
226 $collapsed_nodes{$key} = $group_node;
230 foreach my $group (values %group_nodes) {
231 next if $used_node{$group->{name}};
232 $used_node{$group->{name}} = 1;
233 $dot .= $group->{attr};
237 foreach my $key (keys %all_states) {
238 my ($short_version) = $key =~ m{/(.+)$};
239 next if exists $collapsed_nodes{$key};
240 next if $cgi_var{ignore_boring} and (not defined $all_states{$key}
241 or $all_states{$key} eq 'absent');
242 next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
243 my @attributes = @{$state{$all_states{$key}}};
244 if (length $short_version and exists $version_to_dist{$short_version}) {
245 push @attributes, 'label="'.$key.'\n'."(".join(', ',@{$version_to_dist{$short_version}}).")\"";
247 my $node_attributes = qq("$key" [).join(',',@attributes).qq(]\n);
248 $dot .= $node_attributes;
251 foreach my $key (keys %{$version->{parent}}) {
252 next if not defined $version->{parent}{$key};
253 next if $cgi_var{ignore_boring} and $all_states{$key} eq 'absent';
254 next if $cgi_var{ignore_boring} and (not defined $all_states{$version->{parent}{$key}}
255 or $all_states{$version->{parent}{$key}} eq 'absent');
256 # Ignore branches which are not ancestors of a currently distributed version
257 next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
258 next if exists $collapsed_nodes{$key};
259 $dot .= qq("$key").'->'.q(").
260 (exists $collapsed_nodes{$version->{parent}{$key}}?
261 $group_nodes{$collapsed_nodes{$version->{parent}{$key}}}{name}:$version->{parent}{$key}).
262 qq(" [dir="back"])."\n" if defined $version->{parent}{$key};
264 if ($cgi_var{collapse}) {
266 foreach my $group (values %group_nodes) {
267 next if $used_node{$group->{name}};
268 next if not defined $group->{parent};
269 $used_node{$group->{name}} = 1;
270 $dot .= qq("$group->{name}").'->'.q(").
271 (exists $collapsed_nodes{$group->{parent}}?
272 $group_nodes{$collapsed_nodes{$group->{parent}}}{name}:$group->{parent}).
273 qq(" [dir="back"])."\n";
278 my $temp_dir = tempdir(CLEANUP => 1);
280 if (not defined $cgi_var{dot}) {
281 my $dot_fh = new IO::File "$temp_dir/temp.dot",'w' or
282 die "Unable to open $temp_dir/temp.dot for writing: $!";
283 print {$dot_fh} $dot or die "Unable to print output to the dot file: $!";
284 close $dot_fh or die "Unable to close the dot file: $!";
285 system('dot','-T'.$cgi_var{format},"$temp_dir/temp.dot",'-o',"$temp_dir/temp.$cgi_var{format}") == 0
286 or print "Content-Type: text\n\nDot failed." and die "Dot failed: $?";
287 my $img_fh = new IO::File "$temp_dir/temp.$cgi_var{format}", 'r' or
288 die "Unable to open $temp_dir/temp.$cgi_var{format} for reading: $!";
289 print "Content-Type: $img_types{$cgi_var{format}}\n\n";
294 print "Content-Type: text\n\n";
299 our %_version_relevant_cache;
300 sub version_relevant {
301 my ($version,$test_version,$relevant_versions) = @_;
302 for my $dist_version (@{$relevant_versions}) {
303 if (exists $_version_relevant_cache{$dist_version}{$test_version}{$version}) {
304 return 1 if $_version_relevant_cache{$dist_version}{$test_version}{$version};
307 my $rel = $version->isancestor($test_version,$dist_version);
308 $_version_relevant_cache{$dist_version}{$test_version}{$version} = $rel;