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