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 Deb::Versions;
  25 use Packages::Config qw( $DBDIR $ROOT @SUITES @ARCHIVES @SECTIONS
  26                          @ARCHITECTURES %FTP_SITES );
  27 use Packages::CGI;
  28 use Packages::Search qw( :all );
  29 use Packages::HTML;
  30 use Packages::Page ();
  31
  32 &Packages::CGI::reset;
  33
  34 $ENV{PATH} = "/bin:/usr/bin";
  35
  36 # Read in all the variables set by the form
  37 my $input;
  38 if ($ARGV[0] && ($ARGV[0] eq 'php')) {
  39         $input = new CGI(\*STDIN);
  40 } else {
  41         $input = new CGI;
  42 }
  43
  44 my $pet0 = new Benchmark;
  45 my $tet0 = new Benchmark;
  46 # use this to disable debugging in production mode completly
  47 my $debug_allowed = 1;
  48 my $debug = $debug_allowed && $input->param("debug");
  49 $debug = 0 if !defined($debug) || $debug !~ /^\d+$/o;
  50 $Packages::CGI::debug = $debug;
  51
  52 # read the configuration
  53 our $db_read_time ||= 0;
  54
  55 &Packages::Config::init( '../' );
  56
  57 if (my $path = $input->param('path')) {
  58     my @components = map { lc $_ } split /\//, $path;
  59
  60     my %SUITES = map { $_ => 1 } @SUITES;
  61     my %SECTIONS = map { $_ => 1 } @SECTIONS;
  62     my %ARCHIVES = map { $_ => 1 } @ARCHIVES;
  63     my %ARCHITECTURES = map { $_ => 1 } @ARCHITECTURES;
  64
  65     foreach (@components) {
  66         if ($SUITES{$_}) {
  67             $input->param('suite', $_);
  68         } elsif ($SECTIONS{$_}) {
  69             $input->param('section', $_);
  70         } elsif ($ARCHIVES{$_}) {
  71             $input->param('archive', $_);
  72         } elsif ($ARCHITECTURES{$_}) {
  73             $input->param('arch', $_);
  74         }
  75     }
  76 }
  77
  78 my ( $pkg, $suite, @sections, @archs, @archives, $format );
  79 my %params_def = ( package => { default => undef, match => '^([a-z0-9.+-]+)$',
  80                                 var => \$pkg },
  81                    suite => { default => undef, match => '^(\w+)$',
  82                               var => \$suite },
  83                    archive => { default => 'all', match => '^(\w+)$',
  84                                 array => ',', var => \@archives,
  85                                 replace => { all => [qw(us security)] } },
  86                    section => { default => 'all', match => '^(\w+)$',
  87                                 array => ',', var => \@sections,
  88                                 replace => { all => \@SECTIONS } },
  89                    arch => { default => 'any', match => '^(\w+)$',
  90                              array => ',', var => \@archs,
  91                              replace => { any => \@ARCHITECTURES } },
  92                    format => { default => 'html', match => '^(\w+)$',
  93                                var => \$format }
  94                    );
  95 my %opts;
  96 my %params = Packages::Search::parse_params( $input, \%params_def, \%opts );
  97
  98 #XXX: Don't use alternative output formats yet
  99 $format = 'html';
 100 if ($format eq 'html') {
 101     print $input->header;
 102 }
 103
 104 if ($params{errors}{package}) {
 105     fatal_error( "package not valid or not specified" );
 106     $pkg = '';
 107 }
 108 if ($params{errors}{suite}) {
 109     fatal_error( "suite not valid or not specified" );
 110     $suite = '';
 111 }
 112
 113 $opts{h_suites} =   { $suite => 1 };
 114 $opts{h_archs} =    { map { $_ => 1 } @archs };
 115 $opts{h_sections} = { map { $_ => 1 } @sections };
 116 $opts{h_archives} = { map { $_ => 1 } @archives };;
 117
 118 my $DL_URL = "$pkg/download";
 119 my $FILELIST_URL = "$pkg/files";
 120
 121 our (%packages, %packages_all, %sources_all, %descriptions);
 122 my (@results, @non_results);
 123 my $page = new Packages::Page( $pkg );
 124 my $package_page = "";
 125 my ($short_desc, $version, $archive, $section, $subsection) = ("")x5;
 126
 127 sub gettext { return $_[0]; };
 128
 129 my $st0 = new Benchmark;
 130 unless (@Packages::CGI::fatal_errors) {
 131     my $dbmodtime = (stat("$DBDIR/packages_small.db"))[9];
 132     tie %packages_all, 'DB_File', "$DBDIR/packages_all_$suite.db",
 133     O_RDONLY, 0666, $DB_BTREE
 134         or die "couldn't tie DB $DBDIR/packages_all_$suite.db: $!";
 135     tie %sources_all, 'DB_File', "$DBDIR/sources_all_$suite.db",
 136     O_RDONLY, 0666, $DB_BTREE
 137         or die "couldn't tie DB $DBDIR/sources_all_$suite.db: $!";
 138     if ($dbmodtime > $db_read_time) {
 139         tie %packages, 'DB_File', "$DBDIR/packages_small.db",
 140         O_RDONLY, 0666, $DB_BTREE
 141             or die "couldn't tie DB $DBDIR/packages_small.db: $!";
 142         tie %descriptions, 'DB_File', "$DBDIR/descriptions.db",
 143         O_RDONLY, 0666, $DB_BTREE
 144             or die "couldn't tie DB $DBDIR/descriptions.db: $!";
 145
 146         debug( "tied databases ($dbmodtime > $db_read_time)" );
 147         $db_read_time = $dbmodtime;
 148     }
 149
 150     read_entry_all( \%packages, $pkg, \@results, \@non_results, \%opts );
 151
 152     unless (@results || @non_results ) {
 153         fatal_error( "No such package".
 154                      "{insert link to search page with substring search}" );
 155     } else {
 156         unless (@results) {
 157             fatal_error( "Package not available in this suite" );
 158         } else {
 159             for my $entry (@results) {
 160                 debug( join(":", @$entry), 1 );
 161                 my (undef, $archive, undef, $arch, $section, $subsection,
 162                     $priority, $version) = @$entry;
 163
 164                 my $data = $packages_all{"$pkg $arch $version"};
 165                 $page->merge_data($pkg, $version, $arch, $data) or debug( "Merging $pkg $arch $version FAILED", 2 );
 166             }
 167
 168             $version = $page->{newest};
 169             my $source = $page->get_newest( 'source' );
 170             my $source_version = $page->get_newest( 'source-version' )
 171                 || $version;
 172             my $src_data = $sources_all{"$source $source_version"};
 173             unless ($src_data) { #fucking binNMUs
 174                 my $versions = $page->get_versions;
 175                 my $sources = $page->get_arch_field( 'source' );
 176                 my $source_versions = $page->get_arch_field( 'source-version' );
 177                 foreach (version_sort keys %$versions) {
 178                     $source = $sources->{$versions->{$_}[0]};
 179                     $source = $source_versions->{$versions->{$_}[0]}
 180                     || $version;
 181                     $src_data = $sources_all{"$source $source_version"};
 182                     last if $src_data;
 183                 }
 184                 error( "couldn't find source package" ) unless $src_data;
 185             }
 186             $page->add_src_data( $source, $source_version, $src_data );
 187
 188             my $st1 = new Benchmark;
 189             my $std = timediff($st1, $st0);
 190             debug( "Data search and merging took ".timestr($std) );
 191
 192             my $encodedpkg = uri_escape( $pkg );
 193             my ($v_str, $v_str_arch, $v_str_arr) = $page->get_version_string();
 194             my $did = $page->get_newest( 'description' );
 195             $archive = $page->get_newest( 'archive' );
 196             $section = $page->get_newest( 'section' );
 197             $subsection = $page->get_newest( 'subsection' );
 198             my $filenames = $page->get_arch_field( 'filename' );
 199             my $file_md5sums = $page->get_arch_field( 'md5sum' );
 200             my $archives = $page->get_arch_field( 'archive' );
 201             my $sizes_inst = $page->get_arch_field( 'installed-size' );
 202             my $sizes_deb = $page->get_arch_field( 'size' );
 203             my @archs = sort $page->get_architectures;
 204
 205             # process description
 206             #
 207             my $desc = $descriptions{$did};
 208             $short_desc = encode_entities( $1, "<>&\"" )
 209                 if $desc =~ s/^(.*)$//m;
 210             my $long_desc = encode_entities( $desc, "<>&\"" );
 211
 212             $long_desc =~ s,((ftp|http|https)://[\S~-]+?/?)((\&gt\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go; # syntax highlighting -> '];
 213             $long_desc =~ s/\A //o;
 214             $long_desc =~ s/\n /\n/sgo;
 215             $long_desc =~ s/\n.\n/\n<p>\n/go;
 216             $long_desc =~ s/(((\n|\A) [^\n]*)+)/\n<pre>$1\n<\/pre>/sgo;
 217 #           $long_desc = conv_desc( $lang, $long_desc );
 218 #           $short_desc = conv_desc( $lang, $short_desc );
 219
 220             my %all_suites;
 221             foreach (@results, @non_results) {
 222                 my $a = $_->[1];
 223                 my $s = $_->[2];
 224                 if ($a =~ /^(?:us|security)$/o) {
 225                     $all_suites{$s}++;
 226                 } else {
 227                     $all_suites{"$s/$a"}++;
 228                 }
 229             }
 230             foreach (suites_sort(keys %all_suites)) {
 231                 if (("$suite/$archive" eq $_)
 232                     || (!$all_suites{"$suite/$archive"} && ($suite eq $_))) {
 233                     $package_page .= "[ <strong>$_</strong> ] ";
 234                 } else {
 235                     $package_page .=
 236                         "[ <a href=\"$ROOT/$_/".uri_escape($pkg)."\">$_</a> ] ";
 237                 }
 238             }
 239             $package_page .= '<br>';
 240
 241             $package_page .= simple_menu( [ gettext( "Distribution:" ),
 242                                             gettext( "Overview over this suite" ),
 243                                             "/$suite/",
 244                                             $suite ],
 245                                           [ gettext( "Section:" ),
 246                                             gettext( "All packages in this section" ),
 247                                             "/$suite/$subsection/",
 248                                             $subsection ],
 249                                           );
 250
 251             my $title .= sprintf( gettext( "Package: %s (%s)" ), $pkg, $v_str );
 252             $title .=  " ".marker( $archive ) if $archive ne 'us';
 253             $title .=  " ".marker( $section ) if $section ne 'main';
 254             $package_page .= title( $title );
 255
 256             $package_page .= "<h2>".gettext( "Versions:" )." $v_str_arch</h2>\n"
 257                 unless $version eq $v_str;
 258
 259             if ($suite eq "experimental") {
 260                 $package_page .= note( gettext( "Experimental package"),
 261                                        gettext( "Warning: This package is from the <span class=\"pred\">experimental</span> distribution. That means it is likely unstable or buggy, and it may even cause data loss. If you ignore this warning and install it nevertheless, you do it on your own risk.")."</p><p>".
 262                                        gettext( "Users of experimental packages are encouraged to contact the package maintainers directly in case of problems." )
 263                                        );
 264             }
 265             if ($subsection eq "debian-installer") {
 266                 note( gettext( "debian-installer udeb package"),
 267                       gettext( "Warning: This package is intended for the use in building <a href=\"http://www.debian.org/devel/debian-installer\">debian-installer</a> images only. Do not install it on a normal Debian system." )
 268                       );
 269             }
 270             $package_page .= pdesc( $short_desc, $long_desc );
 271
 272             #
 273             # display dependencies
 274             #
 275             my $dep_list;
 276             $dep_list = print_deps( \%packages, \%opts, $pkg,
 277                                        $page->get_dep_field('depends'),
 278                                        'depends' );
 279             $dep_list .= print_deps( \%packages, \%opts, $pkg,
 280                                        $page->get_dep_field('recommends'),
 281                                        'recommends' );
 282             $dep_list .= print_deps( \%packages, \%opts, $pkg,
 283                                        $page->get_dep_field('suggests'),
 284                                        'suggests' );
 285
 286             if ( $dep_list ) {
 287                 $package_page .= "<div id=\"pdeps\">\n";
 288                 $package_page .= sprintf( "<h2>".gettext( "Other Packages Related to %s" )."</h2>\n", $pkg );
 289                 if ($suite eq "experimental") {
 290                     note( gettext( "Note that the \"<span class=\"pred\">experimental</span>\" distribution is not self-contained; missing dependencies are likely found in the \"<a href=\"/unstable/\">unstable</a>\" distribution." ) );
 291                 }
 292
 293                 $package_page .= pdeplegend( [ 'dep',  gettext( 'depends' ) ],
 294                                              [ 'rec',  gettext( 'recommends' ) ],
 295                                              [ 'sug',  gettext( 'suggests' ) ], );
 296
 297                 $package_page .= $dep_list;
 298                 $package_page .= "</div> <!-- end pdeps -->\n";
 299             }
 300
 301             #
 302             # Download package
 303             #
 304             my $encodedpack = uri_escape( $pkg );
 305             $package_page .= "<div id=\"pdownload\">";
 306             $package_page .= sprintf( "<h2>".gettext( "Download %s\n" )."</h2>",
 307                                       $pkg ) ;
 308             $package_page .= "<table border=\"1\" summary=\"".gettext("The download table links to the download of the package and a file overview. In addition it gives information about the package size and the installed size.")."\">\n";
 309             $package_page .= "<caption class=\"hidecss\">".gettext("Download for all available architectures")."</caption>\n";
 310             $package_page .= "<tr>\n";
 311             $package_page .= "<th>".gettext("Architecture")."</th><th>".gettext("Files")."</th><th>".gettext( "Package Size")."</th><th>".gettext("Installed Size")."</th></tr>\n";
 312             foreach my $a ( @archs ) {
 313                 $package_page .= "<tr>\n";
 314                 $package_page .=  "<th><a href=\"$DL_URL?arch=$a";
 315                 $package_page .=  "&amp;file=".uri_escape($filenames->{$a});
 316                 $package_page .=  "&amp;md5sum=$file_md5sums->{$a}";
 317                 $package_page .=  "&amp;arch=$a";
 318                 # there was at least one package with two
 319                 # different source packages on different
 320                 # archs where one had a security update
 321                 # and the other one not
 322                 for ($archives->{$a}) {
 323                     /security/o &&  do {
 324                         $package_page .=  "&amp;type=security"; last };
 325                     /volatile/o &&  do {
 326                         $package_page .=  "&amp;type=volatile"; last };
 327                     /non-us/io  &&  do {
 328                         $package_page .=  "&amp;type=nonus"; last };
 329                     $package_page .=  "&amp;type=main";
 330                 }
 331                 $package_page .=  "\">$a</a></th>\n";
 332                 $package_page .= "<td>";
 333                 if ( $suite ne "experimental" ) {
 334                     $package_page .= sprintf( "[<a href=\"%s\">".gettext( "list of files" )."</a>]\n", "$FILELIST_URL$encodedpkg&amp;version=$suite&amp;arch=$a", $pkg );
 335                 } else {
 336                     $package_page .= gettext( "no current information" );
 337                 }
 338                 $package_page .= "</td>\n<td>";
 339                 $package_page .=  floor(($sizes_deb->{$a}/102.4)+0.5)/10;
 340                 $package_page .= "</td>\n<td>";
 341                 $package_page .=  $sizes_inst->{$a};
 342                 $package_page .= "</td>\n</tr>";
 343             }
 344             $package_page .= "</table><p>".gettext ( "Size is measured in kBytes." )."</p>\n";
 345             $package_page .= "</div> <!-- end pdownload -->\n";
 346
 347             #
 348             # more information
 349             #
 350             $package_page .= pmoreinfo( name => $pkg, data => $page,
 351                                         opts => \%opts,
 352                                         env => \%FTP_SITES,
 353                                         bugreports => 1, sourcedownload => 1,
 354                                         changesandcopy => 1, maintainers => 1,
 355                                         search => 1 );
 356         }
 357     }
 358 }
 359
 360 use Data::Dumper;
 361 debug( "Final page object:\n".Dumper($page), 3 );
 362
 363 print Packages::HTML::header( title => "Details of package <em>$pkg</em> in $suite" ,
 364                               lang => 'en',
 365                               desc => $short_desc,
 366                               keywords => "$suite, $archive, $section, $subsection, $version",
 367                               title_tag => "Details of package $pkg in $suite",
 368                               );
 369
 370 print_errors();
 371 print_hints();
 372 print_msgs();
 373 print_debug();
 374 print_notes();
 375
 376 unless (@Packages::CGI::fatal_errors) {
 377     print $package_page;
 378 }
 379 my $tet1 = new Benchmark;
 380 my $tetd = timediff($tet1, $tet0);
 381 print "Total page evaluation took ".timestr($tetd)."<br>"
 382     if $debug_allowed;
 383
 384 my $trailer = Packages::HTML::trailer( $ROOT );
 385 $trailer =~ s/LAST_MODIFIED_DATE/gmtime()/e; #FIXME
 386 print $trailer;
 387
 388 # vim: ts=8 sw=4