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 );
25 use Packages::Config qw( $DBDIR $ROOT @SUITES @ARCHIVES @SECTIONS
26 @ARCHITECTURES %FTP_SITES );
28 use Packages::Search qw( :all );
30 use Packages::Page ();
32 &Packages::CGI::reset;
34 $ENV{PATH} = "/bin:/usr/bin";
36 # Read in all the variables set by the form
38 if ($ARGV[0] && ($ARGV[0] eq 'php')) {
39 $input = new CGI(\*STDIN);
44 my $pet0 = new Benchmark;
45 my $tet0 = new Benchmark;
46 # use this to disable debugging in production mode completly
47 my $debug_allowed = 1;
48 my $debug = $debug_allowed && $input->param("debug");
49 $debug = 0 if !defined($debug) || $debug !~ /^\d+$/o;
50 $Packages::CGI::debug = $debug;
52 # read the configuration
53 our $db_read_time ||= 0;
55 &Packages::Config::init( '../' );
57 if (my $path = $input->param('path')) {
58 my @components = map { lc $_ } split /\//, $path;
60 my %SUITES = map { $_ => 1 } @SUITES;
61 my %SECTIONS = map { $_ => 1 } @SECTIONS;
62 my %ARCHIVES = map { $_ => 1 } @ARCHIVES;
63 my %ARCHITECTURES = map { $_ => 1 } @ARCHITECTURES;
65 foreach (@components) {
67 $input->param('suite', $_);
68 } elsif ($SECTIONS{$_}) {
69 $input->param('section', $_);
70 } elsif ($ARCHIVES{$_}) {
71 $input->param('archive', $_);
72 } elsif ($ARCHITECTURES{$_}) {
73 $input->param('arch', $_);
78 my ( $pkg, $suite, @sections, @archs, @archives, $format );
79 my %params_def = ( package => { default => undef, match => '^([a-z0-9.+-]+)$',
81 suite => { default => undef, match => '^(\w+)$',
83 archive => { default => 'all', match => '^(\w+)$',
84 array => ',', var => \@archives,
85 replace => { all => [qw(us security)] } },
86 section => { default => 'all', match => '^(\w+)$',
87 array => ',', var => \@sections,
88 replace => { all => \@SECTIONS } },
89 arch => { default => 'any', match => '^(\w+)$',
90 array => ',', var => \@archs,
91 replace => { any => \@ARCHITECTURES } },
92 format => { default => 'html', match => '^(\w+)$',
96 my %params = Packages::Search::parse_params( $input, \%params_def, \%opts );
98 #XXX: Don't use alternative output formats yet
100 if ($format eq 'html') {
101 print $input->header;
104 if ($params{errors}{package}) {
105 fatal_error( "package not valid or not specified" );
108 if ($params{errors}{suite}) {
109 fatal_error( "suite not valid or not specified" );
113 $opts{h_suites} = { $suite => 1 };
114 $opts{h_archs} = { map { $_ => 1 } @archs };
115 $opts{h_sections} = { map { $_ => 1 } @sections };
116 $opts{h_archives} = { map { $_ => 1 } @archives };;
118 my $DL_URL = "$pkg/download";
119 my $FILELIST_URL = "$pkg/files";
121 our (%packages, %packages_all, %sources_all, %descriptions);
122 my (@results, @non_results);
123 my $page = new Packages::Page( $pkg );
124 my $package_page = "";
125 my ($short_desc, $version, $archive, $section, $subsection) = ("")x5;
127 sub gettext { return $_[0]; };
129 my $st0 = new Benchmark;
130 unless (@Packages::CGI::fatal_errors) {
131 my $dbmodtime = (stat("$DBDIR/packages_small.db"))[9];
132 tie %packages_all, 'DB_File', "$DBDIR/packages_all_$suite.db",
133 O_RDONLY, 0666, $DB_BTREE
134 or die "couldn't tie DB $DBDIR/packages_all_$suite.db: $!";
135 tie %sources_all, 'DB_File', "$DBDIR/sources_all_$suite.db",
136 O_RDONLY, 0666, $DB_BTREE
137 or die "couldn't tie DB $DBDIR/sources_all_$suite.db: $!";
138 if ($dbmodtime > $db_read_time) {
139 tie %packages, 'DB_File', "$DBDIR/packages_small.db",
140 O_RDONLY, 0666, $DB_BTREE
141 or die "couldn't tie DB $DBDIR/packages_small.db: $!";
142 tie %descriptions, 'DB_File', "$DBDIR/descriptions.db",
143 O_RDONLY, 0666, $DB_BTREE
144 or die "couldn't tie DB $DBDIR/descriptions.db: $!";
146 debug( "tied databases ($dbmodtime > $db_read_time)" );
147 $db_read_time = $dbmodtime;
150 read_entry_all( \%packages, $pkg, \@results, \@non_results, \%opts );
152 unless (@results || @non_results ) {
153 fatal_error( "No such package".
154 "{insert link to search page with substring search}" );
157 fatal_error( "Package not available in this suite" );
159 for my $entry (@results) {
160 debug( join(":", @$entry), 1 );
161 my (undef, $archive, undef, $arch, $section, $subsection,
162 $priority, $version) = @$entry;
164 my $data = $packages_all{"$pkg $arch $version"};
165 $page->merge_data($pkg, $version, $arch, $data) or debug( "Merging $pkg $arch $version FAILED", 2 );
168 $version = $page->{newest};
169 my $source = $page->get_newest( 'source' );
170 my $source_version = $page->get_newest( 'source-version' )
172 my $src_data = $sources_all{"$source $source_version"};
173 unless ($src_data) { #fucking binNMUs
174 my $versions = $page->get_versions;
175 my $sources = $page->get_arch_field( 'source' );
176 my $source_versions = $page->get_arch_field( 'source-version' );
177 foreach (version_sort keys %$versions) {
178 $source = $sources->{$versions->{$_}[0]};
179 $source = $source_versions->{$versions->{$_}[0]}
181 $src_data = $sources_all{"$source $source_version"};
184 error( "couldn't find source package" ) unless $src_data;
186 $page->add_src_data( $source, $source_version, $src_data );
188 my $st1 = new Benchmark;
189 my $std = timediff($st1, $st0);
190 debug( "Data search and merging took ".timestr($std) );
192 my $encodedpkg = uri_escape( $pkg );
193 my ($v_str, $v_str_arch, $v_str_arr) = $page->get_version_string();
194 my $did = $page->get_newest( 'description' );
195 $archive = $page->get_newest( 'archive' );
196 $section = $page->get_newest( 'section' );
197 $subsection = $page->get_newest( 'subsection' );
198 my $filenames = $page->get_arch_field( 'filename' );
199 my $file_md5sums = $page->get_arch_field( 'md5sum' );
200 my $archives = $page->get_arch_field( 'archive' );
201 my $sizes_inst = $page->get_arch_field( 'installed-size' );
202 my $sizes_deb = $page->get_arch_field( 'size' );
203 my @archs = sort $page->get_architectures;
205 # process description
207 my $desc = $descriptions{$did};
208 $short_desc = encode_entities( $1, "<>&\"" )
209 if $desc =~ s/^(.*)$//m;
210 my $long_desc = encode_entities( $desc, "<>&\"" );
212 $long_desc =~ s,((ftp|http|https)://[\S~-]+?/?)((\>\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go; # syntax highlighting -> '];
213 $long_desc =~ s/\A //o;
214 $long_desc =~ s/\n /\n/sgo;
215 $long_desc =~ s/\n.\n/\n<p>\n/go;
216 $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 );
221 foreach (@results, @non_results) {
224 if ($a =~ /^(?:us|security)$/o) {
227 $all_suites{"$s/$a"}++;
230 foreach (suites_sort(keys %all_suites)) {
231 if (("$suite/$archive" eq $_)
232 || (!$all_suites{"$suite/$archive"} && ($suite eq $_))) {
233 $package_page .= "[ <strong>$_</strong> ] ";
236 "[ <a href=\"$ROOT/$_/".uri_escape($pkg)."\">$_</a> ] ";
239 $package_page .= '<br>';
241 $package_page .= simple_menu( [ gettext( "Distribution:" ),
242 gettext( "Overview over this suite" ),
245 [ gettext( "Section:" ),
246 gettext( "All packages in this section" ),
247 "/$suite/$subsection/",
251 my $title .= sprintf( gettext( "Package: %s (%s)" ), $pkg, $v_str );
252 $title .= " ".marker( $archive ) if $archive ne 'us';
253 $title .= " ".marker( $section ) if $section ne 'main';
254 $package_page .= title( $title );
256 $package_page .= "<h2>".gettext( "Versions:" )." $v_str_arch</h2>\n"
257 unless $version eq $v_str;
259 if ($suite eq "experimental") {
260 $package_page .= note( gettext( "Experimental package"),
261 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>".
262 gettext( "Users of experimental packages are encouraged to contact the package maintainers directly in case of problems." )
265 if ($subsection eq "debian-installer") {
266 note( gettext( "debian-installer udeb package"),
267 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." )
270 $package_page .= pdesc( $short_desc, $long_desc );
273 # display dependencies
276 $dep_list = print_deps( \%packages, \%opts, $pkg,
277 $page->get_dep_field('depends'),
279 $dep_list .= print_deps( \%packages, \%opts, $pkg,
280 $page->get_dep_field('recommends'),
282 $dep_list .= print_deps( \%packages, \%opts, $pkg,
283 $page->get_dep_field('suggests'),
287 $package_page .= "<div id=\"pdeps\">\n";
288 $package_page .= sprintf( "<h2>".gettext( "Other Packages Related to %s" )."</h2>\n", $pkg );
289 if ($suite eq "experimental") {
290 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." ) );
293 $package_page .= pdeplegend( [ 'dep', gettext( 'depends' ) ],
294 [ 'rec', gettext( 'recommends' ) ],
295 [ 'sug', gettext( 'suggests' ) ], );
297 $package_page .= $dep_list;
298 $package_page .= "</div> <!-- end pdeps -->\n";
304 my $encodedpack = uri_escape( $pkg );
305 $package_page .= "<div id=\"pdownload\">";
306 $package_page .= sprintf( "<h2>".gettext( "Download %s\n" )."</h2>",
308 $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";
309 $package_page .= "<caption class=\"hidecss\">".gettext("Download for all available architectures")."</caption>\n";
310 $package_page .= "<tr>\n";
311 $package_page .= "<th>".gettext("Architecture")."</th><th>".gettext("Files")."</th><th>".gettext( "Package Size")."</th><th>".gettext("Installed Size")."</th></tr>\n";
312 foreach my $a ( @archs ) {
313 $package_page .= "<tr>\n";
314 $package_page .= "<th><a href=\"$DL_URL?arch=$a";
315 $package_page .= "&file=".uri_escape($filenames->{$a});
316 $package_page .= "&md5sum=$file_md5sums->{$a}";
317 $package_page .= "&arch=$a";
318 # there was at least one package with two
319 # different source packages on different
320 # archs where one had a security update
321 # and the other one not
322 for ($archives->{$a}) {
324 $package_page .= "&type=security"; last };
326 $package_page .= "&type=volatile"; last };
328 $package_page .= "&type=nonus"; last };
329 $package_page .= "&type=main";
331 $package_page .= "\">$a</a></th>\n";
332 $package_page .= "<td>";
333 if ( $suite ne "experimental" ) {
334 $package_page .= sprintf( "[<a href=\"%s\">".gettext( "list of files" )."</a>]\n", "$FILELIST_URL$encodedpkg&version=$suite&arch=$a", $pkg );
336 $package_page .= gettext( "no current information" );
338 $package_page .= "</td>\n<td>";
339 $package_page .= floor(($sizes_deb->{$a}/102.4)+0.5)/10;
340 $package_page .= "</td>\n<td>";
341 $package_page .= $sizes_inst->{$a};
342 $package_page .= "</td>\n</tr>";
344 $package_page .= "</table><p>".gettext ( "Size is measured in kBytes." )."</p>\n";
345 $package_page .= "</div> <!-- end pdownload -->\n";
350 $package_page .= pmoreinfo( name => $pkg, data => $page,
353 bugreports => 1, sourcedownload => 1,
354 changesandcopy => 1, maintainers => 1,
361 debug( "Final page object:\n".Dumper($page), 3 );
363 print Packages::HTML::header( title => "Details of package <em>$pkg</em> in $suite" ,
366 keywords => "$suite, $archive, $section, $subsection, $version",
367 title_tag => "Details of package $pkg in $suite",
376 unless (@Packages::CGI::fatal_errors) {
379 my $tet1 = new Benchmark;
380 my $tetd = timediff($tet1, $tet0);
381 print "Total page evaluation took ".timestr($tetd)."<br>"
384 my $trailer = Packages::HTML::trailer( $ROOT );
385 $trailer =~ s/LAST_MODIFIED_DATE/gmtime()/e; #FIXME