cgi-bin/show_package.pl

   1 #!/usr/bin/perl -wT
   2 # $Id$
   3 # show_package.pl -- CGI interface to show info about a package
   4 #
   5 # Copyright (C) 1998 James Treacy
   6 # Copyright (C) 2000, 2001 Josip Rodin
   7 # Copyright (C) 2001 Adam Heath
   8 # Copyright (C) 2004 Martin Schulze
   9 # Copyright (C) 2004-2006 Frank Lichtenheld
  10 # Copyright (C) 2006 Jeroen van Wolffelaar
  11 #
  12 # use is allowed under the terms of the GNU Public License (GPL)
  13 # see http://www.fsf.org/copyleft/gpl.html for a copy of the license
  14
  15 use strict;
  16 use CGI qw( -oldstyle_urls );
  17 use CGI::Carp qw( fatalsToBrowser );
  18 use POSIX;
  19 use URI::Escape;
  20 use HTML::Entities;
  21 use DB_File;
  22 use Benchmark;
  23
  24 use lib "../lib";
  25
  26 use Deb::Versions;
  27 use Packages::Search qw( :all );
  28 use Packages::HTML ();
  29
  30 my $HOME = "http://www.debian.org";
  31 my $ROOT = "";
  32 my $SEARCHPAGE = "http://packages.debian.org/";
  33 my @SUITES = qw( oldstable stable testing unstable experimental );
  34 my @DISTS = @SUITES;
  35 my @SECTIONS = qw( main contrib non-free );
  36 my @ARCHIVES = qw( us security installer );
  37 my @ARCHITECTURES = qw( alpha amd64 arm hppa hurd-i386 i386 ia64
  38                         kfreebsd-i386 mips mipsel powerpc s390 sparc );
  39 my %SUITES = map { $_ => 1 } @SUITES;
  40 my %SECTIONS = map { $_ => 1 } @SECTIONS;
  41 my %ARCHIVES = map { $_ => 1 } @ARCHIVES;
  42 my %ARCHITECTURES = map { $_ => 1 } @ARCHITECTURES;
  43
  44 $ENV{PATH} = "/bin:/usr/bin";
  45
  46 # Read in all the variables set by the form
  47 my $input;
  48 if ($ARGV[0] eq 'php') {
  49         $input = new CGI(\*STDIN);
  50 } else {
  51         $input = new CGI;
  52 }
  53
  54 my $pet0 = new Benchmark;
  55 # use this to disable debugging in production mode completly
  56 my $debug_allowed = 1;
  57 my $debug = $debug_allowed && $input->param("debug");
  58 $debug = 0 if not defined($debug);
  59 $Search::Param::debug = 1 if $debug > 1;
  60
  61 # If you want, just print out a list of all of the variables and exit.
  62 print $input->header if $debug;
  63 # print $input->dump;
  64 # exit;
  65
  66 my %params_def = ( package => { default => undef, match => '^([a-z0-9.+-]+)$' },
  67                    suite => { default => undef, match => '^(\w+)$' },
  68                    #format => { default => 'html', match => '^(\w+)$' }
  69                    );
  70 my %params = Packages::Search::parse_params( $input, \%params_def );
  71
  72 my $format = $params{values}{format}{final};
  73 #XXX: Don't use alternative output formats yet
  74 $format = 'html';
  75
  76 if ($format eq 'html') {
  77     print $input->header;
  78 } elsif ($format eq 'xml') {
  79 #    print $input->header( -type=>'application/rdf+xml' );
  80     print $input->header( -type=>'text/plain' );
  81 }
  82
  83 if ($params{errors}{package}) {
  84     print "Error: package not valid or not specified" if $format eq 'html';
  85     exit 0;
  86 }
  87 if ($params{errors}{suite}) {
  88     print "Error: package not valid or not specified" if $format eq 'html';
  89     exit 0;
  90 }
  91 my $package = $params{values}{package}{final};
  92 my $suite = $params{values}{suite}{final};
  93
  94 # for output
  95 if ($format eq 'html') {
  96 print Packages::HTML::header( title => 'Package Details' ,
  97                               lang => 'en',
  98                               title_tag => 'Package Details',
  99                               print_title_above => 1
 100                               );
 101 }
 102
 103 # read the configuration
 104 my $topdir;
 105 if (!open (C, "../config.sh")) {
 106     print "\nInternal Error: Cannot open configuration file.\n\n"
 107 if $format eq 'html';
 108     exit 0;
 109 }
 110 while (<C>) {
 111     $topdir = $1 if (/^\s*topdir="?(.*)"?\s*$/);
 112 }
 113 close (C);
 114
 115 my $DBDIR = $topdir . "/files/db";
 116
 117 my $obj1 = tie my %packages, 'DB_File', "$DBDIR/packages_small.db", O_RDONLY, 0666, $DB_BTREE
 118     or die "couldn't tie DB $DBDIR/packages_small.db: $!";
 119 my $obj2 = tie my %packages_all, 'DB_File', "$DBDIR/packages_all_$suite.db", O_RDONLY, 0666, $DB_BTREE
 120     or die "couldn't tie DB $DBDIR/packages_all_$suite.db: $!";
 121 my %allsuites = ();
 122 my @results = ();
 123
 124 &read_entry( $package, \@results, \%allsuites );
 125 for my $entry (@results) {
 126     print join ":", @$entry;
 127     print "<br>\n";
 128 }
 129
 130 print "Available in ".(join ', ', keys %allsuites)."\n";
 131
 132 &printfooter;
 133
 134 sub read_entry {
 135     my ($key, $results, $allsuites) = @_;
 136     my $result = $packages{$key};
 137     foreach (split /\000/, $result) {
 138         my @data = split ( /\s/, $_, 7 );
 139         print "DEBUG: Considering entry ".join( ':', @data)."<br>" if $debug > 2;
 140         if ($suite eq $data[0]) {
 141             print "DEBUG: Using entry ".join( ':', @data)."<br>" if $debug > 2;
 142             push @$results, [@data];
 143         }
 144         $allsuites->{$data[0]} = 1;
 145     }
 146 }
 147
 148 # TODO: move to common lib:
 149 sub printfooter {
 150     print <<END;
 151 </div>
 152
 153 <hr class="hidecss">
 154 <p style="text-align:right;font-size:small;font-stlye:italic"><a href="$SEARCHPAGE">Packages search page</a></p>
 155
 156 </div>
 157 END
 158
 159     my $pete = new Benchmark;
 160     my $petd = timediff($pete, $pet0);
 161     print "Total page evaluation took ".timestr($petd)."<br>"
 162         if $debug_allowed;
 163
 164     print $input->end_html;
 165 }
 166
 167 # vim: ts=8 sw=4