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 non-US)] } },
  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             debug( "find source package: source=$source (=$source_version)", 1);
 174             my $src_data = $sources_all{"$source $source_version"};
 175             unless ($src_data) { #fucking binNMUs
 176                 my $versions = $page->get_versions;
 177                 my $sources = $page->get_arch_field( 'source' );
 178                 my $source_versions = $page->get_arch_field( 'source-version' );
 179                 foreach (version_sort keys %$versions) {
 180                     $source = $sources->{$versions->{$_}[0]};
 181                     $source = $source_versions->{$versions->{$_}[0]}
 182                     || $version;
 183                     $src_data = $sources_all{"$source $source_version"};
 184                     last if $src_data;
 185                 }
 186                 error( "couldn't find source package" ) unless $src_data;
 187             }
 188             $page->add_src_data( $source, $source_version, $src_data )
 189                 if $src_data;
 190
 191             my $st1 = new Benchmark;
 192             my $std = timediff($st1, $st0);
 193             debug( "Data search and merging took ".timestr($std) );
 194
 195             my $encodedpkg = uri_escape( $pkg );
 196             my ($v_str, $v_str_arch, $v_str_arr) = $page->get_version_string();
 197             my $did = $page->get_newest( 'description' );
 198             $archive = $page->get_newest( 'archive' );
 199             $section = $page->get_newest( 'section' );
 200             $subsection = $page->get_newest( 'subsection' );
 201             my $filenames = $page->get_arch_field( 'filename' );
 202             my $file_md5sums = $page->get_arch_field( 'md5sum' );
 203             my $archives = $page->get_arch_field( 'archive' );
 204             my $sizes_inst = $page->get_arch_field( 'installed-size' );
 205             my $sizes_deb = $page->get_arch_field( 'size' );
 206             my @archs = sort $page->get_architectures;
 207
 208             # process description
 209             #
 210             my $desc = $descriptions{$did};
 211             $short_desc = encode_entities( $1, "<>&\"" )
 212                 if $desc =~ s/^(.*)$//m;
 213             my $long_desc = encode_entities( $desc, "<>&\"" );
 214
 215             $long_desc =~ s,((ftp|http|https)://[\S~-]+?/?)((\&gt\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go; # syntax highlighting -> '];
 216             $long_desc =~ s/\A //o;
 217             $long_desc =~ s/\n /\n/sgo;
 218             $long_desc =~ s/\n.\n/\n<p>\n/go;
 219             $long_desc =~ s/(((\n|\A) [^\n]*)+)/\n<pre>$1\n<\/pre>/sgo;
 220 #           $long_desc = conv_desc( $lang, $long_desc );
 221 #           $short_desc = conv_desc( $lang, $short_desc );
 222
 223             my %all_suites;
 224             foreach (@results, @non_results) {
 225                 my $a = $_->[1];
 226                 my $s = $_->[2];
 227                 if ($a =~ /^(?:us|security|non-US)$/o) {
 228                     $all_suites{$s}++;
 229                 } else {
 230                     $all_suites{"$s/$a"}++;
 231                 }
 232             }
 233             foreach (suites_sort(keys %all_suites)) {
 234                 if (("$suite/$archive" eq $_)
 235                     || (!$all_suites{"$suite/$archive"} && ($suite eq $_))) {
 236                     $package_page .= "[ <strong>$_</strong> ] ";
 237                 } else {
 238                     $package_page .=
 239                         "[ <a href=\"$ROOT/$_/".uri_escape($pkg)."\">$_</a> ] ";
 240                 }
 241             }
 242             $package_page .= '<br>';
 243
 244             $package_page .= simple_menu( [ gettext( "Distribution:" ),
 245                                             gettext( "Overview over this suite" ),
 246                                             "/$suite/",
 247                                             $suite ],
 248                                           [ gettext( "Section:" ),
 249                                             gettext( "All packages in this section" ),
 250                                             "/$suite/$subsection/",
 251                                             $subsection ],
 252                                           );
 253
 254             my $title .= sprintf( gettext( "Package: %s (%s)" ), $pkg, $v_str );
 255             $title .=  " ".marker( $archive ) if $archive ne 'us';
 256             $title .=  " ".marker( $subsection ) if $subsection eq 'non-US'
 257                 and $archive ne 'non-US'; # non-US/security
 258             $title .=  " ".marker( $section ) if $section ne 'main';
 259             $package_page .= title( $title );
 260
 261             $package_page .= "<h2>".gettext( "Versions:" )." $v_str_arch</h2>\n"
 262                 unless $version eq $v_str;
 263
 264             if ($suite eq "experimental") {
 265                 $package_page .= note( gettext( "Experimental package"),
 266                                        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>".
 267                                        gettext( "Users of experimental packages are encouraged to contact the package maintainers directly in case of problems." )
 268                                        );
 269             }
 270             if ($subsection eq "debian-installer") {
 271                 note( gettext( "debian-installer udeb package"),
 272                       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." )
 273                       );
 274             }
 275             $package_page .= pdesc( $short_desc, $long_desc );
 276
 277             #
 278             # display dependencies
 279             #
 280             my $dep_list;
 281             $dep_list = print_deps( \%packages, \%opts, $pkg,
 282                                        $page->get_dep_field('depends'),
 283                                        'depends' );
 284             $dep_list .= print_deps( \%packages, \%opts, $pkg,
 285                                        $page->get_dep_field('recommends'),
 286                                        'recommends' );
 287             $dep_list .= print_deps( \%packages, \%opts, $pkg,
 288                                        $page->get_dep_field('suggests'),
 289                                        'suggests' );
 290
 291             if ( $dep_list ) {
 292                 $package_page .= "<div id=\"pdeps\">\n";
 293                 $package_page .= sprintf( "<h2>".gettext( "Other Packages Related to %s" )."</h2>\n", $pkg );
 294                 if ($suite eq "experimental") {
 295                     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." ) );
 296                 }
 297
 298                 $package_page .= pdeplegend( [ 'dep',  gettext( 'depends' ) ],
 299                                              [ 'rec',  gettext( 'recommends' ) ],
 300                                              [ 'sug',  gettext( 'suggests' ) ], );
 301
 302                 $package_page .= $dep_list;
 303                 $package_page .= "</div> <!-- end pdeps -->\n";
 304             }
 305
 306             #
 307             # Download package
 308             #
 309             my $encodedpack = uri_escape( $pkg );
 310             $package_page .= "<div id=\"pdownload\">";
 311             $package_page .= sprintf( "<h2>".gettext( "Download %s\n" )."</h2>",
 312                                       $pkg ) ;
 313             $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";
 314             $package_page .= "<caption class=\"hidecss\">".gettext("Download for all available architectures")."</caption>\n";
 315             $package_page .= "<tr>\n";
 316             $package_page .= "<th>".gettext("Architecture")."</th><th>".gettext("Files")."</th><th>".gettext( "Package Size")."</th><th>".gettext("Installed Size")."</th></tr>\n";
 317             foreach my $a ( @archs ) {
 318                 $package_page .= "<tr>\n";
 319                 $package_page .=  "<th><a href=\"$DL_URL?arch=$a";
 320                 $package_page .=  "&amp;file=".uri_escape($filenames->{$a});
 321                 $package_page .=  "&amp;md5sum=$file_md5sums->{$a}";
 322                 $package_page .=  "&amp;arch=$a";
 323                 # there was at least one package with two
 324                 # different source packages on different
 325                 # archs where one had a security update
 326                 # and the other one not
 327                 for ($archives->{$a}) {
 328                     /security/o &&  do {
 329                         $package_page .=  "&amp;type=security"; last };
 330                     /volatile/o &&  do {
 331                         $package_page .=  "&amp;type=volatile"; last };
 332                     /non-us/io  &&  do {
 333                         $package_page .=  "&amp;type=nonus"; last };
 334                     $package_page .=  "&amp;type=main";
 335                 }
 336                 $package_page .=  "\">$a</a></th>\n";
 337                 $package_page .= "<td>";
 338                 if ( $suite ne "experimental" ) {
 339                     $package_page .= sprintf( "[<a href=\"%s\">".gettext( "list of files" )."</a>]\n", "$FILELIST_URL$encodedpkg&amp;version=$suite&amp;arch=$a", $pkg );
 340                 } else {
 341                     $package_page .= gettext( "no current information" );
 342                 }
 343                 $package_page .= "</td>\n<td>";
 344                 $package_page .=  floor(($sizes_deb->{$a}/102.4)+0.5)/10;
 345                 $package_page .= "</td>\n<td>";
 346                 $package_page .=  $sizes_inst->{$a};
 347                 $package_page .= "</td>\n</tr>";
 348             }
 349             $package_page .= "</table><p>".gettext ( "Size is measured in kBytes." )."</p>\n";
 350             $package_page .= "</div> <!-- end pdownload -->\n";
 351
 352             #
 353             # more information
 354             #
 355             $package_page .= pmoreinfo( name => $pkg, data => $page,
 356                                         opts => \%opts,
 357                                         env => \%FTP_SITES,
 358                                         bugreports => 1, sourcedownload => 1,
 359                                         changesandcopy => 1, maintainers => 1,
 360                                         search => 1 );
 361         }
 362     }
 363 }
 364
 365 use Data::Dumper;
 366 debug( "Final page object:\n".Dumper($page), 3 );
 367
 368 print Packages::HTML::header( title => "Details of package <em>$pkg</em> in $suite" ,
 369                               lang => 'en',
 370                               desc => $short_desc,
 371                               keywords => "$suite, $archive, $section, $subsection, $version",
 372                               title_tag => "Details of package $pkg in $suite",
 373                               );
 374
 375 print_errors();
 376 print_hints();
 377 print_msgs();
 378 print_debug();
 379 print_notes();
 380
 381 unless (@Packages::CGI::fatal_errors) {
 382     print $package_page;
 383 }
 384 my $tet1 = new Benchmark;
 385 my $tetd = timediff($tet1, $tet0);
 386 print "Total page evaluation took ".timestr($tetd)."<br>"
 387     if $debug_allowed;
 388
 389 my $trailer = Packages::HTML::trailer( $ROOT );
 390 $trailer =~ s/LAST_MODIFIED_DATE/gmtime()/e; #FIXME
 391 print $trailer;
 392
 393 # vim: ts=8 sw=4