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