6 # Hack to work on merkel where suexec is in place
8 if (defined $ENV{HTTP_HOST} and $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";
14 # if we're running out of git, we want to use the git base directory as the
15 # first INC directory. If you're not running out of git, don't do that.
16 use File::Basename qw(dirname);
21 abs_path(dirname(abs_path(__FILE__)) . '/../');
22 # clear the taint; we'll assume that the absolute path to __FILE__ is the
23 # right path if there's a .git directory there
24 ($debbugs_dir) = $debbugs_dir =~ /([[:print:]]+)/;
25 if (defined $debbugs_dir and
26 -d $debbugs_dir . '/.git/') {
30 # if the first directory in @INC is not an absolute directory, assume that
31 # someone has overridden us via -I.
32 if ($INC[0] !~ /^\//) {
35 use if defined $debbugs_dir, lib => $debbugs_dir;
39 # by default send this message nowhere
40 # use CGI::Alert q(nobody@example.com);
42 use Debbugs::Config qw(:config);
46 use Debbugs::CGI qw(htmlize_packagelinks html_escape cgi_parameters munge_url :cache);
47 use Debbugs::Versions;
48 use Debbugs::Versions::Dpkg;
49 use Debbugs::Packages qw(get_versions make_source_versions);
50 use HTML::Entities qw(encode_entities);
51 use File::Temp qw(tempdir);
56 if (defined $config{database}) {
57 my $s = Debbugs::DB->connect($config{database}) or
58 die "Unable to connect to DB";
59 @schema_arg = ('schema',$s);
62 my %img_types = (svg => 'image/svg+xml',
66 my $q = CGI::Simple->new();
68 my %cgi_var = cgi_parameters(query => $q,
69 single => [qw(package format ignore_boring width height collapse info)],
70 default => {package => 'spamass-milter',
81 my $this = munge_url('version.cgi?',
85 if (defined $cgi_var{width}) {
86 $cgi_var{width} =~ /(\d+)/;
89 if (defined $cgi_var{height}) {
90 $cgi_var{height} =~ /(\d+)/;
91 $cgi_var{height} = $1;
94 if (defined $cgi_var{format}) {
95 $cgi_var{format} =~ /(png|svg|jpg|gif)/;
96 $cgi_var{format} = $1 || 'png';
99 $cgi_var{format} = 'png';
103 if ($cgi_var{info} and not defined $cgi_var{dot}) {
104 $etag = etag_does_not_match(cgi=>$q,
105 additional_data=>[grep {defined $_ ? $_ : ()}
106 @cgi_var{(qw(package ignore_boring),
113 print $q->header(-status => 304);
114 print "304: Not modified\n";
117 print $q->header(-status => 200,
118 -cache_control => 'public, max-age=86400',
120 -content_type => 'text/html',
123 <!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
126 print '<head><title>'.html_escape($cgi_var{package}).' Version Graph</title></head>'."\n";
128 print '<a href="'.html_escape(munge_url($this,ignore_boring=>$cgi_var{ignore_boring}?0:1)).
129 '">['.($cgi_var{ignore_boring}?"Don't i":'I').'gnore boring]</a> ';
130 print '<a href="'.html_escape(munge_url($this,collapse=>$cgi_var{collapse}?0:1)).
131 '">['.($cgi_var{collapse}?"Don't c":'C').'ollapse]</a> ';
132 print '<a href="'.html_escape(munge_url($this,dot=>1)).
134 print '<img src="'.html_escape(munge_url($this,info=>0)).'">';
142 # we want to first load the appropriate file,
143 # then figure out which versions are there in which architectures,
146 for my $dist (@{$config{distributions}}) {
147 $versions{$dist} = [get_versions(package => [split /\s*,\s*/, $cgi_var{package}],
152 # make version_to_dist
153 foreach my $version (@{$versions{$dist}}){
154 push @{$version_to_dist{$version}}, $dist;
158 # then figure out which are affected.
159 # turn found and fixed into full versions
161 map {make_source_versions(package => $_,
162 versions => $cgi_var{found})}
163 split/\s*,\s*/, $cgi_var{package};
165 map {make_source_versions(package =>$_,
166 versions => $cgi_var{fixed})}
167 split/\s*,\s*/, $cgi_var{package};
168 my @interesting_versions =
169 map {make_source_versions(package => $_,
170 versions => [keys %version_to_dist])}
171 split/\s*,\s*/, $cgi_var{package};
173 # We need to be able to rip out leaves which the versions that do not affect the current versions of unstable/testing
175 @sources{map {m{(.+)/}; $1} @{$cgi_var{found}}} = (1) x @{$cgi_var{found}};
176 @sources{map {m{(.+)/}; $1} @{$cgi_var{fixed}}} = (1) x @{$cgi_var{fixed}};
177 @sources{map {m{(.+)/}; $1} @interesting_versions} = (1) x @interesting_versions;
179 # at this point, we know enough to calculate the etag.
182 foreach my $source (sort keys %sources) {
183 my $srchash = substr $source, 0, 1;
184 next unless -e "$config{version_packages_dir}/$srchash/$source";
185 push @versions_files, "$config{version_packages_dir}/$srchash/$source";
188 $etag = etag_does_not_match(cgi=>$q,
189 additional_data=>[@cgi_var{(qw(package ignore_boring),
194 files => [@versions_files
198 print $q->header(-status => 304);
199 print "304: Not modified\n";
203 my $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
204 for my $version_fn (@versions_files) {
205 my $version_fh = IO::File->new($version_fn, 'r') or
206 warn "Unable to open $version_fn for reading: $!";
207 $version->load($version_fh);
209 # Here, we need to generate a short version to full version map
211 foreach my $key (keys %{$version->{parent}}) {
212 my ($short_version) = $key =~ m{/(.+)$};
213 next unless length $short_version;
214 # we let the first short version have presidence.
215 $version_map{$short_version} = $key if not exists $version_map{$short_version};
217 # Turn all short versions into long versions
218 for my $found_fixed (qw(found fixed)) {
219 $cgi_var{$found_fixed} =
222 if ($_ !~ m{/}) { # short version
225 else { # long version
228 } @{$cgi_var{$found_fixed}}
231 my %all_states = $version->allstates($cgi_var{found},$cgi_var{fixed});
233 my $dot = "digraph G {\n";
234 if (defined $cgi_var{width} and defined $cgi_var{height}) {
235 $dot .= qq(size="$cgi_var{width},$cgi_var{height}";\n);
237 my %state = (found => ['fillcolor="salmon"',
241 absent => ['fillcolor="grey"',
245 fixed => ['fillcolor="chartreuse"',
250 # TODO: Allow collapsing versions which are at the same state and not
254 if ($cgi_var{collapse}) {
256 foreach my $key (keys %{$version->{parent}}) {
257 next if $cgi_var{ignore_boring} and (not defined $all_states{$key}
258 or $all_states{$key} eq 'absent');
259 next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
260 if (defined $version->{parent}{$key}) {
261 next if $cgi_var{ignore_boring} and (not defined $all_states{$version->{parent}{$key}}
262 or $all_states{$version->{parent}{$key}} eq 'absent');
263 next if $cgi_var{ignore_boring} and not version_relevant($version,$version->{parent}{$key},\@interesting_versions);
264 push @{$reversed_nodes{$version->{parent}{$key}}},$key;
267 $reversed_nodes{$key} ||=[];
270 # nodes that can be collapsed are those that have one child
271 # are in the same state as their parent, and are not in a suite
272 foreach my $key (keys %reversed_nodes) {
273 if (not exists $version_to_dist{$key}
274 and @{$reversed_nodes{$key}} <= 1
275 and defined $version->{parent}{$key}
276 and $all_states{$key} eq $all_states{$version->{parent}{$key}}
278 # check to see if there is an entry for the parent or child of this node
280 if ((@{$reversed_nodes{$key}} and exists $collapsed_nodes{$reversed_nodes{$key}[0]})) {
281 $group_node = $collapsed_nodes{$reversed_nodes{$key}[0]};
282 if ($group_nodes{$group_node}{parent} eq $key) {
283 $group_nodes{$group_node}{parent} = $version->{parent}{$key};
286 if (defined $version->{parent}{$key} and exists $collapsed_nodes{$version->{parent}{$key}}) {
287 if (defined $group_node) {
289 my $collapser = $group_nodes{$collapsed_nodes{$version->{parent}{$key}}};
290 push @{$collapser->{collapsed_nodes}},@{$group_nodes{$group_node}{collapsed_nodes}},$group_node;
291 foreach (@{$collapser->{collapsed_nodes}}) {
292 if (exists $group_nodes{$_}) {
293 $group_nodes{$_} = $collapser;
297 $group_node = $collapsed_nodes{$version->{parent}{$key}};
299 if (not defined $group_node) {
300 $group_node = "group_$key";
301 $group_nodes{$group_node} = {attr => qq("$group_node" [).join(',','label="some versions"',
302 @{$state{$all_states{$key}}},
303 'style="bold,filled"',
306 parent => $version->{parent}{$key},
307 collapsed_nodes => [],
310 $collapsed_nodes{$key} = $group_node;
314 foreach my $group (values %group_nodes) {
315 next if $used_node{$group->{name}};
316 $used_node{$group->{name}} = 1;
317 $dot .= $group->{attr};
321 foreach my $key (keys %all_states) {
322 next if exists $collapsed_nodes{$key};
323 next if $cgi_var{ignore_boring} and (not defined $all_states{$key}
324 or $all_states{$key} eq 'absent');
325 next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
326 my @attributes = @{$state{$all_states{$key}}};
327 if (exists $version_to_dist{$key}) {
328 push @attributes, 'label="'.$key.'\n'."(".join(', ',@{$version_to_dist{$key}}).")\"";
330 my $node_attributes = qq("$key" [).join(',',@attributes).qq(]\n);
331 $dot .= $node_attributes;
334 foreach my $key (keys %{$version->{parent}}) {
335 next if not defined $version->{parent}{$key};
336 next if $cgi_var{ignore_boring} and $all_states{$key} eq 'absent';
337 next if $cgi_var{ignore_boring} and (not defined $all_states{$version->{parent}{$key}}
338 or $all_states{$version->{parent}{$key}} eq 'absent');
339 # Ignore branches which are not ancestors of a currently distributed version
340 next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
341 next if exists $collapsed_nodes{$key};
342 $dot .= qq("$key").'->'.q(").
343 (exists $collapsed_nodes{$version->{parent}{$key}}?
344 $group_nodes{$collapsed_nodes{$version->{parent}{$key}}}{name}:$version->{parent}{$key}).
345 qq(" [dir="back"])."\n" if defined $version->{parent}{$key};
347 if ($cgi_var{collapse}) {
349 foreach my $group (values %group_nodes) {
350 next if $used_node{$group->{name}};
351 next if not defined $group->{parent};
352 $used_node{$group->{name}} = 1;
353 $dot .= qq("$group->{name}").'->'.q(").
354 (exists $collapsed_nodes{$group->{parent}}?
355 $group_nodes{$collapsed_nodes{$group->{parent}}}{name}:$group->{parent}).
356 qq(" [dir="back"])."\n";
361 my $temp_dir = tempdir(CLEANUP => 1);
363 if (not defined $cgi_var{dot}) {
364 my $dot_fh = IO::File->new("$temp_dir/temp.dot",'w') or
365 die "Unable to open $temp_dir/temp.dot for writing: $!";
366 print {$dot_fh} $dot or die "Unable to print output to the dot file: $!";
367 close $dot_fh or die "Unable to close the dot file: $!";
368 system('dot','-T'.$cgi_var{format},"$temp_dir/temp.dot",'-o',"$temp_dir/temp.$cgi_var{format}") == 0
369 or print "Content-Type: text\n\nDot failed." and die "Dot failed: $?";
370 my $img_fh = IO::File->new("$temp_dir/temp.$cgi_var{format}", 'r') or
371 die "Unable to open $temp_dir/temp.$cgi_var{format} for reading: $!";
372 print $q->header(-status => 200,
373 -cache_control => 'public, max-age=300',
375 -content_type => $img_types{$cgi_var{format}},
381 print $q->header(-status => 200,
382 -cache_control => 'public, max-age=300',
384 -content_type => 'text',
390 our %_version_relevant_cache;
391 sub version_relevant {
392 my ($version,$test_version,$relevant_versions) = @_;
393 for my $dist_version (@{$relevant_versions}) {
394 if (exists $_version_relevant_cache{$dist_version}{$test_version}{$version}) {
395 return 1 if $_version_relevant_cache{$dist_version}{$test_version}{$version};
398 my $rel = $version->isancestor($test_version,$dist_version);
399 $_version_relevant_cache{$dist_version}{$test_version}{$version} = $rel;