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 non-US)] } },
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 debug( "find source package: source=$source (=$source_version)", 1);
174 my $src_data = $sources_all{"$source $source_version"};
175 unless ($src_data) { #fucking binNMUs
176 my $versions = $page->get_versions;
177 my $sources = $page->get_arch_field( 'source' );
178 my $source_versions = $page->get_arch_field( 'source-version' );
179 foreach (version_sort keys %$versions) {
180 $source = $sources->{$versions->{$_}[0]};
181 $source = $source_versions->{$versions->{$_}[0]}
183 $src_data = $sources_all{"$source $source_version"};
186 error( "couldn't find source package" ) unless $src_data;
188 $page->add_src_data( $source, $source_version, $src_data )
191 my $st1 = new Benchmark;
192 my $std = timediff($st1, $st0);
193 debug( "Data search and merging took ".timestr($std) );
195 my $encodedpkg = uri_escape( $pkg );
196 my ($v_str, $v_str_arch, $v_str_arr) = $page->get_version_string();
197 my $did = $page->get_newest( 'description' );
198 $archive = $page->get_newest( 'archive' );
199 $section = $page->get_newest( 'section' );
200 $subsection = $page->get_newest( 'subsection' );
201 my $filenames = $page->get_arch_field( 'filename' );
202 my $file_md5sums = $page->get_arch_field( 'md5sum' );
203 my $archives = $page->get_arch_field( 'archive' );
204 my $sizes_inst = $page->get_arch_field( 'installed-size' );
205 my $sizes_deb = $page->get_arch_field( 'size' );
206 my @archs = sort $page->get_architectures;
208 # process description
210 my $desc = $descriptions{$did};
211 $short_desc = encode_entities( $1, "<>&\"" )
212 if $desc =~ s/^(.*)$//m;
213 my $long_desc = encode_entities( $desc, "<>&\"" );
215 $long_desc =~ s,((ftp|http|https)://[\S~-]+?/?)((\>\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go; # syntax highlighting -> '];
216 $long_desc =~ s/\A //o;
217 $long_desc =~ s/\n /\n/sgo;
218 $long_desc =~ s/\n.\n/\n<p>\n/go;
219 $long_desc =~ s/(((\n|\A) [^\n]*)+)/\n<pre>$1\n<\/pre>/sgo;
220 # $long_desc = conv_desc( $lang, $long_desc );
221 # $short_desc = conv_desc( $lang, $short_desc );
224 foreach (@results, @non_results) {
227 if ($a =~ /^(?:us|security|non-US)$/o) {
230 $all_suites{"$s/$a"}++;
233 foreach (suites_sort(keys %all_suites)) {
234 if (("$suite/$archive" eq $_)
235 || (!$all_suites{"$suite/$archive"} && ($suite eq $_))) {
236 $package_page .= "[ <strong>$_</strong> ] ";
239 "[ <a href=\"$ROOT/$_/".uri_escape($pkg)."\">$_</a> ] ";
242 $package_page .= '<br>';
244 $package_page .= simple_menu( [ gettext( "Distribution:" ),
245 gettext( "Overview over this suite" ),
248 [ gettext( "Section:" ),
249 gettext( "All packages in this section" ),
250 "/$suite/$subsection/",
254 my $title .= sprintf( gettext( "Package: %s (%s)" ), $pkg, $v_str );
255 $title .= " ".marker( $archive ) if $archive ne 'us';
256 $title .= " ".marker( $subsection ) if $subsection eq 'non-US'
257 and $archive ne 'non-US'; # non-US/security
258 $title .= " ".marker( $section ) if $section ne 'main';
259 $package_page .= title( $title );
261 $package_page .= "<h2>".gettext( "Versions:" )." $v_str_arch</h2>\n"
262 unless $version eq $v_str;
264 if ($suite eq "experimental") {
265 $package_page .= note( gettext( "Experimental package"),
266 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>".
267 gettext( "Users of experimental packages are encouraged to contact the package maintainers directly in case of problems." )
270 if ($subsection eq "debian-installer") {
271 note( gettext( "debian-installer udeb package"),
272 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." )
275 $package_page .= pdesc( $short_desc, $long_desc );
278 # display dependencies
281 $dep_list = print_deps( \%packages, \%opts, $pkg,
282 $page->get_dep_field('depends'),
284 $dep_list .= print_deps( \%packages, \%opts, $pkg,
285 $page->get_dep_field('recommends'),
287 $dep_list .= print_deps( \%packages, \%opts, $pkg,
288 $page->get_dep_field('suggests'),
292 $package_page .= "<div id=\"pdeps\">\n";
293 $package_page .= sprintf( "<h2>".gettext( "Other Packages Related to %s" )."</h2>\n", $pkg );
294 if ($suite eq "experimental") {
295 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." ) );
298 $package_page .= pdeplegend( [ 'dep', gettext( 'depends' ) ],
299 [ 'rec', gettext( 'recommends' ) ],
300 [ 'sug', gettext( 'suggests' ) ], );
302 $package_page .= $dep_list;
303 $package_page .= "</div> <!-- end pdeps -->\n";
309 my $encodedpack = uri_escape( $pkg );
310 $package_page .= "<div id=\"pdownload\">";
311 $package_page .= sprintf( "<h2>".gettext( "Download %s\n" )."</h2>",
313 $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";
314 $package_page .= "<caption class=\"hidecss\">".gettext("Download for all available architectures")."</caption>\n";
315 $package_page .= "<tr>\n";
316 $package_page .= "<th>".gettext("Architecture")."</th><th>".gettext("Files")."</th><th>".gettext( "Package Size")."</th><th>".gettext("Installed Size")."</th></tr>\n";
317 foreach my $a ( @archs ) {
318 $package_page .= "<tr>\n";
319 $package_page .= "<th><a href=\"$DL_URL?arch=$a";
320 $package_page .= "&file=".uri_escape($filenames->{$a});
321 $package_page .= "&md5sum=$file_md5sums->{$a}";
322 $package_page .= "&arch=$a";
323 # there was at least one package with two
324 # different source packages on different
325 # archs where one had a security update
326 # and the other one not
327 for ($archives->{$a}) {
329 $package_page .= "&type=security"; last };
331 $package_page .= "&type=volatile"; last };
333 $package_page .= "&type=nonus"; last };
334 $package_page .= "&type=main";
336 $package_page .= "\">$a</a></th>\n";
337 $package_page .= "<td>";
338 if ( $suite ne "experimental" ) {
339 $package_page .= sprintf( "[<a href=\"%s\">".gettext( "list of files" )."</a>]\n", "$FILELIST_URL$encodedpkg&version=$suite&arch=$a", $pkg );
341 $package_page .= gettext( "no current information" );
343 $package_page .= "</td>\n<td>";
344 $package_page .= floor(($sizes_deb->{$a}/102.4)+0.5)/10;
345 $package_page .= "</td>\n<td>";
346 $package_page .= $sizes_inst->{$a};
347 $package_page .= "</td>\n</tr>";
349 $package_page .= "</table><p>".gettext ( "Size is measured in kBytes." )."</p>\n";
350 $package_page .= "</div> <!-- end pdownload -->\n";
355 $package_page .= pmoreinfo( name => $pkg, data => $page,
358 bugreports => 1, sourcedownload => 1,
359 changesandcopy => 1, maintainers => 1,
366 debug( "Final page object:\n".Dumper($page), 3 );
368 print Packages::HTML::header( title => "Details of package <em>$pkg</em> in $suite" ,
371 keywords => "$suite, $archive, $section, $subsection, $version",
372 title_tag => "Details of package $pkg in $suite",
381 unless (@Packages::CGI::fatal_errors) {
384 my $tet1 = new Benchmark;
385 my $tetd = timediff($tet1, $tet0);
386 print "Total page evaluation took ".timestr($tetd)."<br>"
389 my $trailer = Packages::HTML::trailer( $ROOT );
390 $trailer =~ s/LAST_MODIFIED_DATE/gmtime()/e; #FIXME