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;
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) = @$entry;
159 my %data = split /\000/, $packages_all{"$pkg $arch $version"};
160 $data{package} = $pkg;
161 $data{architecture} = $arch;
162 $data{version} = $version;
163 $page->merge_package(\%data) or debug( "Merging $pkg $arch $version FAILED", 2 );
166 $version = $page->{newest};
167 my $source = $page->get_newest( 'source' );
168 $archive = $page->get_newest( 'archive' );
169 debug( "find source package: source=$source", 1);
170 my $src_data = $sources_all{"$archive $suite $source"};
171 $page->add_src_data( $source, $src_data )
174 my $st1 = new Benchmark;
175 my $std = timediff($st1, $st0);
176 debug( "Data search and merging took ".timestr($std) );
178 my $encodedpkg = uri_escape( $pkg );
179 my ($v_str, $v_str_arch, $v_str_arr) = $page->get_version_string();
180 my $did = $page->get_newest( 'description' );
181 $section = $page->get_newest( 'section' );
182 $subsection = $page->get_newest( 'subsection' );
183 my $filenames = $page->get_arch_field( 'filename' );
184 my $file_md5sums = $page->get_arch_field( 'md5sum' );
185 my $archives = $page->get_arch_field( 'archive' );
186 my $sizes_inst = $page->get_arch_field( 'installed-size' );
187 my $sizes_deb = $page->get_arch_field( 'size' );
188 my @archs = sort $page->get_architectures;
190 # process description
192 my $desc = $descriptions{$did};
193 $short_desc = encode_entities( $1, "<>&\"" )
194 if $desc =~ s/^(.*)$//m;
195 my $long_desc = encode_entities( $desc, "<>&\"" );
197 $long_desc =~ s,((ftp|http|https)://[\S~-]+?/?)((\>\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go; # syntax highlighting -> '];
198 $long_desc =~ s/\A //o;
199 $long_desc =~ s/\n /\n/sgo;
200 $long_desc =~ s/\n.\n/\n<p>\n/go;
201 $long_desc =~ s/(((\n|\A) [^\n]*)+)/\n<pre>$1\n<\/pre>/sgo;
202 # $long_desc = conv_desc( $lang, $long_desc );
203 # $short_desc = conv_desc( $lang, $short_desc );
206 foreach (@results, @non_results) {
209 if ($a =~ /^(?:us|security|non-US)$/o) {
212 $all_suites{"$s/$a"}++;
215 foreach (suites_sort(keys %all_suites)) {
216 if (("$suite/$archive" eq $_)
217 || (!$all_suites{"$suite/$archive"} && ($suite eq $_))) {
218 $package_page .= "[ <strong>$_</strong> ] ";
221 "[ <a href=\"$ROOT/$_/".uri_escape($pkg)."\">$_</a> ] ";
224 $package_page .= '<br>';
226 $package_page .= simple_menu( [ gettext( "Distribution:" ),
227 gettext( "Overview over this suite" ),
230 [ gettext( "Section:" ),
231 gettext( "All packages in this section" ),
232 "$ROOT/$suite/$subsection/",
236 my $title .= sprintf( gettext( "Package: %s (%s)" ), $pkg, $v_str );
237 $title .= " ".marker( $archive ) if $archive ne 'us';
238 $title .= " ".marker( $subsection ) if $subsection eq 'non-US'
239 and $archive ne 'non-US'; # non-US/security
240 $title .= " ".marker( $section ) if $section ne 'main';
241 $package_page .= title( $title );
243 $package_page .= "<h2>".gettext( "Versions:" )." $v_str_arch</h2>\n"
244 unless $version eq $v_str;
246 if ($suite eq "experimental") {
247 $package_page .= note( gettext( "Experimental package"),
248 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>".
249 gettext( "Users of experimental packages are encouraged to contact the package maintainers directly in case of problems." )
252 if ($subsection eq "debian-installer") {
253 note( gettext( "debian-installer udeb package"),
254 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." )
257 $package_page .= pdesc( $short_desc, $long_desc );
260 # display dependencies
263 $dep_list = print_deps( \%packages, \%opts, $pkg,
264 $page->get_dep_field('depends'),
266 $dep_list .= print_deps( \%packages, \%opts, $pkg,
267 $page->get_dep_field('recommends'),
269 $dep_list .= print_deps( \%packages, \%opts, $pkg,
270 $page->get_dep_field('suggests'),
274 $package_page .= "<div id=\"pdeps\">\n";
275 $package_page .= sprintf( "<h2>".gettext( "Other Packages Related to %s" )."</h2>\n", $pkg );
276 if ($suite eq "experimental") {
277 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." ) );
280 $package_page .= pdeplegend( [ 'dep', gettext( 'depends' ) ],
281 [ 'rec', gettext( 'recommends' ) ],
282 [ 'sug', gettext( 'suggests' ) ], );
284 $package_page .= $dep_list;
285 $package_page .= "</div> <!-- end pdeps -->\n";
291 my $encodedpack = uri_escape( $pkg );
292 $package_page .= "<div id=\"pdownload\">";
293 $package_page .= sprintf( "<h2>".gettext( "Download %s\n" )."</h2>",
295 $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";
296 $package_page .= "<caption class=\"hidecss\">".gettext("Download for all available architectures")."</caption>\n";
297 $package_page .= "<tr>\n";
298 $package_page .= "<th>".gettext("Architecture")."</th><th>".gettext("Files")."</th><th>".gettext( "Package Size")."</th><th>".gettext("Installed Size")."</th></tr>\n";
299 foreach my $a ( @archs ) {
300 $package_page .= "<tr>\n";
301 $package_page .= "<th><a href=\"$ROOT/$suite/$encodedpkg/$a/download";
302 $package_page .= "\">$a</a></th>\n";
303 $package_page .= "<td>";
304 if ( $suite ne "experimental" ) {
305 $package_page .= sprintf( "[<a href=\"%s\">".gettext( "list of files" )."</a>]\n",
306 "$ROOT/$suite/$encodedpkg/$a/filelist", $pkg );
308 $package_page .= gettext( "no current information" );
310 $package_page .= "</td>\n<td align=right>"; #FIXME: css
311 $package_page .= floor(($sizes_deb->{$a}/102.4)+0.5)/10 . " kB";
312 $package_page .= "</td>\n<td align=right>"; #FIXME: css
313 $package_page .= $sizes_inst->{$a} . " kB";
314 $package_page .= "</td>\n</tr>";
316 $package_page .= "</table>\n";
317 $package_page .= "</div> <!-- end pdownload -->\n";
322 $package_page .= pmoreinfo( name => $pkg, data => $page,
325 bugreports => 1, sourcedownload => 1,
326 changesandcopy => 1, maintainers => 1,
331 read_src_entry_all( \%sources, $pkg, \@results, \@non_results, \%opts );
333 unless (@results || @non_results ) {
334 fatal_error( "No such package".
335 "{insert link to search page with substring search}" );
338 fatal_error( "Package not available in this suite" );
340 for my $entry (@results) {
341 debug( join(":", @$entry), 1 );
342 my (undef, $archive, undef, $section, $subsection,
343 $priority, $version) = @$entry;
345 my $data = $sources_all{"$archive $suite $pkg"};
346 $page->merge_data($pkg, $suite, $archive, $data) or debug( "Merging $pkg $version FAILED", 2 );
348 $version = $page->{version};
350 my $st1 = new Benchmark;
351 my $std = timediff($st1, $st0);
352 debug( "Data search and merging took ".timestr($std) );
354 my $encodedpkg = uri_escape( $pkg );
355 my ($v_str, $v_str_arr) = $page->get_version_string();
356 $archive = $page->get_newest( 'archive' );
357 $section = $page->get_newest( 'section' );
358 $subsection = $page->get_newest( 'subsection' );
361 foreach (@results, @non_results) {
364 if ($a =~ /^(?:us|security|non-US)$/o) {
367 $all_suites{"$s/$a"}++;
370 foreach (suites_sort(keys %all_suites)) {
371 if (("$suite/$archive" eq $_)
372 || (!$all_suites{"$suite/$archive"} && ($suite eq $_))) {
373 $package_page .= "[ <strong>$_</strong> ] ";
376 "[ <a href=\"$ROOT/$_/source/".uri_escape($pkg)."\">$_</a> ] ";
379 $package_page .= '<br>';
381 $package_page .= simple_menu( [ gettext( "Distribution:" ),
382 gettext( "Overview over this suite" ),
385 [ gettext( "Section:" ),
386 gettext( "All packages in this section" ),
387 "/$suite/$subsection/",
391 my $title .= sprintf( gettext( "Source Package: %s (%s)" ),
393 $title .= " ".marker( $archive ) if $archive ne 'us';
394 $title .= " ".marker( $subsection ) if $subsection eq 'non-US'
395 and $archive ne 'non-US'; # non-US/security
396 $title .= " ".marker( $section ) if $section ne 'main';
397 $package_page .= title( $title );
399 if ($suite eq "experimental") {
400 $package_page .= note( gettext( "Experimental package"),
401 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>".
402 gettext( "Users of experimental packages are encouraged to contact the package maintainers directly in case of problems." )
405 if ($subsection eq "debian-installer") {
406 note( gettext( "debian-installer udeb package"),
407 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." )
411 my $binaries = find_binaries( $pkg, $archive, $suite, \%src2bin );
412 if ($binaries && @$binaries) {
413 $package_page .= '<div class="pdesc">';
414 $package_page .= gettext( "The following binary packages are built from this source package:" );
415 $package_page .= pkg_list( \%packages, \%opts, $binaries, 'en' );
416 $package_page .= '</div> <!-- end pdesc -->';
420 # display dependencies
423 $dep_list = print_src_deps( \%packages, \%opts, $pkg,
424 $page->get_dep_field('build-depends'),
426 $dep_list .= print_src_deps( \%packages, \%opts, $pkg,
427 $page->get_dep_field('build-depends-indep'),
428 'build-depends-indep' );
431 $package_page .= "<div id=\"pdeps\">\n";
432 $package_page .= sprintf( "<h2>".gettext( "Other Packages Related to %s" )."</h2>\n", $pkg );
433 if ($suite eq "experimental") {
434 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." ) );
437 $package_page .= pdeplegend( [ 'adep', gettext( 'build-depends' ) ],
438 [ 'idep', gettext( 'build-depends-indep' ) ],
441 $package_page .= $dep_list;
442 $package_page .= "</div> <!-- end pdeps -->\n";
446 # Source package download
448 $package_page .= "<div id=\"pdownload\">\n";
449 my $encodedpack = uri_escape( $pkg );
450 $package_page .= sprintf( "<h2>".gettext( "Download %s" )."</h2>\n",
453 my $source_files = $page->get_src( 'files' );
454 my $source_dir = $page->get_src( 'directory' );
456 $package_page .= sprintf( "<table cellspacing=\"0\" cellpadding=\"2\" summary=\"Download information for the files of this source package\">\n"
457 ."<tr><th>%s</th><th>%s</th><th>%s</th>",
459 gettext("Size (in kB)"),
461 foreach( @$source_files ) {
462 my ($src_file_md5, $src_file_size, $src_file_name)
467 $src_url = $FTP_SITES{security}; last };
469 $src_url = $FTP_SITES{volatile}; last };
471 $src_url = $FTP_SITES{backports}; last };
473 $src_url = $FTP_SITES{'non-US'}; last };
474 $src_url = $FTP_SITES{us};
476 $src_url .= "/$source_dir/$src_file_name";
478 $package_page .= "<tr><td><a href=\"$src_url\">$src_file_name</a></td>\n"
479 ."<td class=\"dotalign\">".sprintf("%.1f", (floor(($src_file_size/102.4)+0.5)/10))."</td>\n"
480 ."<td>$src_file_md5</td></tr>";
482 $package_page .= "</table>\n";
483 $package_page .= "</div> <!-- end pdownload -->\n";
488 $package_page .= pmoreinfo( name => $pkg, data => $page,
492 changesandcopy => 1, maintainers => 1,
493 search => 1, is_source => 1 );
500 debug( "Final page object:\n".Dumper($page), 3 );
502 my $title = $opts{source} ?
503 "Details of source package <em>$pkg</em> in $suite" :
504 "Details of package <em>$pkg</em> in $suite" ;
505 my $title_tag = $opts{source} ?
506 "Details of source package $pkg in $suite" :
507 "Details of package $pkg in $suite" ;
508 print Packages::HTML::header( title => $title ,
511 keywords => "$suite, $archive, $section, $subsection, $version",
512 title_tag => "Details of package $pkg in $suite",
521 unless (@Packages::CGI::fatal_errors) {
524 my $tet1 = new Benchmark;
525 my $tetd = timediff($tet1, $tet0);
526 print "Total page evaluation took ".timestr($tetd)."<br>"
529 my $trailer = Packages::HTML::trailer( $ROOT );
530 $trailer =~ s/LAST_MODIFIED_DATE/gmtime()/e; #FIXME