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);
  21 use Debbugs::Versions;
  22 use Debbugs::Versions::Dpkg;
  23 use Debbugs::Packages qw(getversions);
  24 use HTML::Entities qw(encode_entities);
  25 use File::Temp qw(tempdir);
  26 use IO::File;
  27 use IO::Handle;
  28
  29
  30
  31 my $q = new CGI::Simple;
  32
  33 my %cgi_var = cgi_parameters($q);
  34
  35 $cgi_var{package} = ['xterm'] if not defined $cgi_var{package};
  36 $cgi_var{found} = [] if not defined $cgi_var{found};
  37 $cgi_var{fixed} = [] if not defined $cgi_var{fixed};
  38
  39 # we only care about one package
  40 $cgi_var{package} = $cgi_var{package}[0];
  41
  42 # we want to first load the appropriate file,
  43 # then figure out which versions are there in which architectures,
  44 my %versions;
  45 my %version_to_dist;
  46 for my $dist (qw(oldstable stable testing unstable)) {
  47      $versions{$dist} = [getversions($cgi_var{package},$dist)];
  48      # make version_to_dist
  49      foreach my $version (@{$versions{$dist}}){
  50           push @{$version_to_dist{$version}}, $dist;
  51      }
  52 }
  53 # then figure out which are affected.
  54
  55 my $srchash = substr $cgi_var{package}, 0, 1;
  56 my $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
  57 my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$cgi_var{package}", 'r';
  58 $version->load($version_fh);
  59 # Here, we need to generate a short version to full version map
  60 my %version_map;
  61 foreach my $key (keys %{$version->{parent}}) {
  62      my ($short_version) = $key =~ m{/(.+)$};
  63      next unless length $short_version;
  64      # we let the first short version have presidence.
  65      $version_map{$short_version} = $key if not exists $version_map{$short_version};
  66 }
  67 # Turn all short versions into long versions
  68 for my $found_fixed (qw(found fixed)) {
  69      $cgi_var{$found_fixed} =
  70           [
  71            map {
  72                 if ($_ !~ m{/}) { # short version
  73                      ($version_map{$_});
  74                 }
  75                 else { # long version
  76                      ($_);
  77                 }
  78            } @{$cgi_var{$found_fixed}}
  79           ];
  80 }
  81 my %all_states = $version->allstates($cgi_var{found},$cgi_var{fixed});
  82
  83 my $dot = "digraph G {\n";
  84 my %state = (found  => ['fillcolor="salmon"',
  85                         'style="filled"',
  86                         'shape="diamond"',
  87                        ],
  88              absent => ['fillcolor="grey"',
  89                         'style="filled"',
  90                        ],
  91              fixed  => ['fillcolor="chartreuse"',
  92                         'style="filled"',
  93                         'shape="rect"',
  94                        ],
  95             );
  96 foreach my $key (keys %all_states) {
  97      my ($short_version) = $key =~ m{/(.+)$};
  98      my @attributes = @{$state{$all_states{$key}}};
  99      if (length $short_version and exists $version_to_dist{$short_version}) {
 100           push @attributes, 'label="'.$key.'\n'."(".join(', ',@{$version_to_dist{$short_version}}).")\"";
 101      }
 102      my $node_attributes = qq("$key" [).join(',',@attributes).qq(]\n);
 103      $dot .= $node_attributes;
 104 }
 105 foreach my $key (keys %{$version->{parent}}) {
 106      $dot .= qq("$key").'->'.qq("$version->{parent}{$key}" [dir="back"])."\n" if defined $version->{parent}{$key};
 107 }
 108 $dot .= "}\n";
 109
 110 my $temp_dir = tempdir(CLEANUP => 1);
 111
 112 if (not defined $cgi_var{dot}) {
 113      my $dot_fh = new IO::File "$temp_dir/temp.dot",'w' or
 114           die "Unable to open $temp_dir/temp.dot for writing: $!";
 115      print {$dot_fh} $dot or die "Unable to print output to the dot file: $!";
 116      close $dot_fh or die "Unable to close the dot file: $!";
 117      system('dot','-Tpng',"$temp_dir/temp.dot",'-o',"$temp_dir/temp.png") == 0
 118           or print "Content-Type: text\n\nDot failed." and die "Dot failed: $?";
 119      my $png_fh = new IO::File "$temp_dir/temp.png", 'r' or
 120           die "Unable to open $temp_dir/temp.png for reading: $!";
 121      print "Content-Type: image/png\n\n";
 122      print <$png_fh>;
 123      close $png_fh;
 124 }
 125 else {
 126      print "Content-Type: text\n\n";
 127      print $dot;
 128 }
 129
 130 sub cgi_parameters {
 131      my ($q) = @_;
 132
 133      my %param;
 134      foreach my $paramname ($q->param) {
 135           $param{$paramname} = [$q->param($paramname)]
 136      }
 137      return %param;
 138 }