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 use Packages::Page ();
  30
  31 my $HOME = "http://www.debian.org";
  32 my $ROOT = "";
  33 my $SEARCHPAGE = "http://packages.debian.org/";
  34 my @SUITES = qw( oldstable stable testing unstable experimental );
  35 my @DISTS = @SUITES;
  36 my @SECTIONS = qw( main contrib non-free );
  37 my @ARCHIVES = qw( us security installer );
  38 my @ARCHITECTURES = qw( alpha amd64 arm hppa hurd-i386 i386 ia64
  39                         kfreebsd-i386 mips mipsel powerpc s390 sparc );
  40 my %SUITES = map { $_ => 1 } @SUITES;
  41 my %SECTIONS = map { $_ => 1 } @SECTIONS;
  42 my %ARCHIVES = map { $_ => 1 } @ARCHIVES;
  43 my %ARCHITECTURES = map { $_ => 1 } @ARCHITECTURES;
  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     $ROOT = $1 if /^\s*root="?(.*)"?\s*$/;
 115 }
 116 close (C);
 117
 118 my $DBDIR = $topdir . "/files/db";
 119 my $DL_URL = "$package/download";
 120 my $FILELIST_URL = "$package/files";
 121 my $DDPO_URL = "http://qa.debian.org/developer.php?email=";
 122
 123
 124 my $obj1 = tie my %packages, 'DB_File', "$DBDIR/packages_small.db", O_RDONLY, 0666, $DB_BTREE
 125     or die "couldn't tie DB $DBDIR/packages_small.db: $!";
 126 my $obj2 = tie my %packages_all, 'DB_File', "$DBDIR/packages_all_$suite.db", O_RDONLY, 0666, $DB_BTREE
 127     or die "couldn't tie DB $DBDIR/packages_all_$suite.db: $!";
 128 my %allsuites = ();
 129 my @results = ();
 130
 131
 132 &read_entry( $package, \@results, \%allsuites );
 133
 134 if (keys %allsuites == 0) {
 135     print "No such package";
 136     print "{insert link to search page with substring search}";
 137     exit;
 138 }
 139
 140 # sort is gross -- only fails for experimental though
 141 for (sort keys %allsuites) {
 142     if ($suite eq $_) {
 143         print "<strong>$_</strong> | ";
 144     } else {
 145         print "<a href=\"../$_/".uri_escape($package)."\">$_</a> | ";
 146     }
 147 }
 148 print "<br>";
 149 if (not exists $allsuites{$suite}) {
 150     print "Package not available in this suite";
 151     exit;
 152 }
 153
 154 for my $entry (@results) {
 155     print join ":", @$entry;
 156     print "<br>\n";
 157     my ($foo, $arch, $section, $subsection,
 158         $priority, $version) = @$entry;
 159     print "<pre>".$packages_all{"$package $arch $version"}."</pre>";
 160 }
 161
 162 &showpackage($package);
 163
 164 sub showpackage {
 165     my ( $pkg ) = @_;
 166
 167     my $env;
 168
 169     my $name = $pkg->get_name;
 170
 171     if ( $pkg->is_virtual ) {
 172         print_virt_pack( @_ );
 173         return;
 174     }
 175
 176     my @all_archs = ( @{$env->{archs}}, 'all' );
 177
 178     my $page = new Packages::Page( $name,
 179                                    { architectures => $env->{archs} } );
 180     my $d = $page->set_data( $env->{db}, $pkg );
 181
 182     my %versions = $pkg->get_arch_versions( $env->{archs} );
 183     my %subsuites   = $pkg->get_arch_fields( 'subdistribution',
 184                                              $env->{archs} );
 185     my %filenames   = $pkg->get_arch_fields( 'filename',
 186                                              $env->{archs} );
 187     my %file_md5s   = $pkg->get_arch_fields( 'md5sum',
 188                                              $env->{archs} );
 189
 190     my $subsuite_kw = $d->{subsuite} || $env->{distribution};
 191     my $size_kw = exists $d->{sizes_deb}{i386} ? $d->{sizes_deb}{i386} : first_val($d->{sizes_deb});
 192
 193
 194     foreach my $lang (@{$env->{langs}}) {
 195         &Generated::Strings::string_lang($lang);
 196
 197         my $dirname = "$env->{dest_dir}/$d->{subsection}";
 198         my $filename = "$dirname/$name.$lang.html";
 199
 200         unless (( $lang eq 'en' )
 201                 || $env->{db}->is_translated( $name, $d->{version},
 202                                               ${$versions{v2a}{$d->{version}}}[0],
 203                                               $lang )) {
 204             next;
 205         }
 206         progress() if $env->{opts}{progress};
 207
 208         #
 209         # process description
 210         #
 211         my $short_desc = encode_entities( $env->{db}->get_short_desc( $d->{desc_md5},
 212                                                                       $lang ), "<>&\"" );
 213         my $long_desc = encode_entities( $env->{db}->get_long_desc( $d->{desc_md5},
 214                                                                     $lang ), "<>&\"" );
 215
 216         $long_desc =~ s,((ftp|http|https)://[\S~-]+?/?)((\&gt\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go; # syntax highlighting -> '];
 217         $long_desc =~ s/\A //o;
 218         $long_desc =~ s/\n /\n/sgo;
 219         $long_desc =~ s/\n.\n/\n<p>\n/go;
 220         $long_desc =~ s/(((\n|\A) [^\n]*)+)/\n<pre>$1\n<\/pre>/sgo;
 221
 222         $long_desc = conv_desc( $lang, $long_desc );
 223         $short_desc = conv_desc( $lang, $short_desc );
 224
 225         #
 226         # begin output
 227         #
 228         my $package_page = header( title => $name, lang => $lang,
 229                                    desc => $short_desc,
 230                                    keywords => "$env->{distribution}, $subsuite_kw, $d->{section}, $d->{subsection}, size:$size_kw $d->{version}" );
 231         $package_page .= simple_menu( [ gettext( "Distribution:" ),
 232                                         gettext( "Overview over this distribution" ),
 233                                         "../",
 234                                         $env->{distribution} ],
 235                                       [ gettext( "Section:" ),
 236                                         gettext( "All packages in this section" ),
 237                                         "../$d->{subsection}/",
 238                                         $d->{subsection} ],
 239                                       );
 240
 241         my $title .= sprintf( gettext( "Package: %s (%s)" ), $name, $d->{v_str_simple} );
 242         $title .=  " ".marker( $d->{subsuite} ) if $d->{subsuite};
 243         $title .=  " ".marker( $d->{section} ) if $d->{section} ne 'main';
 244         $package_page .= title( $title );
 245
 246         $package_page .= "<h2>".gettext( "Versions:" )." $d->{v_str_arch}</h2>\n"
 247             unless $d->{version} eq $d->{v_str_simple};
 248
 249         if ($env->{distribution} eq "experimental") {
 250             $package_page .= note( gettext( "Experimental package"),
 251                                    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>".
 252                                    gettext( "Users of experimental packages are encouraged to contact the package maintainers directly in case of problems." )
 253                                    );
 254         }
 255         if ($d->{section} eq "debian-installer") {
 256             $package_page .= note( gettext( "debian-installer udeb package"),
 257                                    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." )
 258                                    );
 259         }
 260         $package_page .= pdesc( $short_desc, $long_desc );
 261
 262         #
 263         # display dependencies
 264         #
 265         my $dep_list = print_deps( $env, $lang, $pkg, $d->{depends},    'depends' );
 266         $dep_list   .= print_deps( $env, $lang, $pkg, $d->{recommends}, 'recommends' );
 267         $dep_list   .= print_deps( $env, $lang, $pkg, $d->{suggests},   'suggests' );
 268
 269         if ( $dep_list ) {
 270             $package_page .= "<div id=\"pdeps\">\n";
 271             $package_page .= sprintf( "<h2>".gettext( "Other Packages Related to %s" )."</h2>\n", $name );
 272             if ($env->{distribution} eq "experimental") {
 273                 $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." ) );
 274             }
 275
 276             $package_page .= pdeplegend( [ 'dep',  gettext( 'depends' ) ],
 277                                          [ 'rec',  gettext( 'recommends' ) ],
 278                                          [ 'sug',  gettext( 'suggests' ) ], );
 279
 280             $package_page .= $dep_list;
 281             $package_page .= "</div> <!-- end pdeps -->\n";
 282         }
 283
 284         #
 285         # Download package
 286         #
 287         my $encodedpack = uri_escape( $name );
 288         $package_page .= "<div id=\"pdownload\">";
 289         $package_page .= sprintf( "<h2>".gettext( "Download %s\n" )."</h2>",
 290                                   $name ) ;
 291         $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";
 292         $package_page .= "<caption class=\"hidecss\">".gettext("Download for all available architectures")."</caption>\n";
 293         $package_page .= "<tr>\n";
 294         $package_page .= "<th>".gettext("Architecture")."</th><th>".gettext("Files")."</th><th>".gettext( "Package Size")."</th><th>".gettext("Installed Size")."</th></tr>\n";
 295         foreach my $a ( @all_archs ) {
 296             if ( exists $versions{a2v}{$a} ) {
 297                 $package_page .= "<tr>\n";
 298                 $package_page .=  "<th><a href=\"$DL_URL?arch=$a";
 299                 # \&amp\;file=\" method=\"post\">\n<p>";
 300                 $package_page .=  "&amp;file=".uri_escape($filenames{a2f}->{$a});
 301                 $package_page .=  "&amp;md5sum=$file_md5s{a2f}->{$a}";
 302                 $package_page .=  "&amp;arch=$a";
 303                 # there was at least one package with two
 304                 # different source packages on different
 305                 # archs where one had a security update
 306                 # and the other one not
 307                 if ($subsuites{a2f}{$a}
 308                     && ($subsuites{a2f}{$a} =~ /security/o) ) {
 309                     $package_page .=  "&amp;type=security";
 310                 } elsif ($subsuites{a2f}{$a}
 311                          && ($subsuites{a2f}{$a} =~ /volatile/o) ) {
 312                     $package_page .=  "&amp;type=volatile";
 313                 } elsif ($d->{is_nonus}) {
 314                     $package_page .=  "&amp;type=nonus";
 315                 } else {
 316                     $package_page .=  "&amp;type=main";
 317                 }
 318                 $package_page .=  "\">$a</a></th>\n";
 319                 $package_page .= "<td>";
 320                 if ( $env->{distribution} ne "experimental" ) {
 321                     $package_page .= sprintf( "[<a href=\"%s\">".gettext( "list of files" )."</a>]\n", "$FILELIST_URL$encodedpack&amp;version=$env->{distribution}&amp;arch=$a", $name );
 322                 } else {
 323                     $package_page .= "no files";
 324                 }
 325                 $package_page .= "</td>\n<td>";
 326                 my $size = $d->{sizes_deb}{$a};
 327                 $package_page .=  "$size";
 328                 $package_page .= "</td>\n<td>";
 329                 my $inst_size = $d->{sizes_inst}{$a};
 330                 $package_page .=  "$inst_size";
 331                 $package_page .= "</td>\n</tr>";
 332             }
 333         }
 334         $package_page .= "</table><p>".gettext ( "Size is measured in kBytes." )."</p>\n";
 335         $package_page .= "</div> <!-- end pdownload -->\n";
 336
 337         #
 338         # more information
 339         #
 340         $package_page .= pmoreinfo( name => $name, env => $env, data => $d,
 341                                     bugreports => 1, sourcedownload => 1,
 342                                     changesandcopy => 1, maintainers => 1,
 343                                     search => 1 );
 344
 345         #
 346         # Trailer
 347         #
 348         my @tr_langs = ();
 349         foreach my $l (@{$env->{langs}}) {
 350             next if $l eq $lang;
 351             push @tr_langs, $l if ( $l eq 'en' )
 352                 || $env->{db}->is_translated( $name, $d->{version},
 353                                               ${$versions{v2a}{$d->{version}}}[0],
 354                                               $l );
 355         }
 356         $package_page .= trailer( '../..', $name, $lang, @tr_langs );
 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