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 munge_url);
  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 collapse info)],
  38                              default => {package       => 'spamass-milter',
  39                                          found         => [],
  40                                          fixed         => [],
  41                                          ignore_boring => 1,
  42                                          collapse      => 0,
  43                                          format        => 'png',
  44                                          width         => undef,
  45                                          height        => undef,
  46                                          info          => 0,
  47                                         },
  48                             );
  49 my $this = munge_url('version.cgi?',
  50                      %cgi_var,
  51                     );
  52
  53 # we want to first load the appropriate file,
  54 # then figure out which versions are there in which architectures,
  55 my %versions;
  56 my %version_to_dist;
  57 for my $dist (@{$config{distributions}}) {
  58      $versions{$dist} = [getversions($cgi_var{package},$dist)];
  59      # make version_to_dist
  60      foreach my $version (@{$versions{$dist}}){
  61           push @{$version_to_dist{$version}}, $dist;
  62      }
  63 }
  64
  65 if (defined $cgi_var{width}) {
  66      $cgi_var{width} =~ /(\d+)/;
  67      $cgi_var{width} = $1;
  68 }
  69 if (defined $cgi_var{height}) {
  70      $cgi_var{height} =~ /(\d+)/;
  71      $cgi_var{height} = $1;
  72 }
  73
  74 if (defined $cgi_var{format}) {
  75      $cgi_var{format} =~ /(png|svg|jpg|gif)/;
  76      $cgi_var{format} = $1 || 'png';
  77 }
  78 else {
  79      $cgi_var{format} = 'png';
  80 }
  81
  82 if ($cgi_var{info} and not defined $cgi_var{dot}) {
  83      print "Content-Type: text/html\n\n";
  84      print <<END;
  85 <!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
  86 <html>
  87 <head><title>$cgi_var{package} Version Graph</title></head>
  88 <body>
  89 END
  90      print '<a href="'.html_escape(munge_url($this,ignore_boring=>$cgi_var{ignore_boring}?0:1)).
  91           '">['.($cgi_var{ignore_boring}?"Don't i":'I').'gnore boring]</a> ';
  92      print '<a href="'.html_escape(munge_url($this,collapse=>$cgi_var{collapse}?0:1)).
  93           '">['.($cgi_var{collapse}?"Don't c":'C').'ollapse]</a> ';
  94      print '<a href="'.html_escape(munge_url($this,dot=>1)).
  95           '">[Dot]</a><br/>';
  96      print '<img src="'.html_escape(munge_url($this,info=>0)).'">';
  97      print <<END;
  98 </body>
  99 </html>
 100 END
 101           exit 0;
 102 }
 103
 104 # then figure out which are affected.
 105 # turn found and fixed into full versions
 106 @{$cgi_var{found}} = map {makesourceversions($_,undef,@{$cgi_var{found}})} split/\s*,\s*/, $cgi_var{package};
 107 @{$cgi_var{fixed}} = map {makesourceversions($_,undef,@{$cgi_var{fixed}})} split/\s*,\s*/, $cgi_var{package};
 108 my @interesting_versions = makesourceversions($cgi_var{package},undef,keys %version_to_dist);
 109
 110 # We need to be able to rip out leaves which the versions that do not affect the current versions of unstable/testing
 111 my %sources;
 112 @sources{map {m{(.+)/}; $1} @{$cgi_var{found}}} = (1) x @{$cgi_var{found}};
 113 @sources{map {m{(.+)/}; $1} @{$cgi_var{fixed}}} = (1) x @{$cgi_var{fixed}};
 114 @sources{map {m{(.+)/}; $1} @interesting_versions} = (1) x @interesting_versions;
 115 my $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
 116 foreach my $source (keys %sources) {
 117      my $srchash = substr $source, 0, 1;
 118      my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$source", 'r';
 119      $version->load($version_fh);
 120 }
 121 # Here, we need to generate a short version to full version map
 122 my %version_map;
 123 foreach my $key (keys %{$version->{parent}}) {
 124      my ($short_version) = $key =~ m{/(.+)$};
 125      next unless length $short_version;
 126      # we let the first short version have presidence.
 127      $version_map{$short_version} = $key if not exists $version_map{$short_version};
 128 }
 129 # Turn all short versions into long versions
 130 for my $found_fixed (qw(found fixed)) {
 131      $cgi_var{$found_fixed} =
 132           [
 133            map {
 134                 if ($_ !~ m{/}) { # short version
 135                      ($version_map{$_});
 136                 }
 137                 else { # long version
 138                      ($_);
 139                 }
 140            } @{$cgi_var{$found_fixed}}
 141           ];
 142 }
 143 my %all_states = $version->allstates($cgi_var{found},$cgi_var{fixed});
 144
 145 my $dot = "digraph G {\n";
 146 if (defined $cgi_var{width} and defined $cgi_var{height}) {
 147      $dot .= qq(size="$cgi_var{width},$cgi_var{height}";\n);
 148 }
 149 my %state = (found  => ['fillcolor="salmon"',
 150                         'style="filled"',
 151                         'shape="ellipse"',
 152                        ],
 153              absent => ['fillcolor="grey"',
 154                         'style="filled"',
 155                         'shape="trapezium"',
 156                        ],
 157              fixed  => ['fillcolor="chartreuse"',
 158                         'style="filled"',
 159                         'shape="rect"',
 160                        ],
 161             );
 162 # TODO: Allow collapsing versions which are at the same state and not
 163 # in a suite.
 164 my %collapsed_nodes;
 165 my %group_nodes;
 166 if ($cgi_var{collapse}) {
 167      my %reversed_nodes;
 168      foreach my $key (keys %{$version->{parent}}) {
 169           next if $cgi_var{ignore_boring} and (not defined $all_states{$key}
 170                                                or $all_states{$key} eq 'absent');
 171           next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
 172           if (defined $version->{parent}{$key}) {
 173                next if $cgi_var{ignore_boring} and (not defined $all_states{$version->{parent}{$key}}
 174                                                     or $all_states{$version->{parent}{$key}} eq 'absent');
 175                next if $cgi_var{ignore_boring} and not version_relevant($version,$version->{parent}{$key},\@interesting_versions);
 176                push @{$reversed_nodes{$version->{parent}{$key}}},$key;
 177           }
 178           else {
 179                $reversed_nodes{$key} ||=[];
 180           }
 181      }
 182      # nodes that can be collapsed are those that have one child
 183      # are in the same state as their parent, and are not in a suite
 184      foreach my $key (keys %reversed_nodes) {
 185           my ($short_version) = $key =~ m{/(.+)$};
 186           if (not exists $version_to_dist{$short_version}
 187               and @{$reversed_nodes{$key}} <= 1
 188               and defined $version->{parent}{$key}
 189               and $all_states{$key} eq $all_states{$version->{parent}{$key}}
 190              ) {
 191                # check to see if there is an entry for the parent or child of this node
 192                my $group_node;
 193                if ((@{$reversed_nodes{$key}} and exists $collapsed_nodes{$reversed_nodes{$key}[0]})) {
 194                     $group_node = $collapsed_nodes{$reversed_nodes{$key}[0]};
 195                     if ($group_nodes{$group_node}{parent} eq $key) {
 196                          $group_nodes{$group_node}{parent} = $version->{parent}{$key};
 197                     }
 198                }
 199                if (defined $version->{parent}{$key} and exists $collapsed_nodes{$version->{parent}{$key}}) {
 200                     if (defined $group_node) {
 201                          #MWHAHAHAHAHA
 202                          my $collapser = $group_nodes{$collapsed_nodes{$version->{parent}{$key}}};
 203                          push @{$collapser->{collapsed_nodes}},@{$group_nodes{$group_node}{collapsed_nodes}},$group_node;
 204                          foreach (@{$collapser->{collapsed_nodes}}) {
 205                               if (exists $group_nodes{$_}) {
 206                                    $group_nodes{$_} = $collapser;
 207                               }
 208                          }
 209                     }
 210                     $group_node = $collapsed_nodes{$version->{parent}{$key}};
 211                }
 212                if (not defined $group_node) {
 213                     $group_node = "group_$key";
 214                     $group_nodes{$group_node} = {attr => qq("$group_node" [).join(',','label="some versions"',
 215                                                                                   @{$state{$all_states{$key}}},
 216                                                                                   'style="bold,filled"',
 217                                                                                  ).qq(]\n),
 218                                                  name => $group_node,
 219                                                  parent => $version->{parent}{$key},
 220                                                  collapsed_nodes => [],
 221                                                 };
 222                }
 223                $collapsed_nodes{$key} = $group_node;
 224           }
 225      }
 226      my %used_node;
 227      foreach my $group (values %group_nodes) {
 228           next if $used_node{$group->{name}};
 229           $used_node{$group->{name}} = 1;
 230           $dot .= $group->{attr};
 231      }
 232 }
 233
 234 foreach my $key (keys %all_states) {
 235      my ($short_version) = $key =~ m{/(.+)$};
 236      next if exists $collapsed_nodes{$key};
 237      next if $cgi_var{ignore_boring} and (not defined $all_states{$key}
 238                                           or $all_states{$key} eq 'absent');
 239      next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
 240      my @attributes = @{$state{$all_states{$key}}};
 241      if (length $short_version and exists $version_to_dist{$short_version}) {
 242           push @attributes, 'label="'.$key.'\n'."(".join(', ',@{$version_to_dist{$short_version}}).")\"";
 243      }
 244      my $node_attributes = qq("$key" [).join(',',@attributes).qq(]\n);
 245      $dot .= $node_attributes;
 246 }
 247
 248 foreach my $key (keys %{$version->{parent}}) {
 249      next if not defined $version->{parent}{$key};
 250      next if $cgi_var{ignore_boring} and $all_states{$key} eq 'absent';
 251      next if $cgi_var{ignore_boring} and (not defined $all_states{$version->{parent}{$key}}
 252                                           or $all_states{$version->{parent}{$key}} eq 'absent');
 253      # Ignore branches which are not ancestors of a currently distributed version
 254      next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
 255      next if exists $collapsed_nodes{$key};
 256      $dot .= qq("$key").'->'.q(").
 257           (exists $collapsed_nodes{$version->{parent}{$key}}?
 258            $group_nodes{$collapsed_nodes{$version->{parent}{$key}}}{name}:$version->{parent}{$key}).
 259                 qq(" [dir="back"])."\n" if defined $version->{parent}{$key};
 260 }
 261 if ($cgi_var{collapse}) {
 262      my %used_node;
 263      foreach my $group (values %group_nodes) {
 264           next if $used_node{$group->{name}};
 265           next if not defined $group->{parent};
 266           $used_node{$group->{name}} = 1;
 267           $dot .= qq("$group->{name}").'->'.q(").
 268                (exists $collapsed_nodes{$group->{parent}}?
 269                 $group_nodes{$collapsed_nodes{$group->{parent}}}{name}:$group->{parent}).
 270                     qq(" [dir="back"])."\n";
 271      }
 272 }
 273 $dot .= "}\n";
 274
 275 my $temp_dir = tempdir(CLEANUP => 1);
 276
 277 if (not defined $cgi_var{dot}) {
 278      my $dot_fh = new IO::File "$temp_dir/temp.dot",'w' or
 279           die "Unable to open $temp_dir/temp.dot for writing: $!";
 280      print {$dot_fh} $dot or die "Unable to print output to the dot file: $!";
 281      close $dot_fh or die "Unable to close the dot file: $!";
 282      system('dot','-T'.$cgi_var{format},"$temp_dir/temp.dot",'-o',"$temp_dir/temp.$cgi_var{format}") == 0
 283           or print "Content-Type: text\n\nDot failed." and die "Dot failed: $?";
 284      my $img_fh = new IO::File "$temp_dir/temp.$cgi_var{format}", 'r' or
 285           die "Unable to open $temp_dir/temp.$cgi_var{format} for reading: $!";
 286      print "Content-Type: $img_types{$cgi_var{format}}\n\n";
 287      print <$img_fh>;
 288      close $img_fh;
 289 }
 290 else {
 291      print "Content-Type: text\n\n";
 292      print $dot;
 293 }
 294
 295
 296 our %_version_relevant_cache;
 297 sub version_relevant {
 298      my ($version,$test_version,$relevant_versions) = @_;
 299      for my $dist_version (@{$relevant_versions}) {
 300           if (exists $_version_relevant_cache{$dist_version}{$test_version}{$version}) {
 301                return 1 if $_version_relevant_cache{$dist_version}{$test_version}{$version};
 302           }
 303           else {
 304                my $rel = $version->isancestor($test_version,$dist_version);
 305                $_version_relevant_cache{$dist_version}{$test_version}{$version} = $rel;
 306                return 1 if $rel;
 307           }
 308      }
 309      return 0;
 310 }
 311
 312