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 "/$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=\"$DL_URL?arch=$a";
302 $package_page .= "&file=".uri_escape($filenames->{$a});
303 $package_page .= "&md5sum=$file_md5sums->{$a}";
304 $package_page .= "&arch=$a";
305 for ($archives->{$a}) {
307 $package_page .= "&type=security"; last };
309 $package_page .= "&type=volatile"; last };
311 $package_page .= "&type=backports"; last };
313 $package_page .= "&type=nonus"; last };
314 $package_page .= "&type=main";
316 $package_page .= "\">$a</a></th>\n";
317 $package_page .= "<td>";
318 if ( $suite ne "experimental" ) {
319 $package_page .= sprintf( "[<a href=\"%s\">".gettext( "list of files" )."</a>]\n", "$FILELIST_URL$encodedpkg&version=$suite&arch=$a", $pkg );
321 $package_page .= gettext( "no current information" );
323 $package_page .= "</td>\n<td>";
324 $package_page .= floor(($sizes_deb->{$a}/102.4)+0.5)/10;
325 $package_page .= "</td>\n<td>";
326 $package_page .= $sizes_inst->{$a};
327 $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 => $pkg, data => $page,
338 bugreports => 1, sourcedownload => 1,
339 changesandcopy => 1, maintainers => 1,
344 read_src_entry_all( \%sources, $pkg, \@results, \@non_results, \%opts );
346 unless (@results || @non_results ) {
347 fatal_error( "No such package".
348 "{insert link to search page with substring search}" );
351 fatal_error( "Package not available in this suite" );
353 for my $entry (@results) {
354 debug( join(":", @$entry), 1 );
355 my (undef, $archive, undef, $section, $subsection,
356 $priority, $version) = @$entry;
358 my $data = $sources_all{"$pkg $version"};
359 $page->merge_data($pkg, $version, $data) or debug( "Merging $pkg $version FAILED", 2 );
361 $version = $page->{version};
363 my $st1 = new Benchmark;
364 my $std = timediff($st1, $st0);
365 debug( "Data search and merging took ".timestr($std) );
367 my $encodedpkg = uri_escape( $pkg );
368 my ($v_str, $v_str_arr) = $page->get_version_string();
369 $archive = $page->get_newest( 'archive' );
370 $section = $page->get_newest( 'section' );
371 $subsection = $page->get_newest( 'subsection' );
374 foreach (@results, @non_results) {
377 if ($a =~ /^(?:us|security|non-US)$/o) {
380 $all_suites{"$s/$a"}++;
383 foreach (suites_sort(keys %all_suites)) {
384 if (("$suite/$archive" eq $_)
385 || (!$all_suites{"$suite/$archive"} && ($suite eq $_))) {
386 $package_page .= "[ <strong>$_</strong> ] ";
389 "[ <a href=\"$ROOT/$_/source/".uri_escape($pkg)."\">$_</a> ] ";
392 $package_page .= '<br>';
394 $package_page .= simple_menu( [ gettext( "Distribution:" ),
395 gettext( "Overview over this suite" ),
398 [ gettext( "Section:" ),
399 gettext( "All packages in this section" ),
400 "/$suite/$subsection/",
404 my $title .= sprintf( gettext( "Source Package: %s (%s)" ),
406 $title .= " ".marker( $archive ) if $archive ne 'us';
407 $title .= " ".marker( $subsection ) if $subsection eq 'non-US'
408 and $archive ne 'non-US'; # non-US/security
409 $title .= " ".marker( $section ) if $section ne 'main';
410 $package_page .= title( $title );
412 if ($suite eq "experimental") {
413 $package_page .= note( gettext( "Experimental package"),
414 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>".
415 gettext( "Users of experimental packages are encouraged to contact the package maintainers directly in case of problems." )
418 if ($subsection eq "debian-installer") {
419 note( gettext( "debian-installer udeb package"),
420 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." )
424 my $binaries = find_binaries( $pkg, $archive, $suite, \%src2bin );
425 if ($binaries && @$binaries) {
426 $package_page .= '<div class="pdesc">';
427 $package_page .= gettext( "The following binary packages are built from this source package:" );
428 $package_page .= pkg_list( \%packages, \%opts, $binaries, 'en' );
429 $package_page .= '</div> <!-- end pdesc -->';
433 # display dependencies
436 $dep_list = print_src_deps( \%packages, \%opts, $pkg,
437 $page->get_dep_field('build-depends'),
439 $dep_list .= print_src_deps( \%packages, \%opts, $pkg,
440 $page->get_dep_field('build-depends-indep'),
441 'build-depends-indep' );
444 $package_page .= "<div id=\"pdeps\">\n";
445 $package_page .= sprintf( "<h2>".gettext( "Other Packages Related to %s" )."</h2>\n", $pkg );
446 if ($suite eq "experimental") {
447 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." ) );
450 $package_page .= pdeplegend( [ 'adep', gettext( 'build-depends' ) ],
451 [ 'idep', gettext( 'build-depends-indep' ) ],
454 $package_page .= $dep_list;
455 $package_page .= "</div> <!-- end pdeps -->\n";
459 # Source package download
461 $package_page .= "<div id=\"pdownload\">\n";
462 my $encodedpack = uri_escape( $pkg );
463 $package_page .= sprintf( "<h2>".gettext( "Download %s" )."</h2>\n",
466 my $source_files = $page->get_src( 'files' );
467 my $source_dir = $page->get_src( 'directory' );
469 $package_page .= sprintf( "<table cellspacing=\"0\" cellpadding=\"2\" summary=\"Download information for the files of this source package\">\n"
470 ."<tr><th>%s</th><th>%s</th><th>%s</th>",
472 gettext("Size (in kB)"),
474 foreach( @$source_files ) {
475 my ($src_file_md5, $src_file_size, $src_file_name) = @$_;
479 $src_url = $FTP_SITES{security}; last };
481 $src_url = $FTP_SITES{volatile}; last };
483 $src_url = $FTP_SITES{backports}; last };
485 $src_url = $FTP_SITES{'non-US'}; last };
486 $src_url = $FTP_SITES{us};
488 $src_url .= "/$source_dir/$src_file_name";
490 $package_page .= "<tr><td><a href=\"$src_url\">$src_file_name</a></td>\n"
491 ."<td class=\"dotalign\">".sprintf("%.1f", (floor(($src_file_size/102.4)+0.5)/10))."</td>\n"
492 ."<td>$src_file_md5</td></tr>";
494 $package_page .= "</table>\n";
495 $package_page .= "</div> <!-- end pdownload -->\n";
500 $package_page .= pmoreinfo( name => $pkg, data => $page,
504 changesandcopy => 1, maintainers => 1,
505 search => 1, is_source => 1 );
512 #debug( "Final page object:\n".Dumper($page), 3 );
514 my $title = $opts{source} ?
515 "Details of source package <em>$pkg</em> in $suite" :
516 "Details of package <em>$pkg</em> in $suite" ;
517 my $title_tag = $opts{source} ?
518 "Details of source package $pkg in $suite" :
519 "Details of package $pkg in $suite" ;
520 print Packages::HTML::header( title => $title ,
523 keywords => "$suite, $archive, $section, $subsection, $version",
524 title_tag => "Details of package $pkg in $suite",
533 unless (@Packages::CGI::fatal_errors) {
536 my $tet1 = new Benchmark;
537 my $tetd = timediff($tet1, $tet0);
538 print "Total page evaluation took ".timestr($tetd)."<br>"
541 my $trailer = Packages::HTML::trailer( $ROOT );
542 $trailer =~ s/LAST_MODIFIED_DATE/gmtime()/e; #FIXME