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 lib "../lib";
  25
  26 use Deb::Versions;
  27 use Packages::Search qw( :all );
  28 use Packages::HTML ();
  29
  30 my $HOME = "http://www.debian.org";
  31 my $ROOT = "";
  32 my $SEARCHPAGE = "http://packages.debian.org/";
  33 my @SUITES = qw( oldstable stable testing unstable experimental );
  34 my @DISTS = @SUITES;
  35 my @SECTIONS = qw( main contrib non-free );
  36 my @ARCHIVES = qw( us security installer );
  37 my @ARCHITECTURES = qw( alpha amd64 arm hppa hurd-i386 i386 ia64
  38                         kfreebsd-i386 mips mipsel powerpc s390 sparc );
  39 my %SUITES = map { $_ => 1 } @SUITES;
  40 my %SECTIONS = map { $_ => 1 } @SECTIONS;
  41 my %ARCHIVES = map { $_ => 1 } @ARCHIVES;
  42 my %ARCHITECTURES = map { $_ => 1 } @ARCHITECTURES;
  43
  44
  45
  46 $ENV{PATH} = "/bin:/usr/bin";
  47
  48 # Read in all the variables set by the form
  49 my $input;
  50 if ($ARGV[0] eq 'php') {
  51         $input = new CGI(\*STDIN);
  52 } else {
  53         $input = new CGI;
  54 }
  55
  56 my $pet0 = new Benchmark;
  57 # use this to disable debugging in production mode completly
  58 my $debug_allowed = 1;
  59 my $debug = $debug_allowed && $input->param("debug");
  60 $debug = 0 if not defined($debug);
  61 $Packages::Search::debug = 1 if $debug > 1;
  62
  63 # If you want, just print out a list of all of the variables and exit.
  64 print $input->header if $debug;
  65 # print $input->dump;
  66 # exit;
  67
  68 my %params_def = ( package => { default => undef, match => '^([a-z0-9.+-]+)$' },
  69                    suite => { default => undef, match => '^(\w+)$' },
  70                    #format => { default => 'html', match => '^(\w+)$' }
  71                    );
  72 my %params = Packages::Search::parse_params( $input, \%params_def );
  73
  74 my $format = $params{values}{format}{final};
  75 #XXX: Don't use alternative output formats yet
  76 $format = 'html';
  77
  78 if ($format eq 'html') {
  79     print $input->header;
  80 } elsif ($format eq 'xml') {
  81 #    print $input->header( -type=>'application/rdf+xml' );
  82     print $input->header( -type=>'text/plain' );
  83 }
  84
  85 if ($params{errors}{package}) {
  86     print "Error: package not valid or not specified" if $format eq 'html';
  87     exit 0;
  88 }
  89 if ($params{errors}{suite}) {
  90     print "Error: package not valid or not specified" if $format eq 'html';
  91     exit 0;
  92 }
  93 my $package = $params{values}{package}{final};
  94 my $suite = $params{values}{suite}{final};
  95
  96 # for output
  97 if ($format eq 'html') {
  98 print Packages::HTML::header( title => "Details of package <i>$package</i> in $suite" ,
  99                               lang => 'en',
 100                               title_tag => "Details of package $package in $suite",
 101                               print_title_above => 1
 102                               );
 103 }
 104
 105 # read the configuration
 106 my $topdir;
 107 if (!open (C, "../config.sh")) {
 108     print "\nInternal Error: Cannot open configuration file.\n\n"
 109 if $format eq 'html';
 110     exit 0;
 111 }
 112 while (<C>) {
 113     $topdir = $1 if (/^\s*topdir="?(.*)"?\s*$/);
 114 }
 115 close (C);
 116
 117 my $DBDIR = $topdir . "/files/db";
 118
 119 my $obj1 = tie my %packages, 'DB_File', "$DBDIR/packages_small.db", O_RDONLY, 0666, $DB_BTREE
 120     or die "couldn't tie DB $DBDIR/packages_small.db: $!";
 121 my $obj2 = tie my %packages_all, 'DB_File', "$DBDIR/packages_all_$suite.db", O_RDONLY, 0666, $DB_BTREE
 122     or die "couldn't tie DB $DBDIR/packages_all_$suite.db: $!";
 123 my %allsuites = ();
 124 my @results = ();
 125
 126
 127 &read_entry( $package, \@results, \%allsuites );
 128
 129 if (keys %allsuites == 0) {
 130     print "No such package";
 131     print "{insert link to search page with substring search}";
 132     exit;
 133 }
 134
 135 # sort is gross -- only fails for experimental though
 136 for (sort keys %allsuites) {
 137     if ($suite eq $_) {
 138         print "<strong>$_</strong> | ";
 139     } else {
 140         print "<a href=\"../$_/".uri_escape($package)."\">$_</a> | ";
 141     }
 142 }
 143 print "<br>";
 144 if (not exists $allsuites{$suite}) {
 145     print "Package not available in this suite";
 146     exit;
 147 }
 148
 149 for my $entry (@results) {
 150     print join ":", @$entry;
 151     print "<br>\n";
 152     my ($foo, $arch, $section, $subsection,
 153         $priority, $version) = @$entry;
 154     print "<pre>".$packages_all{"$package $arch $version"}."</pre>";
 155 }
 156
 157 &showpackage($package);
 158
 159 sub showpackage {
 160     my ( $pkg ) = @_;
 161
 162     my $name = $pkg->get_name;
 163
 164     if ( $pkg->is_virtual ) {
 165         print_virt_pack( @_ );
 166         return;
 167     }
 168
 169     my @all_archs = ( @{$env->{archs}}, 'all' );
 170
 171     my $page = new Packages::Page( $name,
 172                                    { architectures => $env->{archs} } );
 173     my $d = $page->set_data( $env->{db}, $pkg );
 174
 175     my %versions = $pkg->get_arch_versions( $env->{archs} );
 176     my %subsuites   = $pkg->get_arch_fields( 'subdistribution',
 177                                              $env->{archs} );
 178     my %filenames   = $pkg->get_arch_fields( 'filename',
 179                                              $env->{archs} );
 180     my %file_md5s   = $pkg->get_arch_fields( 'md5sum',
 181                                              $env->{archs} );
 182
 183     my $subsuite_kw = $d->{subsuite} || $env->{distribution};
 184     my $size_kw = exists $d->{sizes_deb}{i386} ? $d->{sizes_deb}{i386} : first_val($d->{sizes_deb});
 185
 186
 187     foreach my $lang (@{$env->{langs}}) {
 188         &Generated::Strings::string_lang($lang);
 189
 190         my $dirname = "$env->{dest_dir}/$d->{subsection}";
 191         my $filename = "$dirname/$name.$lang.html";
 192
 193         unless (( $lang eq 'en' )
 194                 || $env->{db}->is_translated( $name, $d->{version},
 195                                               ${$versions{v2a}{$d->{version}}}[0],
 196                                               $lang )) {
 197             $files->delete_file( $filename )
 198                 if $files->file_exists( $filename );
 199             next;
 200         }
 201         progress() if $env->{opts}{progress};
 202
 203         #
 204         # process description
 205         #
 206         my $short_desc = encode_entities( $env->{db}->get_short_desc( $d->{desc_md5},
 207                                                                       $lang ), "<>&\"" );
 208         my $long_desc = encode_entities( $env->{db}->get_long_desc( $d->{desc_md5},
 209                                                                     $lang ), "<>&\"" );
 210
 211         $long_desc =~ s,((ftp|http|https)://[\S~-]+?/?)((\&gt\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go; # syntax highlighting -> '];
 212         $long_desc =~ s/\A //o;
 213         $long_desc =~ s/\n /\n/sgo;
 214         $long_desc =~ s/\n.\n/\n<p>\n/go;
 215         $long_desc =~ s/(((\n|\A) [^\n]*)+)/\n<pre>$1\n<\/pre>/sgo;
 216
 217         $long_desc = conv_desc( $lang, $long_desc );
 218         $short_desc = conv_desc( $lang, $short_desc );
 219
 220         #
 221         # begin output
 222         #
 223         my $package_page = header( title => $name, lang => $lang,
 224                                    desc => $short_desc,
 225                                    keywords => "$env->{distribution}, $subsuite_kw, $d->{section}, $d->{subsection}, size:$size_kw $d->{version}" );
 226         $package_page .= simple_menu( [ gettext( "Distribution:" ),
 227                                         gettext( "Overview over this distribution" ),
 228                                         "../",
 229                                         $env->{distribution} ],
 230                                       [ gettext( "Section:" ),
 231                                         gettext( "All packages in this section" ),
 232                                         "../$d->{subsection}/",
 233                                         $d->{subsection} ],
 234                                       );
 235
 236         my $title .= sprintf( gettext( "Package: %s (%s)" ), $name, $d->{v_str_simple} );
 237         $title .=  " ".marker( $d->{subsuite} ) if $d->{subsuite};
 238         $title .=  " ".marker( $d->{section} ) if $d->{section} ne 'main';
 239         $package_page .= title( $title );
 240
 241         $package_page .= "<h2>".gettext( "Versions:" )." $d->{v_str_arch}</h2>\n"
 242             unless $d->{version} eq $d->{v_str_simple};
 243
 244         if ($env->{distribution} eq "experimental") {
 245             $package_page .= note( gettext( "Experimental package"),
 246                                    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>".
 247                                    gettext( "Users of experimental packages are encouraged to contact the package maintainers directly in case of problems." )
 248                                    );
 249         }
 250         if ($d->{section} eq "debian-installer") {
 251             $package_page .= note( gettext( "debian-installer udeb package"),
 252                                    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." )
 253                                    );
 254         }
 255         $package_page .= pdesc( $short_desc, $long_desc );
 256
 257         #
 258         # display dependencies
 259         #
 260         my $dep_list = print_deps( $env, $lang, $pkg, $d->{depends},    'depends' );
 261         $dep_list   .= print_deps( $env, $lang, $pkg, $d->{recommends}, 'recommends' );
 262         $dep_list   .= print_deps( $env, $lang, $pkg, $d->{suggests},   'suggests' );
 263
 264         if ( $dep_list ) {
 265             $package_page .= "<div id=\"pdeps\">\n";
 266             $package_page .= sprintf( "<h2>".gettext( "Other Packages Related to %s" )."</h2>\n", $name );
 267             if ($env->{distribution} eq "experimental") {
 268                 $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." ) );
 269             }
 270
 271             $package_page .= pdeplegend( [ 'dep',  gettext( 'depends' ) ],
 272                                          [ 'rec',  gettext( 'recommends' ) ],
 273                                          [ 'sug',  gettext( 'suggests' ) ], );
 274
 275             $package_page .= $dep_list;
 276             $package_page .= "</div> <!-- end pdeps -->\n";
 277         }
 278
 279         #
 280         # Download package
 281         #
 282         my $encodedpack = uri_escape( $name );
 283         $package_page .= "<div id=\"pdownload\">";
 284         $package_page .= sprintf( "<h2>".gettext( "Download %s\n" )."</h2>",
 285                                   $name ) ;
 286         $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";
 287         $package_page .= "<caption class=\"hidecss\">".gettext("Download for all available architectures")."</caption>\n";
 288         $package_page .= "<tr>\n";
 289         $package_page .= "<th>".gettext("Architecture")."</th><th>".gettext("Files")."</th><th>".gettext( "Package Size")."</th><th>".gettext("Installed Size")."</th></tr>\n";
 290         foreach my $a ( @all_archs ) {
 291             if ( exists $versions{a2v}{$a} ) {
 292                 $package_page .= "<tr>\n";
 293                 $package_page .=  "<th><a href=\"$DL_URL?arch=$a";
 294                 # \&amp\;file=\" method=\"post\">\n<p>";
 295                 $package_page .=  "&amp;file=".uri_escape($filenames{a2f}->{$a});
 296                 $package_page .=  "&amp;md5sum=$file_md5s{a2f}->{$a}";
 297                 $package_page .=  "&amp;arch=$a";
 298                 # there was at least one package with two
 299                 # different source packages on different
 300                 # archs where one had a security update
 301                 # and the other one not
 302                 if ($subsuites{a2f}{$a}
 303                     && ($subsuites{a2f}{$a} =~ /security/o) ) {
 304                     $package_page .=  "&amp;type=security";
 305                 } elsif ($subsuites{a2f}{$a}
 306                          && ($subsuites{a2f}{$a} =~ /volatile/o) ) {
 307                     $package_page .=  "&amp;type=volatile";
 308                 } elsif ($d->{is_nonus}) {
 309                     $package_page .=  "&amp;type=nonus";
 310                 } else {
 311                     $package_page .=  "&amp;type=main";
 312                 }
 313                 $package_page .=  "\">$a</a></th>\n";
 314                 $package_page .= "<td>";
 315                 if ( $env->{distribution} ne "experimental" ) {
 316                     $package_page .= sprintf( "[<a href=\"%s\">".gettext( "list of files" )."</a>]\n", "$FILELIST_URL$encodedpack&amp;version=$env->{distribution}&amp;arch=$a", $name );
 317                 } else {
 318                     $package_page .= "no files";
 319                 }
 320                 $package_page .= "</td>\n<td>";
 321                 my $size = $d->{sizes_deb}{$a};
 322                 $package_page .=  "$size";
 323                 $package_page .= "</td>\n<td>";
 324                 my $inst_size = $d->{sizes_inst}{$a};
 325                 $package_page .=  "$inst_size";
 326                 $package_page .= "</td>\n</tr>";
 327             }
 328         }
 329         $package_page .= "</table><p>".gettext ( "Size is measured in kBytes." )."</p>\n";
 330         $package_page .= "</div> <!-- end pdownload -->\n";
 331
 332         #
 333         # more information
 334         #
 335         $package_page .= pmoreinfo( name => $name, env => $env, data => $d,
 336                                     bugreports => 1, sourcedownload => 1,
 337                                     changesandcopy => 1, maintainers => 1,
 338                                     search => 1 );
 339
 340         #
 341         # Trailer
 342         #
 343         my @tr_langs = ();
 344         foreach my $l (@{$env->{langs}}) {
 345             next if $l eq $lang;
 346             push @tr_langs, $l if ( $l eq 'en' )
 347                 || $env->{db}->is_translated( $name, $d->{version},
 348                                               ${$versions{v2a}{$d->{version}}}[0],
 349                                               $l );
 350         }
 351         $package_page .= trailer( '../..', $name, $lang, @tr_langs );
 352
 353         #
 354         # write file
 355         #
 356         $files->update_file( $filename, $package_page );
 357
 358         #
 359         # create data sheet
 360         #
 361         if($lang eq 'en') {
 362             my $data_sheet = header( title => "$name -- Data sheet",
 363                                      lang => "en",
 364                                      desc => $short_desc,
 365                                      keywords => "$env->{distribution}, $subsuite_kw, $d->{section}, $d->{subsection}, size:$size_kw $d->{version}" );
 366
 367             my $ds_title = $name;
 368             if ( $d->{subsuite} ) {
 369                 $ds_title .=  " ".marker( $d->{subsuite} );
 370             }
 371             if ( $d->{section} ne 'main' ) {
 372                 $ds_title .=  " ".marker( $d->{section} );
 373             }
 374             $data_sheet .= title( $ds_title );
 375
 376             $data_sheet .= ds_begin;
 377             $data_sheet .= ds_item(gettext( "Version" ), $d->{v_str_arch});
 378
 379             my @uploaders = @{$d->{uploaders}};
 380             my ( $maint_name, $maint_email ) = @{shift @uploaders};
 381             $data_sheet .= ds_item(gettext( "Maintainer" ),
 382                                    "<a href=\"$DDPO_URL".
 383                                    uri_escape($maint_email).
 384                                    "\">".encode_entities($maint_name, '&<>')."</a>" );
 385             if (@uploaders) {
 386                 my @uploaders_str;
 387                 foreach (@uploaders) {
 388                     push @uploaders_str, "<a href=\"$DDPO_URL".uri_escape($_->[1])."\">".encode_entities($_->[0], '&<>')."</a>";
 389                 }
 390                 $data_sheet .= ds_item(gettext( "Uploaders" ),
 391                                        join( ",\n ", @uploaders_str ));
 392             }
 393             $data_sheet .= ds_item(gettext( "Section" ),
 394                                    "<a href=\"../$d->{subsection}/\">$d->{subsection}</a>");
 395             $data_sheet .= ds_item(gettext( "Priority" ),
 396                                    "<a href=\"../$d->{priority}\">$d->{priority}</a>");
 397             $data_sheet .= ds_item(gettext( "Essential" ),
 398                                    "<a href=\"../essential\">".
 399                                    gettext("yes")."</a>")
 400                 if $d->{essential} =~ /yes/i;
 401             $data_sheet .= ds_item(gettext( "Source package" ),
 402                                    "<a href=\"../source/$d->{src_name}\">$d->{src_name}</a>");
 403             $data_sheet .= print_deps_ds( $env, $pkg, $d->{depends},    'Depends' );
 404             $data_sheet .= print_deps_ds( $env, $pkg, $d->{recommends}, 'Recommends' );
 405             $data_sheet .= print_deps_ds( $env, $pkg, $d->{suggests},   'Suggests' );
 406             $data_sheet .= print_deps_ds( $env, $pkg, $d->{enhances},   'Enhances' );
 407             $data_sheet .= print_deps_ds( $env, $pkg, $d->{conflicts},  'Conflicts' );
 408             $data_sheet .= print_deps_ds( $env, $pkg, $d->{provides},   'Provides' );
 409 #           $data_sheet .= print_reverse_rel_ds( $env, $pkg, \%versions, 'Depends' );
 410 #           $data_sheet .= print_reverse_rel_ds( $env, $pkg, \%versions, 'Recommends' );
 411 #           $data_sheet .= print_reverse_rel_ds( $env, $pkg, \%versions, 'Suggests' );
 412 #           $data_sheet .= print_reverse_rel_ds( $env, $pkg, \%versions, 'Enhances' );
 413 #           $data_sheet .= print_reverse_rel_ds( $env, $pkg, \%versions, 'Provides' );
 414 #           $data_sheet .= print_reverse_rel_ds( $env, $pkg, \%versions, 'Conflicts' );
 415 #           $data_sheet .= print_reverse_rel_ds( $env, $pkg, \%versions, 'Build-Depends' );
 416 #           $data_sheet .= print_reverse_rel_ds( $env, $pkg, \%versions, 'Build-Depends-Indep' );
 417 #           $data_sheet .= print_reverse_rel_ds( $env, $pkg, \%versions, 'Build-Conflicts' );
 418
 419 #           if ( $name eq 'libc6' ) {
 420 #               use Data::Dumper;
 421 #               print STDERR Dumper( $pkg );
 422 #           }
 423
 424             $data_sheet .= ds_end;
 425
 426             $data_sheet .= trailer( '../..', $name );
 427
 428             my $ds_filename = "$dirname/ds_$name.$lang.html";
 429             #
 430             # write file
 431             #
 432             print $data_sheet;
 433         }
 434     }
 435 }
 436
 437 &printfooter;
 438
 439 sub read_entry {
 440     my ($key, $results, $allsuites) = @_;
 441     my $result = $packages{$key};
 442     foreach (split /\000/, $result) {
 443         my @data = split ( /\s/, $_, 7 );
 444         print "DEBUG: Considering entry ".join( ':', @data)."<br>" if $debug > 2;
 445         if ($suite eq $data[0]) {
 446             print "DEBUG: Using entry ".join( ':', @data)."<br>" if $debug > 2;
 447             push @$results, [@data];
 448         }
 449         $allsuites->{$data[0]} = 1;
 450     }
 451 }
 452
 453 # TODO: move to common lib:
 454 sub printfooter {
 455     print <<END;
 456 </div>
 457
 458 <hr class="hidecss">
 459 <p style="text-align:right;font-size:small;font-stlye:italic"><a href="$SEARCHPAGE">Packages search page</a></p>
 460
 461 </div>
 462 END
 463
 464     my $pete = new Benchmark;
 465     my $petd = timediff($pete, $pet0);
 466     print "Total page evaluation took ".timestr($petd)."<br>"
 467         if $debug_allowed;
 468
 469     print $input->end_html;
 470 }
 471
 472 # vim: ts=8 sw=4