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
17 use CGI qw( -oldstyle_urls );
18 use CGI::Carp qw( fatalsToBrowser );
26 use Packages::Config qw( $DBDIR $ROOT @SUITES @ARCHIVES @SECTIONS
27 @ARCHITECTURES %FTP_SITES );
30 use Packages::Search qw( :all );
32 use Packages::Page ();
33 use Packages::SrcPage ();
35 &Packages::CGI::reset;
37 $ENV{PATH} = "/bin:/usr/bin";
39 # Read in all the variables set by the form
41 if ($ARGV[0] && ($ARGV[0] eq 'php')) {
42 $input = new CGI(\*STDIN);
47 my $pet0 = new Benchmark;
48 my $tet0 = new Benchmark;
49 # use this to disable debugging in production mode completly
50 my $debug_allowed = 1;
51 my $debug = $debug_allowed && $input->param("debug");
52 $debug = 0 if !defined($debug) || $debug !~ /^\d+$/o;
53 $Packages::CGI::debug = $debug;
55 &Packages::Config::init( '../' );
56 &Packages::DB::init();
58 if (my $path = $input->param('path')) {
59 my @components = map { lc $_ } split /\//, $path;
61 my %SUITES = map { $_ => 1 } @SUITES;
62 my %SECTIONS = map { $_ => 1 } @SECTIONS;
63 my %ARCHIVES = map { $_ => 1 } @ARCHIVES;
64 my %ARCHITECTURES = map { $_ => 1 } @ARCHITECTURES;
66 foreach (@components) {
68 $input->param('suite', $_);
69 } elsif ($SECTIONS{$_}) {
70 $input->param('section', $_);
71 } elsif ($ARCHIVES{$_}) {
72 $input->param('archive', $_);
73 } elsif ($ARCHITECTURES{$_}) {
74 $input->param('arch', $_);
75 } elsif ($_ eq 'source') {
76 $input->param('source', 1);
81 my ( $pkg, $suite, @sections, @archs, @archives, $format );
82 my %params_def = ( package => { default => undef, match => '^([a-z0-9.+-]+)$',
84 suite => { default => undef, match => '^(\w+)$',
86 archive => { default => 'all', match => '^(\w+)$',
87 array => ',', var => \@archives,
88 replace => { all => [qw(us security non-US)] } },
89 section => { default => 'all', match => '^(\w+)$',
90 array => ',', var => \@sections,
91 replace => { all => \@SECTIONS } },
92 arch => { default => 'any', match => '^(\w+)$',
93 array => ',', var => \@archs,
94 replace => { any => \@ARCHITECTURES } },
95 format => { default => 'html', match => '^(\w+)$',
97 source => { default => 0, match => '^(\d+)$' },
100 my %params = Packages::Search::parse_params( $input, \%params_def, \%opts );
102 #XXX: Don't use alternative output formats yet
104 if ($format eq 'html') {
105 print $input->header( -charset => 'utf-8' );
108 if ($params{errors}{package}) {
109 fatal_error( "package not valid or not specified" );
112 if ($params{errors}{suite}) {
113 fatal_error( "suite not valid or not specified" );
117 $opts{h_suites} = { $suite => 1 };
118 $opts{h_archs} = { map { $_ => 1 } @archs };
119 $opts{h_sections} = { map { $_ => 1 } @sections };
120 $opts{h_archives} = { map { $_ => 1 } @archives };
122 my $DL_URL = "$pkg/download";
123 my $FILELIST_URL = "$pkg/files";
125 our (%packages_all, %sources_all);
126 my (@results, @non_results);
127 my $page = $opts{source} ?
128 new Packages::SrcPage( $pkg ) :
129 new Packages::Page( $pkg );
130 my $package_page = "";
131 my ($short_desc, $version, $archive, $section, $subsection) = ("")x5;
133 sub gettext { return $_[0]; };
135 my $st0 = new Benchmark;
136 unless (@Packages::CGI::fatal_errors) {
137 tie %packages_all, 'DB_File', "$DBDIR/packages_all_$suite.db",
138 O_RDONLY, 0666, $DB_BTREE
139 or die "couldn't tie DB $DBDIR/packages_all_$suite.db: $!";
140 tie %sources_all, 'DB_File', "$DBDIR/sources_all_$suite.db",
141 O_RDONLY, 0666, $DB_BTREE
142 or die "couldn't tie DB $DBDIR/sources_all_$suite.db: $!";
144 unless ($opts{source}) {
145 read_entry_all( \%packages, $pkg, \@results, \@non_results, \%opts );
147 unless (@results || @non_results ) {
148 fatal_error( "No such package".
149 "{insert link to search page with substring search}" );
152 fatal_error( "Package not available in this suite" );
154 for my $entry (@results) {
155 debug( join(":", @$entry), 1 );
156 my (undef, $archive, undef, $arch, $section, $subsection,
157 $priority, $version, $provided_by) = @$entry;
159 if ($arch ne 'virtual') {
160 my %data = split /\000/, $packages_all{"$pkg $arch $version"};
161 $data{package} = $pkg;
162 $data{architecture} = $arch;
163 $data{version} = $version;
164 $page->merge_package(\%data) or debug( "Merging $pkg $arch $version FAILED", 2 );
166 $page->add_provided_by([split /\s+/, $provided_by]);
170 unless ($page->is_virtual()) {
171 $version = $page->{newest};
172 my $source = $page->get_newest( 'source' );
173 $archive = $page->get_newest( 'archive' );
174 debug( "find source package: source=$source", 1);
175 my $src_data = $sources_all{"$archive $suite $source"};
176 $page->add_src_data( $source, $src_data )
179 my $st1 = new Benchmark;
180 my $std = timediff($st1, $st0);
181 debug( "Data search and merging took ".timestr($std) );
183 my $encodedpkg = uri_escape( $pkg );
184 my ($v_str, $v_str_arch, $v_str_arr) = $page->get_version_string();
185 my $did = $page->get_newest( 'description' );
186 $section = $page->get_newest( 'section' );
187 $subsection = $page->get_newest( 'subsection' );
188 my $filenames = $page->get_arch_field( 'filename' );
189 my $file_md5sums = $page->get_arch_field( 'md5sum' );
190 my $archives = $page->get_arch_field( 'archive' );
191 my $sizes_inst = $page->get_arch_field( 'installed-size' );
192 my $sizes_deb = $page->get_arch_field( 'size' );
193 my @archs = sort $page->get_architectures;
195 # process description
197 my $desc = $descriptions{$did};
198 $short_desc = encode_entities( $1, "<>&\"" )
199 if $desc =~ s/^(.*)$//m;
200 my $long_desc = encode_entities( $desc, "<>&\"" );
202 $long_desc =~ s,((ftp|http|https)://[\S~-]+?/?)((\>\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go; # syntax highlighting -> '];
203 $long_desc =~ s/\A //o;
204 $long_desc =~ s/\n /\n/sgo;
205 $long_desc =~ s/\n.\n/\n<p>\n/go;
206 $long_desc =~ s/(((\n|\A) [^\n]*)+)/\n<pre>$1\n<\/pre>/sgo;
207 # $long_desc = conv_desc( $lang, $long_desc );
208 # $short_desc = conv_desc( $lang, $short_desc );
211 foreach (@results, @non_results) {
214 if ($a =~ /^(?:us|security|non-US)$/o) {
217 $all_suites{"$s/$a"}++;
220 foreach (suites_sort(keys %all_suites)) {
221 if (("$suite/$archive" eq $_)
222 || (!$all_suites{"$suite/$archive"} && ($suite eq $_))) {
223 $package_page .= "[ <strong>$_</strong> ] ";
226 "[ <a href=\"$ROOT/$_/".uri_escape($pkg)."\">$_</a> ] ";
229 $package_page .= '<br>';
231 $package_page .= simple_menu( [ gettext( "Distribution:" ),
232 gettext( "Overview over this suite" ),
235 [ gettext( "Section:" ),
236 gettext( "All packages in this section" ),
237 "$ROOT/$suite/$subsection/",
241 my $title .= sprintf( gettext( "Package: %s (%s)" ), $pkg, $v_str );
242 $title .= " ".marker( $archive ) if $archive ne 'us';
243 $title .= " ".marker( $subsection ) if $subsection eq 'non-US'
244 and $archive ne 'non-US'; # non-US/security
245 $title .= " ".marker( $section ) if $section ne 'main';
246 $package_page .= title( $title );
248 $package_page .= "<h2>".gettext( "Versions:" )." $v_str_arch</h2>\n"
249 unless $version eq $v_str;
250 if (my $provided_by = $page->{provided_by}) {
251 note( gettext( "This is also a virtual package provided by ").join( ', ', map { "<a href=\"$ROOT/$suite/$_\">$_</a>" } @$provided_by) );
254 if ($suite eq "experimental") {
255 note( gettext( "Experimental package"),
256 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>".
257 gettext( "Users of experimental packages are encouraged to contact the package maintainers directly in case of problems." )
260 if ($subsection eq "debian-installer") {
261 note( gettext( "debian-installer udeb package"),
262 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." )
265 $package_page .= pdesc( $short_desc, $long_desc );
268 # display dependencies
271 $dep_list = print_deps( \%packages, \%opts, $pkg,
272 $page->get_dep_field('depends'),
274 $dep_list .= print_deps( \%packages, \%opts, $pkg,
275 $page->get_dep_field('recommends'),
277 $dep_list .= print_deps( \%packages, \%opts, $pkg,
278 $page->get_dep_field('suggests'),
282 $package_page .= "<div id=\"pdeps\">\n";
283 $package_page .= sprintf( "<h2>".gettext( "Other Packages Related to %s" )."</h2>\n", $pkg );
284 if ($suite eq "experimental") {
285 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." ) );
288 $package_page .= pdeplegend( [ 'dep', gettext( 'depends' ) ],
289 [ 'rec', gettext( 'recommends' ) ],
290 [ 'sug', gettext( 'suggests' ) ], );
292 $package_page .= $dep_list;
293 $package_page .= "</div> <!-- end pdeps -->\n";
299 my $encodedpack = uri_escape( $pkg );
300 $package_page .= "<div id=\"pdownload\">";
301 $package_page .= sprintf( "<h2>".gettext( "Download %s\n" )."</h2>",
303 $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";
304 $package_page .= "<caption class=\"hidecss\">".gettext("Download for all available architectures")."</caption>\n";
305 $package_page .= "<tr>\n";
306 $package_page .= "<th>".gettext("Architecture")."</th><th>".gettext("Files")."</th><th>".gettext( "Package Size")."</th><th>".gettext("Installed Size")."</th></tr>\n";
307 foreach my $a ( @archs ) {
308 $package_page .= "<tr>\n";
309 $package_page .= "<th><a href=\"$ROOT/$suite/$encodedpkg/$a/download";
310 $package_page .= "\">$a</a></th>\n";
311 $package_page .= "<td>";
312 if ( $suite ne "experimental" ) {
313 $package_page .= sprintf( "[<a href=\"%s\">".gettext( "list of files" )."</a>]\n",
314 "$ROOT/$suite/$encodedpkg/$a/filelist", $pkg );
316 $package_page .= gettext( "no current information" );
318 $package_page .= "</td>\n<td align=right>"; #FIXME: css
319 $package_page .= floor(($sizes_deb->{$a}/102.4)+0.5)/10 . " kB";
320 $package_page .= "</td>\n<td align=right>"; #FIXME: css
321 $package_page .= $sizes_inst->{$a} . " kB";
322 $package_page .= "</td>\n</tr>";
324 $package_page .= "</table>\n";
325 $package_page .= "</div> <!-- end pdownload -->\n";
330 $package_page .= pmoreinfo( name => $pkg, data => $page,
333 bugreports => 1, sourcedownload => 1,
334 changesandcopy => 1, maintainers => 1,
336 } else { # unless $page->is_virtual
337 $short_desc = gettext( "virtual package" );
340 foreach (@results, @non_results) {
343 if ($a =~ /^(?:us|security|non-US)$/o) {
346 $all_suites{"$s/$a"}++;
349 foreach (suites_sort(keys %all_suites)) {
350 if (("$suite/$archive" eq $_)
351 || (!$all_suites{"$suite/$archive"} && ($suite eq $_))) {
352 $package_page .= "[ <strong>$_</strong> ] ";
355 "[ <a href=\"$ROOT/$_/".uri_escape($pkg)."\">$_</a> ] ";
358 $package_page .= '<br>';
359 $package_page .= simple_menu( [ gettext( "Distribution:" ),
360 gettext( "Overview over this distribution" ),
363 [ gettext( "Section:" ),
364 gettext( "All packages in this section" ),
365 "$ROOT/$suite/virtual/",
369 $package_page .= title( sprintf( gettext( "Virtual Package: %s" ),
372 my $policy_url = 'http://www.debian.org/doc/debian-policy/';
373 note( sprintf( gettext( "This is a <em>virtual package</em>. See the <a href=\"%s\">Debian policy</a> for a <a href=\"%sch-binary.html#s-virtual_pkg\">definition of virtual packages</a>." ),
374 $policy_url, $policy_url ));
376 $package_page .= sprintf( "<h2>".gettext( "Packages providing %s" )."</h2>", $pkg );
377 my $provided_by = $page->{provided_by};
378 $package_page .= pkg_list( \%packages, \%opts, $provided_by, 'en');
380 } # else (unless $page->is_virtual)
381 } # else (unless @results)
382 } # else (unless (@results || @non_results ))
384 read_src_entry_all( \%sources, $pkg, \@results, \@non_results, \%opts );
386 unless (@results || @non_results ) {
387 fatal_error( "No such package".
388 "{insert link to search page with substring search}" );
391 fatal_error( "Package not available in this suite" );
393 for my $entry (@results) {
394 debug( join(":", @$entry), 1 );
395 my (undef, $archive, undef, $section, $subsection,
396 $priority, $version) = @$entry;
398 my $data = $sources_all{"$archive $suite $pkg"};
399 $page->merge_data($pkg, $suite, $archive, $data) or debug( "Merging $pkg $version FAILED", 2 );
401 $version = $page->{version};
403 my $st1 = new Benchmark;
404 my $std = timediff($st1, $st0);
405 debug( "Data search and merging took ".timestr($std) );
407 my $encodedpkg = uri_escape( $pkg );
408 my ($v_str, $v_str_arr) = $page->get_version_string();
409 $archive = $page->get_newest( 'archive' );
410 $section = $page->get_newest( 'section' );
411 $subsection = $page->get_newest( 'subsection' );
414 foreach (@results, @non_results) {
417 if ($a =~ /^(?:us|security|non-US)$/o) {
420 $all_suites{"$s/$a"}++;
423 foreach (suites_sort(keys %all_suites)) {
424 if (("$suite/$archive" eq $_)
425 || (!$all_suites{"$suite/$archive"} && ($suite eq $_))) {
426 $package_page .= "[ <strong>$_</strong> ] ";
429 "[ <a href=\"$ROOT/$_/source/".uri_escape($pkg)."\">$_</a> ] ";
432 $package_page .= '<br>';
434 $package_page .= simple_menu( [ gettext( "Distribution:" ),
435 gettext( "Overview over this suite" ),
438 [ gettext( "Section:" ),
439 gettext( "All packages in this section" ),
440 "/$suite/$subsection/",
444 my $title .= sprintf( gettext( "Source Package: %s (%s)" ),
446 $title .= " ".marker( $archive ) if $archive ne 'us';
447 $title .= " ".marker( $subsection ) if $subsection eq 'non-US'
448 and $archive ne 'non-US'; # non-US/security
449 $title .= " ".marker( $section ) if $section ne 'main';
450 $package_page .= title( $title );
452 if ($suite eq "experimental") {
453 $package_page .= note( gettext( "Experimental package"),
454 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>".
455 gettext( "Users of experimental packages are encouraged to contact the package maintainers directly in case of problems." )
458 if ($subsection eq "debian-installer") {
459 note( gettext( "debian-installer udeb package"),
460 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." )
464 my $binaries = find_binaries( $pkg, $archive, $suite, \%src2bin );
465 if ($binaries && @$binaries) {
466 $package_page .= '<div class="pdesc">';
467 $package_page .= gettext( "The following binary packages are built from this source package:" );
468 $package_page .= pkg_list( \%packages, \%opts, $binaries, 'en' );
469 $package_page .= '</div> <!-- end pdesc -->';
473 # display dependencies
476 $dep_list = print_src_deps( \%packages, \%opts, $pkg,
477 $page->get_dep_field('build-depends'),
479 $dep_list .= print_src_deps( \%packages, \%opts, $pkg,
480 $page->get_dep_field('build-depends-indep'),
481 'build-depends-indep' );
484 $package_page .= "<div id=\"pdeps\">\n";
485 $package_page .= sprintf( "<h2>".gettext( "Other Packages Related to %s" )."</h2>\n", $pkg );
486 if ($suite eq "experimental") {
487 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." ) );
490 $package_page .= pdeplegend( [ 'adep', gettext( 'build-depends' ) ],
491 [ 'idep', gettext( 'build-depends-indep' ) ],
494 $package_page .= $dep_list;
495 $package_page .= "</div> <!-- end pdeps -->\n";
499 # Source package download
501 $package_page .= "<div id=\"pdownload\">\n";
502 my $encodedpack = uri_escape( $pkg );
503 $package_page .= sprintf( "<h2>".gettext( "Download %s" )."</h2>\n",
506 my $source_files = $page->get_src( 'files' );
507 my $source_dir = $page->get_src( 'directory' );
509 $package_page .= sprintf( "<table cellspacing=\"0\" cellpadding=\"2\" summary=\"Download information for the files of this source package\">\n"
510 ."<tr><th>%s</th><th>%s</th><th>%s</th>",
512 gettext("Size (in kB)"),
514 foreach( @$source_files ) {
515 my ($src_file_md5, $src_file_size, $src_file_name)
520 $src_url = $FTP_SITES{security}; last };
522 $src_url = $FTP_SITES{volatile}; last };
524 $src_url = $FTP_SITES{backports}; last };
526 $src_url = $FTP_SITES{'non-US'}; last };
527 $src_url = $FTP_SITES{us};
529 $src_url .= "/$source_dir/$src_file_name";
531 $package_page .= "<tr><td><a href=\"$src_url\">$src_file_name</a></td>\n"
532 ."<td class=\"dotalign\">".sprintf("%.1f", (floor(($src_file_size/102.4)+0.5)/10))."</td>\n"
533 ."<td>$src_file_md5</td></tr>";
535 $package_page .= "</table>\n";
536 $package_page .= "</div> <!-- end pdownload -->\n";
541 $package_page .= pmoreinfo( name => $pkg, data => $page,
545 changesandcopy => 1, maintainers => 1,
546 search => 1, is_source => 1 );
553 debug( "Final page object:\n".Dumper($page), 3 );
555 my $title = $opts{source} ?
556 "Details of source package <em>$pkg</em> in $suite" :
557 "Details of package <em>$pkg</em> in $suite" ;
558 my $title_tag = $opts{source} ?
559 "Details of source package $pkg in $suite" :
560 "Details of package $pkg in $suite" ;
561 print Packages::HTML::header( title => $title ,
564 keywords => "$suite, $archive, $section, $subsection, $version",
565 title_tag => "Details of package $pkg in $suite",
574 unless (@Packages::CGI::fatal_errors) {
577 my $tet1 = new Benchmark;
578 my $tetd = timediff($tet1, $tet0);
579 print "Total page evaluation took ".timestr($tetd)."<br>"
582 my $trailer = Packages::HTML::trailer( $ROOT );
583 $trailer =~ s/LAST_MODIFIED_DATE/gmtime()/e; #FIXME