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