3 # show_package.pl -- CGI interface to show info about a package
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
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
16 use CGI qw( -oldstyle_urls );
17 use CGI::Carp qw( fatalsToBrowser );
27 use Packages::Search qw( :all );
28 use Packages::HTML ();
30 my $HOME = "http://www.debian.org";
32 my $SEARCHPAGE = "http://packages.debian.org/";
33 my @SUITES = qw( oldstable stable testing unstable experimental );
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;
46 $ENV{PATH} = "/bin:/usr/bin";
48 # Read in all the variables set by the form
50 if ($ARGV[0] eq 'php') {
51 $input = new CGI(\*STDIN);
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;
63 # If you want, just print out a list of all of the variables and exit.
64 print $input->header if $debug;
68 my %params_def = ( package => { default => undef, match => '^([a-z0-9.+-]+)$' },
69 suite => { default => undef, match => '^(\w+)$' },
70 #format => { default => 'html', match => '^(\w+)$' }
72 my %params = Packages::Search::parse_params( $input, \%params_def );
74 my $format = $params{values}{format}{final};
75 #XXX: Don't use alternative output formats yet
78 if ($format eq 'html') {
80 } elsif ($format eq 'xml') {
81 # print $input->header( -type=>'application/rdf+xml' );
82 print $input->header( -type=>'text/plain' );
85 if ($params{errors}{package}) {
86 print "Error: package not valid or not specified" if $format eq 'html';
89 if ($params{errors}{suite}) {
90 print "Error: package not valid or not specified" if $format eq 'html';
93 my $package = $params{values}{package}{final};
94 my $suite = $params{values}{suite}{final};
97 if ($format eq 'html') {
98 print Packages::HTML::header( title => "Details of package <i>$package</i> in $suite" ,
100 title_tag => "Details of package $package in $suite",
101 print_title_above => 1
105 # read the configuration
107 if (!open (C, "../config.sh")) {
108 print "\nInternal Error: Cannot open configuration file.\n\n"
109 if $format eq 'html';
113 $topdir = $1 if (/^\s*topdir="?(.*)"?\s*$/);
117 my $DBDIR = $topdir . "/files/db";
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: $!";
127 &read_entry( $package, \@results, \%allsuites );
129 if (keys %allsuites == 0) {
130 print "No such package";
131 print "{insert link to search page with substring search}";
135 # sort is gross -- only fails for experimental though
136 for (sort keys %allsuites) {
138 print "<strong>$_</strong> | ";
140 print "<a href=\"../$_/".uri_escape($package)."\">$_</a> | ";
144 if (not exists $allsuites{$suite}) {
145 print "Package not available in this suite";
149 for my $entry (@results) {
150 print join ":", @$entry;
152 my ($foo, $arch, $section, $subsection,
153 $priority, $version) = @$entry;
154 print "<pre>".$packages_all{"$package $arch $version"}."</pre>";
157 &showpackage($package);
162 my $name = $pkg->get_name;
164 if ( $pkg->is_virtual ) {
165 print_virt_pack( @_ );
169 my @all_archs = ( @{$env->{archs}}, 'all' );
171 my $page = new Packages::Page( $name,
172 { architectures => $env->{archs} } );
173 my $d = $page->set_data( $env->{db}, $pkg );
175 my %versions = $pkg->get_arch_versions( $env->{archs} );
176 my %subsuites = $pkg->get_arch_fields( 'subdistribution',
178 my %filenames = $pkg->get_arch_fields( 'filename',
180 my %file_md5s = $pkg->get_arch_fields( 'md5sum',
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});
187 foreach my $lang (@{$env->{langs}}) {
188 &Generated::Strings::string_lang($lang);
190 my $dirname = "$env->{dest_dir}/$d->{subsection}";
191 my $filename = "$dirname/$name.$lang.html";
193 unless (( $lang eq 'en' )
194 || $env->{db}->is_translated( $name, $d->{version},
195 ${$versions{v2a}{$d->{version}}}[0],
197 $files->delete_file( $filename )
198 if $files->file_exists( $filename );
201 progress() if $env->{opts}{progress};
204 # process description
206 my $short_desc = encode_entities( $env->{db}->get_short_desc( $d->{desc_md5},
208 my $long_desc = encode_entities( $env->{db}->get_long_desc( $d->{desc_md5},
211 $long_desc =~ s,((ftp|http|https)://[\S~-]+?/?)((\>\;)?[)]?[']?[:.\,]?(\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;
217 $long_desc = conv_desc( $lang, $long_desc );
218 $short_desc = conv_desc( $lang, $short_desc );
223 my $package_page = header( title => $name, lang => $lang,
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" ),
229 $env->{distribution} ],
230 [ gettext( "Section:" ),
231 gettext( "All packages in this section" ),
232 "../$d->{subsection}/",
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 );
241 $package_page .= "<h2>".gettext( "Versions:" )." $d->{v_str_arch}</h2>\n"
242 unless $d->{version} eq $d->{v_str_simple};
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." )
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." )
255 $package_page .= pdesc( $short_desc, $long_desc );
258 # display dependencies
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' );
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." ) );
271 $package_page .= pdeplegend( [ 'dep', gettext( 'depends' ) ],
272 [ 'rec', gettext( 'recommends' ) ],
273 [ 'sug', gettext( 'suggests' ) ], );
275 $package_page .= $dep_list;
276 $package_page .= "</div> <!-- end pdeps -->\n";
282 my $encodedpack = uri_escape( $name );
283 $package_page .= "<div id=\"pdownload\">";
284 $package_page .= sprintf( "<h2>".gettext( "Download %s\n" )."</h2>",
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 # \&\;file=\" method=\"post\">\n<p>";
295 $package_page .= "&file=".uri_escape($filenames{a2f}->{$a});
296 $package_page .= "&md5sum=$file_md5s{a2f}->{$a}";
297 $package_page .= "&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 .= "&type=security";
305 } elsif ($subsuites{a2f}{$a}
306 && ($subsuites{a2f}{$a} =~ /volatile/o) ) {
307 $package_page .= "&type=volatile";
308 } elsif ($d->{is_nonus}) {
309 $package_page .= "&type=nonus";
311 $package_page .= "&type=main";
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&version=$env->{distribution}&arch=$a", $name );
318 $package_page .= "no files";
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>";
329 $package_page .= "</table><p>".gettext ( "Size is measured in kBytes." )."</p>\n";
330 $package_page .= "</div> <!-- end pdownload -->\n";
335 $package_page .= pmoreinfo( name => $name, env => $env, data => $d,
336 bugreports => 1, sourcedownload => 1,
337 changesandcopy => 1, maintainers => 1,
344 foreach my $l (@{$env->{langs}}) {
346 push @tr_langs, $l if ( $l eq 'en' )
347 || $env->{db}->is_translated( $name, $d->{version},
348 ${$versions{v2a}{$d->{version}}}[0],
351 $package_page .= trailer( '../..', $name, $lang, @tr_langs );
356 $files->update_file( $filename, $package_page );
362 my $data_sheet = header( title => "$name -- Data sheet",
365 keywords => "$env->{distribution}, $subsuite_kw, $d->{section}, $d->{subsection}, size:$size_kw $d->{version}" );
367 my $ds_title = $name;
368 if ( $d->{subsuite} ) {
369 $ds_title .= " ".marker( $d->{subsuite} );
371 if ( $d->{section} ne 'main' ) {
372 $ds_title .= " ".marker( $d->{section} );
374 $data_sheet .= title( $ds_title );
376 $data_sheet .= ds_begin;
377 $data_sheet .= ds_item(gettext( "Version" ), $d->{v_str_arch});
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>" );
387 foreach (@uploaders) {
388 push @uploaders_str, "<a href=\"$DDPO_URL".uri_escape($_->[1])."\">".encode_entities($_->[0], '&<>')."</a>";
390 $data_sheet .= ds_item(gettext( "Uploaders" ),
391 join( ",\n ", @uploaders_str ));
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' );
419 # if ( $name eq 'libc6' ) {
421 # print STDERR Dumper( $pkg );
424 $data_sheet .= ds_end;
426 $data_sheet .= trailer( '../..', $name );
428 my $ds_filename = "$dirname/ds_$name.$lang.html";
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];
449 $allsuites->{$data[0]} = 1;
453 # TODO: move to common lib:
459 <p style="text-align:right;font-size:small;font-stlye:italic"><a href="$SEARCHPAGE">Packages search page</a></p>
464 my $pete = new Benchmark;
465 my $petd = timediff($pete, $pet0);
466 print "Total page evaluation took ".timestr($petd)."<br>"
469 print $input->end_html;