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