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