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         @SUITES = split(/\s+/, $1) if /^\s*suites="?([^\"]*)"?\s*$/o;
  72         @SECTIONS = split(/\s+/, $1) if /^\s*sections="?([^\"]*)"?\s*$/o;
  73         @ARCHIVES = split(/\s+/, $1) if /^\s*archives="?([^\"]*)"?\s*$/o;
  74         @ARCHITECTURES = split(/\s+/, $1) if /^\s*architectures="?([^\"]*)"?\s*$/o;
  75     }
  76     close (C);
  77     debug( "read config ($modtime > $config_read_time)" );
  78     $config_read_time = $modtime;
  79 }
  80 my $DBDIR = $topdir . "/files/db";
  81 my $thisscript = $Packages::HTML::SEARCH_CGI;
  82
  83 if (my $path = $input->param('path')) {
  84     my @components = map { lc $_ } split /\//, $path;
  85
  86     my %SUITES = map { $_ => 1 } @SUITES;
  87     my %SECTIONS = map { $_ => 1 } @SECTIONS;
  88     my %ARCHIVES = map { $_ => 1 } @ARCHIVES;
  89     my %ARCHITECTURES = map { $_ => 1 } @ARCHITECTURES;
  90
  91     foreach (@components) {
  92         if ($SUITES{$_}) {
  93             $input->param('suite', $_);
  94         }# elsif ($SECTIONS{$_}) {
  95 #           $input->param('section', $_);
  96 #       } elsif ($ARCHIVES{$_}) {
  97 #           $input->param('archive', $_);
  98 #       } elsif ($ARCHITECTURES{$_}) {
  99 #           $input->param('arch', $_);
 100 #       }
 101     }
 102 }
 103
 104 my ( $pkg, $suite, $format );
 105 my %params_def = ( package => { default => undef, match => '^([a-z0-9.+-]+)$',
 106                                 var => \$pkg },
 107                    suite => { default => undef, match => '^(\w+)$',
 108                               var => \$suite },
 109                    format => { default => 'html', match => '^(\w+)$',
 110                                var => \$format }
 111                    );
 112 my %opts;
 113 my %params = Packages::Search::parse_params( $input, \%params_def, \%opts );
 114
 115 $opts{h_suites} =   { $suite => 1 };
 116 $opts{h_archs} =    { map { $_ => 1 } @ARCHITECTURES };
 117 $opts{h_sections} = { map { $_ => 1 } @SECTIONS };
 118 $opts{h_archives} = { map { $_ => 1 } @ARCHIVES };
 119
 120 #XXX: Don't use alternative output formats yet
 121 $format = 'html';
 122 if ($format eq 'html') {
 123     print $input->header;
 124 }
 125
 126 if ($params{errors}{package}) {
 127     fatal_error( "package not valid or not specified" );
 128 }
 129 if ($params{errors}{suite}) {
 130     fatal_error( "suite not valid or not specified" );
 131 }
 132
 133 my $DL_URL = "$pkg/download";
 134 my $FILELIST_URL = "$pkg/files";
 135 my $DDPO_URL = "http://qa.debian.org/developer.php?email=";
 136
 137 our (%packages, %packages_all);
 138 my (@results, @non_results);
 139
 140 unless (@Packages::CGI::fatal_errors) {
 141     my $dbmodtime = (stat("$DBDIR/packages_small.db"))[9];
 142     if ($dbmodtime > $db_read_time) {
 143         tie %packages, 'DB_File', "$DBDIR/packages_small.db",
 144         O_RDONLY, 0666, $DB_BTREE
 145             or die "couldn't tie DB $DBDIR/packages_small.db: $!";
 146         tie %packages_all, 'DB_File', "$DBDIR/packages_all_$suite.db",
 147         O_RDONLY, 0666, $DB_BTREE
 148             or die "couldn't tie DB $DBDIR/packages_all_$suite.db: $!";
 149         debug( "tied databases ($dbmodtime > $db_read_time)" );
 150         $db_read_time = $dbmodtime;
 151     }
 152
 153     read_entry_all( \%packages, $pkg, \@results, \@non_results, \%opts );
 154
 155     unless (@results || @non_results ) {
 156         fatal_error( "No such package".
 157                      "{insert link to search page with substring search}" );
 158     } else {
 159         unless (@results) {
 160             fatal_error( "Package not available in this suite" );
 161         }
 162     }
 163 }
 164
 165 print Packages::HTML::header( title => "Details of package <em>$pkg</em> in $suite" ,
 166                               lang => 'en',
 167                               title_tag => "Details of package $pkg in $suite",
 168                               print_title_above => 1
 169                               );
 170
 171 print_errors();
 172 print_hints();
 173 print_msgs();
 174 print_debug();
 175
 176 unless (@Packages::CGI::fatal_errors) {
 177
 178 my %all_suites = map { $_->[2] => 1 } (@results, @non_results);
 179     foreach (suites_sort(keys %all_suites)) {
 180         if ($suite eq $_) {
 181             print "<strong>$_</strong> | ";
 182         } else {
 183             print "<a href=\"../$_/".uri_escape($pkg)."\">$_</a> | ";
 184         }
 185     }
 186     print "<br>";
 187
 188 my $page = new Packages::Page( $pkg );
 189
 190     for my $entry (@results) {
 191         print join ":", @$entry;
 192         print "<br>\n";
 193         my (undef, $archive, undef, $arch, $section, $subsection,
 194             $priority, $version) = @$entry;
 195         print "<pre>".$packages_all{"$pkg $arch $version"}."</pre>";
 196     }
 197
 198 #       my %versions = $pkg->get_arch_versions( $env->{archs} );
 199 #       my %subsuites   = $pkg->get_arch_fields( 'subdistribution',
 200 #                                                $env->{archs} );
 201 #       my %filenames   = $pkg->get_arch_fields( 'filename',
 202 #                                                $env->{archs} );
 203 #       my %file_md5s   = $pkg->get_arch_fields( 'md5sum',
 204 #                                                $env->{archs} );
 205
 206 #       my $subsuite_kw = $d->{subsuite} || $env->{distribution};
 207 #       my $size_kw = exists $d->{sizes_deb}{i386} ? $d->{sizes_deb}{i386} : first_val($d->{sizes_deb});
 208
 209
 210 #       foreach my $lang (@{$env->{langs}}) {
 211 #           &Generated::Strings::string_lang($lang);
 212
 213 #           my $dirname = "$env->{dest_dir}/$d->{subsection}";
 214 #           my $filename = "$dirname/$name.$lang.html";
 215
 216 #           unless (( $lang eq 'en' )
 217 #                   || $env->{db}->is_translated( $name, $d->{version},
 218 #                                                 ${$versions{v2a}{$d->{version}}}[0],
 219 #                                                 $lang )) {
 220 #               next;
 221 #           }
 222 #           progress() if $env->{opts}{progress};
 223
 224 #           #
 225 #           # process description
 226 #           #
 227 #           my $short_desc = encode_entities( $env->{db}->get_short_desc( $d->{desc_md5},
 228 #                                                                         $lang ), "<>&\"" );
 229 #           my $long_desc = encode_entities( $env->{db}->get_long_desc( $d->{desc_md5},
 230 #                                                                       $lang ), "<>&\"" );
 231
 232 #           $long_desc =~ s,((ftp|http|https)://[\S~-]+?/?)((\&gt\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go; # syntax highlighting -> '];
 233 #           $long_desc =~ s/\A //o;
 234 #           $long_desc =~ s/\n /\n/sgo;
 235 #           $long_desc =~ s/\n.\n/\n<p>\n/go;
 236 #           $long_desc =~ s/(((\n|\A) [^\n]*)+)/\n<pre>$1\n<\/pre>/sgo;
 237
 238 #           $long_desc = conv_desc( $lang, $long_desc );
 239 #           $short_desc = conv_desc( $lang, $short_desc );
 240
 241 #           #
 242 #           # begin output
 243 #           #
 244 #           my $package_page = header( title => $name, lang => $lang,
 245 #                                      desc => $short_desc,
 246 #                                      keywords => "$env->{distribution}, $subsuite_kw, $d->{section}, $d->{subsection}, size:$size_kw $d->{version}" );
 247 #           $package_page .= simple_menu( [ gettext( "Distribution:" ),
 248 #                                           gettext( "Overview over this distribution" ),
 249 #                                           "../",
 250 #                                           $env->{distribution} ],
 251 #                                         [ gettext( "Section:" ),
 252 #                                           gettext( "All packages in this section" ),
 253 #                                           "../$d->{subsection}/",
 254 #                                           $d->{subsection} ],
 255 #                                         );
 256
 257 #           my $title .= sprintf( gettext( "Package: %s (%s)" ), $name, $d->{v_str_simple} );
 258 #           $title .=  " ".marker( $d->{subsuite} ) if $d->{subsuite};
 259 #           $title .=  " ".marker( $d->{section} ) if $d->{section} ne 'main';
 260 #           $package_page .= title( $title );
 261
 262 #           $package_page .= "<h2>".gettext( "Versions:" )." $d->{v_str_arch}</h2>\n"
 263 #               unless $d->{version} eq $d->{v_str_simple};
 264
 265 #           if ($env->{distribution} eq "experimental") {
 266 #               $package_page .= note( gettext( "Experimental package"),
 267 #                                      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>".
 268 #                                      gettext( "Users of experimental packages are encouraged to contact the package maintainers directly in case of problems." )
 269 #                                      );
 270 #           }
 271 #           if ($d->{section} eq "debian-installer") {
 272 #               $package_page .= note( gettext( "debian-installer udeb package"),
 273 #                                      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." )
 274 #                                      );
 275 #           }
 276 #           $package_page .= pdesc( $short_desc, $long_desc );
 277
 278 #           #
 279 #           # display dependencies
 280 #           #
 281 #           my $dep_list = print_deps( $env, $lang, $pkg, $d->{depends},    'depends' );
 282 #           $dep_list   .= print_deps( $env, $lang, $pkg, $d->{recommends}, 'recommends' );
 283 #           $dep_list   .= print_deps( $env, $lang, $pkg, $d->{suggests},   'suggests' );
 284
 285 #           if ( $dep_list ) {
 286 #               $package_page .= "<div id=\"pdeps\">\n";
 287 #               $package_page .= sprintf( "<h2>".gettext( "Other Packages Related to %s" )."</h2>\n", $name );
 288 #               if ($env->{distribution} eq "experimental") {
 289 #                   $package_page .= 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." ) );
 290 #               }
 291
 292 #               $package_page .= pdeplegend( [ 'dep',  gettext( 'depends' ) ],
 293 #                                            [ 'rec',  gettext( 'recommends' ) ],
 294 #                                            [ 'sug',  gettext( 'suggests' ) ], );
 295
 296 #               $package_page .= $dep_list;
 297 #               $package_page .= "</div> <!-- end pdeps -->\n";
 298 #           }
 299
 300 #           #
 301 #           # Download package
 302 #           #
 303 #           my $encodedpack = uri_escape( $name );
 304 #           $package_page .= "<div id=\"pdownload\">";
 305 #           $package_page .= sprintf( "<h2>".gettext( "Download %s\n" )."</h2>",
 306 #                                     $name ) ;
 307 #           $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";
 308 #           $package_page .= "<caption class=\"hidecss\">".gettext("Download for all available architectures")."</caption>\n";
 309 #           $package_page .= "<tr>\n";
 310 #           $package_page .= "<th>".gettext("Architecture")."</th><th>".gettext("Files")."</th><th>".gettext( "Package Size")."</th><th>".gettext("Installed Size")."</th></tr>\n";
 311 #           foreach my $a ( @all_archs ) {
 312 #               if ( exists $versions{a2v}{$a} ) {
 313 #                   $package_page .= "<tr>\n";
 314 #                   $package_page .=  "<th><a href=\"$DL_URL?arch=$a";
 315 #                   # \&amp\;file=\" method=\"post\">\n<p>";
 316 #                   $package_page .=  "&amp;file=".uri_escape($filenames{a2f}->{$a});
 317 #                   $package_page .=  "&amp;md5sum=$file_md5s{a2f}->{$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 #                   if ($subsuites{a2f}{$a}
 324 #                       && ($subsuites{a2f}{$a} =~ /security/o) ) {
 325 #                       $package_page .=  "&amp;type=security";
 326 #                   } elsif ($subsuites{a2f}{$a}
 327 #                            && ($subsuites{a2f}{$a} =~ /volatile/o) ) {
 328 #                       $package_page .=  "&amp;type=volatile";
 329 #                   } elsif ($d->{is_nonus}) {
 330 #                       $package_page .=  "&amp;type=nonus";
 331 #                   } else {
 332 #                       $package_page .=  "&amp;type=main";
 333 #                   }
 334 #                   $package_page .=  "\">$a</a></th>\n";
 335 #                   $package_page .= "<td>";
 336 #                   if ( $env->{distribution} ne "experimental" ) {
 337 #                       $package_page .= sprintf( "[<a href=\"%s\">".gettext( "list of files" )."</a>]\n", "$FILELIST_URL$encodedpack&amp;version=$env->{distribution}&amp;arch=$a", $name );
 338 #                   } else {
 339 #                       $package_page .= "no files";
 340 #                   }
 341 #                   $package_page .= "</td>\n<td>";
 342 #                   my $size = $d->{sizes_deb}{$a};
 343 #                   $package_page .=  "$size";
 344 #                   $package_page .= "</td>\n<td>";
 345 #                   my $inst_size = $d->{sizes_inst}{$a};
 346 #                   $package_page .=  "$inst_size";
 347 #                   $package_page .= "</td>\n</tr>";
 348 #               }
 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 => $name, env => $env, data => $d,
 357 #                                       bugreports => 1, sourcedownload => 1,
 358 #                                       changesandcopy => 1, maintainers => 1,
 359 #                                       search => 1 );
 360
 361 #           #
 362 #           # Trailer
 363 #           #
 364 #           my @tr_langs = ();
 365 #           foreach my $l (@{$env->{langs}}) {
 366 #               next if $l eq $lang;
 367 #               push @tr_langs, $l if ( $l eq 'en' )
 368 #                   || $env->{db}->is_translated( $name, $d->{version},
 369 #                                                 ${$versions{v2a}{$d->{version}}}[0],
 370 #                                                 $l );
 371 #           }
 372 #           $package_page .= trailer( '../..', $name, $lang, @tr_langs );
 373 #       }
 374 #     }
 375 }
 376 my $tet1 = new Benchmark;
 377 my $tetd = timediff($tet1, $tet0);
 378 print "Total page evaluation took ".timestr($tetd)."<br>"
 379     if $debug_allowed;
 380
 381 my $trailer = Packages::HTML::trailer( $ROOT );
 382 $trailer =~ s/LAST_MODIFIED_DATE/gmtime()/e; #FIXME
 383 print $trailer;
 384
 385 # vim: ts=8 sw=4