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 );
29 use Packages::Search qw( :all );
31 use Packages::Page ();
33 &Packages::CGI::reset;
35 $ENV{PATH} = "/bin:/usr/bin";
37 # Read in all the variables set by the form
39 if ($ARGV[0] && ($ARGV[0] eq 'php')) {
40 $input = new CGI(\*STDIN);
45 my $pet0 = new Benchmark;
46 my $tet0 = new Benchmark;
47 # use this to disable debugging in production mode completly
48 my $debug_allowed = 1;
49 my $debug = $debug_allowed && $input->param("debug");
50 $debug = 0 if !defined($debug) || $debug !~ /^\d+$/o;
51 $Packages::CGI::debug = $debug;
53 # read the configuration
54 our $db_read_time ||= 0;
56 &Packages::Config::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', $_);
79 my ( $pkg, $suite, @sections, @archs, @archives, $format );
80 my %params_def = ( package => { default => undef, match => '^([a-z0-9.+-]+)$',
82 suite => { default => undef, match => '^(\w+)$',
84 archive => { default => 'all', match => '^(\w+)$',
85 array => ',', var => \@archives,
86 replace => { all => [qw(us security)] } },
87 section => { default => 'all', match => '^(\w+)$',
88 array => ',', var => \@sections,
89 replace => { all => \@SECTIONS } },
90 arch => { default => 'any', match => '^(\w+)$',
91 array => ',', var => \@archs,
92 replace => { any => \@ARCHITECTURES } },
93 format => { default => 'html', match => '^(\w+)$',
97 my %params = Packages::Search::parse_params( $input, \%params_def, \%opts );
99 #XXX: Don't use alternative output formats yet
101 if ($format eq 'html') {
102 print $input->header;
105 if ($params{errors}{package}) {
106 fatal_error( "package not valid or not specified" );
109 if ($params{errors}{suite}) {
110 fatal_error( "suite not valid or not specified" );
114 $opts{h_suites} = { $suite => 1 };
115 $opts{h_archs} = { map { $_ => 1 } @archs };
116 $opts{h_sections} = { map { $_ => 1 } @sections };
117 $opts{h_archives} = { map { $_ => 1 } @archives };;
119 my $DL_URL = "$pkg/download";
120 my $FILELIST_URL = "$pkg/files";
122 our (%packages, %packages_all, %sources_all, %descriptions);
123 my (@results, @non_results);
124 my $page = new Packages::Page( $pkg );
125 my $package_page = "";
126 my ($short_desc, $version, $archive, $section, $subsection) = ("")x5;
128 sub gettext { return $_[0]; };
130 my $st0 = new Benchmark;
131 unless (@Packages::CGI::fatal_errors) {
132 my $dbmodtime = (stat("$DBDIR/packages_small.db"))[9];
133 tie %packages_all, 'DB_File', "$DBDIR/packages_all_$suite.db",
134 O_RDONLY, 0666, $DB_BTREE
135 or die "couldn't tie DB $DBDIR/packages_all_$suite.db: $!";
136 tie %sources_all, 'DB_File', "$DBDIR/sources_all_$suite.db",
137 O_RDONLY, 0666, $DB_BTREE
138 or die "couldn't tie DB $DBDIR/sources_all_$suite.db: $!";
139 if ($dbmodtime > $db_read_time) {
140 tie %packages, 'DB_File', "$DBDIR/packages_small.db",
141 O_RDONLY, 0666, $DB_BTREE
142 or die "couldn't tie DB $DBDIR/packages_small.db: $!";
143 tie %descriptions, 'DB_File', "$DBDIR/descriptions.db",
144 O_RDONLY, 0666, $DB_BTREE
145 or die "couldn't tie DB $DBDIR/descriptions.db: $!";
147 debug( "tied databases ($dbmodtime > $db_read_time)" );
148 $db_read_time = $dbmodtime;
151 read_entry_all( \%packages, $pkg, \@results, \@non_results, \%opts );
153 unless (@results || @non_results ) {
154 fatal_error( "No such package".
155 "{insert link to search page with substring search}" );
158 fatal_error( "Package not available in this suite" );
160 for my $entry (@results) {
161 debug( join(":", @$entry), 1 );
162 my (undef, $archive, undef, $arch, $section, $subsection,
163 $priority, $version) = @$entry;
165 my $data = $packages_all{"$pkg $arch $version"};
166 $page->merge_data($pkg, $version, $arch, $data) or debug( "Merging $pkg $arch $version FAILED", 2 );
169 $version = $page->{newest};
170 my $source = $page->get_newest( 'source' );
171 my $source_version = $page->get_newest( 'source-version' )
173 my $src_data = $sources_all{"$source $source_version"};
174 unless ($src_data) { #fucking binNMUs
175 my $versions = $page->get_versions;
176 my $sources = $page->get_arch_field( 'source' );
177 my $source_versions = $page->get_arch_field( 'source-version' );
178 foreach (version_sort keys %$versions) {
179 $source = $sources->{$versions->{$_}[0]};
180 $source = $source_versions->{$versions->{$_}[0]}
182 $src_data = $sources_all{"$source $source_version"};
185 error( "couldn't find source package" ) unless $src_data;
187 $page->add_src_data( $source, $source_version, $src_data );
189 my $st1 = new Benchmark;
190 my $std = timediff($st1, $st0);
191 debug( "Data search and merging took ".timestr($std) );
193 my $encodedpkg = uri_escape( $pkg );
194 my ($v_str, $v_str_arch, $v_str_arr) = $page->get_version_string();
195 my $did = $page->get_newest( 'description' );
196 $archive = $page->get_newest( 'archive' );
197 $section = $page->get_newest( 'section' );
198 $subsection = $page->get_newest( 'subsection' );
199 my $filenames = $page->get_arch_field( 'filename' );
200 my $file_md5sums = $page->get_arch_field( 'md5sum' );
201 my $archives = $page->get_arch_field( 'archive' );
202 my $sizes_inst = $page->get_arch_field( 'installed-size' );
203 my $sizes_deb = $page->get_arch_field( 'size' );
204 my @archs = sort $page->get_architectures;
206 # process description
208 my $desc = $descriptions{$did};
209 $short_desc = encode_entities( $1, "<>&\"" )
210 if $desc =~ s/^(.*)$//m;
211 my $long_desc = encode_entities( $desc, "<>&\"" );
213 $long_desc =~ s,((ftp|http|https)://[\S~-]+?/?)((\>\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go; # syntax highlighting -> '];
214 $long_desc =~ s/\A //o;
215 $long_desc =~ s/\n /\n/sgo;
216 $long_desc =~ s/\n.\n/\n<p>\n/go;
217 $long_desc =~ s/(((\n|\A) [^\n]*)+)/\n<pre>$1\n<\/pre>/sgo;
218 # $long_desc = conv_desc( $lang, $long_desc );
219 # $short_desc = conv_desc( $lang, $short_desc );
222 foreach (@results, @non_results) {
225 if ($a =~ /^(?:us|security)$/o) {
228 $all_suites{"$s/$a"}++;
231 foreach (suites_sort(keys %all_suites)) {
232 if (("$suite/$archive" eq $_)
233 || (!$all_suites{"$suite/$archive"} && ($suite eq $_))) {
234 $package_page .= "[ <strong>$_</strong> ] ";
237 "[ <a href=\"$ROOT/$_/".uri_escape($pkg)."\">$_</a> ] ";
240 $package_page .= '<br>';
242 $package_page .= simple_menu( [ gettext( "Distribution:" ),
243 gettext( "Overview over this suite" ),
246 [ gettext( "Section:" ),
247 gettext( "All packages in this section" ),
248 "/$suite/$subsection/",
252 my $title .= sprintf( gettext( "Package: %s (%s)" ), $pkg, $v_str );
253 $title .= " ".marker( $archive ) if $archive ne 'us';
254 $title .= " ".marker( $section ) if $section ne 'main';
255 $package_page .= title( $title );
257 $package_page .= "<h2>".gettext( "Versions:" )." $v_str_arch</h2>\n"
258 unless $version eq $v_str;
260 if ($suite eq "experimental") {
261 $package_page .= note( gettext( "Experimental package"),
262 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>".
263 gettext( "Users of experimental packages are encouraged to contact the package maintainers directly in case of problems." )
266 if ($subsection eq "debian-installer") {
267 note( gettext( "debian-installer udeb package"),
268 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." )
271 $package_page .= pdesc( $short_desc, $long_desc );
274 # display dependencies
277 $dep_list = print_deps( \%packages, \%opts, $pkg,
278 $page->get_dep_field('depends'),
280 $dep_list .= print_deps( \%packages, \%opts, $pkg,
281 $page->get_dep_field('recommends'),
283 $dep_list .= print_deps( \%packages, \%opts, $pkg,
284 $page->get_dep_field('suggests'),
288 $package_page .= "<div id=\"pdeps\">\n";
289 $package_page .= sprintf( "<h2>".gettext( "Other Packages Related to %s" )."</h2>\n", $pkg );
290 if ($suite eq "experimental") {
291 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." ) );
294 $package_page .= pdeplegend( [ 'dep', gettext( 'depends' ) ],
295 [ 'rec', gettext( 'recommends' ) ],
296 [ 'sug', gettext( 'suggests' ) ], );
298 $package_page .= $dep_list;
299 $package_page .= "</div> <!-- end pdeps -->\n";
305 my $encodedpack = uri_escape( $pkg );
306 $package_page .= "<div id=\"pdownload\">";
307 $package_page .= sprintf( "<h2>".gettext( "Download %s\n" )."</h2>",
309 $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";
310 $package_page .= "<caption class=\"hidecss\">".gettext("Download for all available architectures")."</caption>\n";
311 $package_page .= "<tr>\n";
312 $package_page .= "<th>".gettext("Architecture")."</th><th>".gettext("Files")."</th><th>".gettext( "Package Size")."</th><th>".gettext("Installed Size")."</th></tr>\n";
313 foreach my $a ( @archs ) {
314 $package_page .= "<tr>\n";
315 $package_page .= "<th><a href=\"$DL_URL?arch=$a";
316 $package_page .= "&file=".uri_escape($filenames->{$a});
317 $package_page .= "&md5sum=$file_md5sums->{$a}";
318 $package_page .= "&arch=$a";
319 # there was at least one package with two
320 # different source packages on different
321 # archs where one had a security update
322 # and the other one not
323 for ($archives->{$a}) {
325 $package_page .= "&type=security"; last };
327 $package_page .= "&type=volatile"; last };
329 $package_page .= "&type=nonus"; last };
330 $package_page .= "&type=main";
332 $package_page .= "\">$a</a></th>\n";
333 $package_page .= "<td>";
334 if ( $suite ne "experimental" ) {
335 $package_page .= sprintf( "[<a href=\"%s\">".gettext( "list of files" )."</a>]\n", "$FILELIST_URL$encodedpkg&version=$suite&arch=$a", $pkg );
337 $package_page .= gettext( "no current information" );
339 $package_page .= "</td>\n<td>";
340 $package_page .= floor(($sizes_deb->{$a}/102.4)+0.5)/10;
341 $package_page .= "</td>\n<td>";
342 $package_page .= $sizes_inst->{$a};
343 $package_page .= "</td>\n</tr>";
345 $package_page .= "</table><p>".gettext ( "Size is measured in kBytes." )."</p>\n";
346 $package_page .= "</div> <!-- end pdownload -->\n";
351 $package_page .= pmoreinfo( name => $pkg, data => $page,
354 bugreports => 1, sourcedownload => 1,
355 changesandcopy => 1, maintainers => 1,
362 debug( "Final page object:\n".Dumper($page), 3 );
364 print Packages::HTML::header( title => "Details of package <em>$pkg</em> in $suite" ,
367 keywords => "$suite, $archive, $section, $subsection, $version",
368 title_tag => "Details of package $pkg in $suite",
377 unless (@Packages::CGI::fatal_errors) {
380 my $tet1 = new Benchmark;
381 my $tetd = timediff($tet1, $tet0);
382 print "Total page evaluation took ".timestr($tetd)."<br>"
385 my $trailer = Packages::HTML::trailer( $ROOT );
386 $trailer =~ s/LAST_MODIFIED_DATE/gmtime()/e; #FIXME