3 # show_package.pl -- CGI interface to show info about a package
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
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
16 use CGI qw( -oldstyle_urls );
17 use CGI::Carp qw( fatalsToBrowser );
27 use Packages::Search qw( :all );
28 use Packages::HTML ();
30 my $HOME = "http://www.debian.org";
32 my $SEARCHPAGE = "http://packages.debian.org/";
33 my @SUITES = qw( oldstable stable testing unstable experimental );
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;
44 $ENV{PATH} = "/bin:/usr/bin";
46 # Read in all the variables set by the form
48 if ($ARGV[0] eq 'php') {
49 $input = new CGI(\*STDIN);
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;
61 # If you want, just print out a list of all of the variables and exit.
62 print $input->header if $debug;
66 my %params_def = ( package => { default => undef, match => '^([a-z0-9.+-]+)$' },
67 suite => { default => undef, match => '^(\w+)$' },
68 #format => { default => 'html', match => '^(\w+)$' }
70 my %params = Packages::Search::parse_params( $input, \%params_def );
72 my $format = $params{values}{format}{final};
73 #XXX: Don't use alternative output formats yet
76 if ($format eq 'html') {
78 } elsif ($format eq 'xml') {
79 # print $input->header( -type=>'application/rdf+xml' );
80 print $input->header( -type=>'text/plain' );
83 if ($params{errors}{package}) {
84 print "Error: package not valid or not specified" if $format eq 'html';
87 if ($params{errors}{suite}) {
88 print "Error: package not valid or not specified" if $format eq 'html';
91 my $package = $params{values}{package}{final};
92 my $suite = $params{values}{suite}{final};
95 if ($format eq 'html') {
96 print Packages::HTML::header( title => 'Package Details' ,
98 title_tag => 'Package Details',
99 print_title_above => 1
103 # read the configuration
105 if (!open (C, "../config.sh")) {
106 print "\nInternal Error: Cannot open configuration file.\n\n"
107 if $format eq 'html';
111 $topdir = $1 if (/^\s*topdir="?(.*)"?\s*$/);
115 my $DBDIR = $topdir . "/files/db";
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: $!";
124 &read_entry( $package, \@results, \%allsuites );
125 for my $entry (@results) {
126 print join ":", @$entry;
130 print "Available in ".(join ', ', keys %allsuites)."\n";
133 my ($key, $results, $allsuites) = @_;
134 my $result = $packages{$key};
135 foreach (split /\000/, $result) {
136 my @data = split ( /\s/, $_, 7 );
137 print "DEBUG: Considering entry ".join( ':', @data)."<br>" if $debug > 2;
138 if ($suite eq $data[0]) {
139 print "DEBUG: Using entry ".join( ':', @data)."<br>" if $debug > 2;
140 push @$results, [@data];
142 $allsuites->{$data[0]} = 1;
146 # TODO: move to common lib:
152 <p style="text-align:right;font-size:small;font-stlye:italic"><a href="$SEARCHPAGE">Packages search page</a></p>
157 my $pete = new Benchmark;
158 my $petd = timediff($pete, $pet0);
159 print "Total page evaluation took ".timestr($petd)."<br>"
162 print $input->end_html;