cgi/version.cgi

   1 #!/usr/bin/perl
   2
   3 use warnings;
   4 use strict;
   5
   6 # Hack to work on merkel where suexec is in place
   7 BEGIN{
   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";
  11      }
  12 }
  13
  14
  15 use CGI::Simple;
  16
  17 use CGI::Alert 'don@donarmstrong.com';
  18
  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);
  26 use IO::File;
  27 use IO::Handle;
  28
  29
  30 my %img_types = (svg => 'image/svg+xml',
  31                  png => 'image/png',
  32                 );
  33
  34 my $q = new CGI::Simple;
  35
  36 my %cgi_var = cgi_parameters(query   => $q,
  37                              single  => [qw(package format ignore_boring width height)],
  38                              default => {package       => 'xterm',
  39                                          found         => [],
  40                                          fixed         => [],
  41                                          ignore_boring => 1,
  42                                          format        => 'png',
  43                                          width         => undef,
  44                                          height        => undef,
  45                                         },
  46                             );
  47
  48 # we want to first load the appropriate file,
  49 # then figure out which versions are there in which architectures,
  50 my %versions;
  51 my %version_to_dist;
  52 for my $dist (@{$config{distributions}}) {
  53      $versions{$dist} = [getversions($cgi_var{package},$dist)];
  54      # make version_to_dist
  55      foreach my $version (@{$versions{$dist}}){
  56           push @{$version_to_dist{$version}}, $dist;
  57      }
  58 }
  59
  60 if (defined $cgi_var{width}) {
  61      $cgi_var{width} =~ /(\d+)/;
  62      $cgi_var{width} = $1;
  63 }
  64 if (defined $cgi_var{height}) {
  65      $cgi_var{height} =~ /(\d+)/;
  66      $cgi_var{height} = $1;
  67 }
  68
  69 if (defined $cgi_var{format}) {
  70      $cgi_var{format} =~ /(png|svg|jpg|gif)/;
  71      $cgi_var{format} = $1 || 'png';
  72 }
  73 else {
  74      $cgi_var{format} = 'png';
  75 }
  76
  77 # then figure out which are affected.
  78 # turn found and fixed into full versions
  79 @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
  80 @{$cgi_var{fixed}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{fixed}});
  81 my @interesting_versions = makesourceversions($cgi_var{package},undef,keys %version_to_dist);
  82
  83 # We need to be able to rip out leaves which the versions that do not affect the current versions of unstable/testing
  84 my %sources;
  85 @sources{map {m{(.+)/}; $1} @{$cgi_var{found}}} = (1) x @{$cgi_var{found}};
  86 @sources{map {m{(.+)/}; $1} @{$cgi_var{fixed}}} = (1) x @{$cgi_var{fixed}};
  87 @sources{map {m{(.+)/}; $1} @interesting_versions} = (1) x @interesting_versions;
  88 my $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
  89 foreach my $source (keys %sources) {
  90      my $srchash = substr $source, 0, 1;
  91      my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$source", 'r';
  92      $version->load($version_fh);
  93 }
  94 # Here, we need to generate a short version to full version map
  95 my %version_map;
  96 foreach my $key (keys %{$version->{parent}}) {
  97      my ($short_version) = $key =~ m{/(.+)$};
  98      next unless length $short_version;
  99      # we let the first short version have presidence.
 100      $version_map{$short_version} = $key if not exists $version_map{$short_version};
 101 }
 102 # Turn all short versions into long versions
 103 for my $found_fixed (qw(found fixed)) {
 104      $cgi_var{$found_fixed} =
 105           [
 106            map {
 107                 if ($_ !~ m{/}) { # short version
 108                      ($version_map{$_});
 109                 }
 110                 else { # long version
 111                      ($_);
 112                 }
 113            } @{$cgi_var{$found_fixed}}
 114           ];
 115 }
 116 my %all_states = $version->allstates($cgi_var{found},$cgi_var{fixed});
 117
 118 my $dot = "digraph G {\n";
 119 if (defined $cgi_var{width} and defined $cgi_var{height}) {
 120      $dot .= qq(size="$cgi_var{width},$cgi_var{height}";\n);
 121 }
 122 my %state = (found  => ['fillcolor="salmon"',
 123                         'style="filled"',
 124                         'shape="diamond"',
 125                        ],
 126              absent => ['fillcolor="grey"',
 127                         'style="filled"',
 128                        ],
 129              fixed  => ['fillcolor="chartreuse"',
 130                         'style="filled"',
 131                         'shape="rect"',
 132                        ],
 133             );
 134 foreach my $key (keys %all_states) {
 135      my ($short_version) = $key =~ m{/(.+)$};
 136      next if $cgi_var{ignore_boring} and (not defined $all_states{$key}
 137                                           or $all_states{$key} eq 'absent');
 138      next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
 139      my @attributes = @{$state{$all_states{$key}}};
 140      if (length $short_version and exists $version_to_dist{$short_version}) {
 141           push @attributes, 'label="'.$key.'\n'."(".join(', ',@{$version_to_dist{$short_version}}).")\"";
 142      }
 143      my $node_attributes = qq("$key" [).join(',',@attributes).qq(]\n);
 144      $dot .= $node_attributes;
 145 }
 146 foreach my $key (keys %{$version->{parent}}) {
 147      next if not defined $version->{parent}{$key};
 148      next if $cgi_var{ignore_boring} and $all_states{$key} eq 'absent';
 149      next if $cgi_var{ignore_boring} and (not defined $all_states{$version->{parent}{$key}}
 150                                           or $all_states{$version->{parent}{$key}} eq 'absent');
 151      # Ignore branches which are not ancestors of a currently distributed version
 152      next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
 153      $dot .= qq("$key").'->'.qq("$version->{parent}{$key}" [dir="back"])."\n" if defined $version->{parent}{$key};
 154 }
 155 $dot .= "}\n";
 156
 157 my $temp_dir = tempdir(CLEANUP => 1);
 158
 159 if (not defined $cgi_var{dot}) {
 160      my $dot_fh = new IO::File "$temp_dir/temp.dot",'w' or
 161           die "Unable to open $temp_dir/temp.dot for writing: $!";
 162      print {$dot_fh} $dot or die "Unable to print output to the dot file: $!";
 163      close $dot_fh or die "Unable to close the dot file: $!";
 164      system('dot','-T'.$cgi_var{format},"$temp_dir/temp.dot",'-o',"$temp_dir/temp.$cgi_var{format}") == 0
 165           or print "Content-Type: text\n\nDot failed." and die "Dot failed: $?";
 166      my $img_fh = new IO::File "$temp_dir/temp.$cgi_var{format}", 'r' or
 167           die "Unable to open $temp_dir/temp.$cgi_var{format} for reading: $!";
 168      print "Content-Type: $img_types{$cgi_var{format}}\n\n";
 169      print <$img_fh>;
 170      close $img_fh;
 171 }
 172 else {
 173      print "Content-Type: text\n\n";
 174      print $dot;
 175 }
 176
 177
 178 my %_version_relevant_cache;
 179 sub version_relevant {
 180      my ($version,$test_version,$relevant_versions) = @_;
 181      for my $dist_version (@{$relevant_versions}) {
 182           print STDERR "Testing $dist_version against $test_version\n";
 183           return 1 if $version->isancestor($test_version,$dist_version);
 184      }
 185      return 0;
 186 }
 187
 188