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 );
26 use Packages::Search qw( :all );
28 use Packages::Page ();
30 &Packages::CGI::reset;
32 $ENV{PATH} = "/bin:/usr/bin";
34 # Read in all the variables set by the form
36 if ($ARGV[0] && ($ARGV[0] eq 'php')) {
37 $input = new CGI(\*STDIN);
42 my $pet0 = new Benchmark;
43 my $tet0 = new Benchmark;
44 # use this to disable debugging in production mode completly
45 my $debug_allowed = 1;
46 my $debug = $debug_allowed && $input->param("debug");
47 $debug = 0 if !defined($debug) || $debug !~ /^\d+$/o;
48 $Packages::CGI::debug = $debug;
50 # read the configuration
51 our $config_read_time ||= 0;
52 our $db_read_time ||= 0;
53 our ( $topdir, $ROOT, @SUITES, @SECTIONS, @ARCHIVES, @ARCHITECTURES );
55 # FIXME: move to own module
56 my $modtime = (stat( "../config.sh" ))[9];
57 if ($modtime > $config_read_time) {
58 if (!open (C, '<', "../config.sh")) {
59 error( "Internal: Cannot open configuration file." );
64 $topdir = $1 if /^\s*topdir="?([^\"]*)"?\s*$/o;
65 $ROOT = $1 if /^\s*root="?([^\"]*)"?\s*$/o;
66 $Packages::HTML::HOME = $1 if /^\s*home="?([^\"]*)"?\s*$/o;
67 $Packages::HTML::SEARCH_CGI = $1 if /^\s*searchcgi="?([^\"]*)"?\s*$/o;
68 $Packages::HTML::SEARCH_PAGE = $1 if /^\s*searchpage="?([^\"]*)"?\s*$/o;
69 $Packages::HTML::WEBMASTER_MAIL = $1 if /^\s*webmaster="?([^\"]*)"?\s*$/o;
70 $Packages::HTML::CONTACT_MAIL = $1 if /^\s*contact="?([^\"]*)"?\s*$/o;
71 $Packages::HTML::BUG_URL = $1 if /^\s*bug_url="?([^\"]*)"?\s*$/o;
72 $Packages::HTML::SRC_BUG_URL = $1 if /^\s*src_bug_url="?([^\"]*)"?\s*$/o;
73 $Packages::HTML::QA_URL = $1 if /^\s*qa_url="?([^\"]*)"?\s*$/o;
74 @SUITES = split(/\s+/, $1) if /^\s*suites="?([^\"]*)"?\s*$/o;
75 @SECTIONS = split(/\s+/, $1) if /^\s*sections="?([^\"]*)"?\s*$/o;
76 @ARCHIVES = split(/\s+/, $1) if /^\s*archives="?([^\"]*)"?\s*$/o;
77 @ARCHITECTURES = split(/\s+/, $1) if /^\s*architectures="?([^\"]*)"?\s*$/o;
80 debug( "read config ($modtime > $config_read_time)" );
81 $config_read_time = $modtime;
83 my $DBDIR = $topdir . "/files/db";
84 my $thisscript = $Packages::HTML::SEARCH_CGI;
86 if (my $path = $input->param('path')) {
87 my @components = map { lc $_ } split /\//, $path;
89 my %SUITES = map { $_ => 1 } @SUITES;
90 my %SECTIONS = map { $_ => 1 } @SECTIONS;
91 my %ARCHIVES = map { $_ => 1 } @ARCHIVES;
92 my %ARCHITECTURES = map { $_ => 1 } @ARCHITECTURES;
94 foreach (@components) {
96 $input->param('suite', $_);
97 } elsif ($SECTIONS{$_}) {
98 $input->param('section', $_);
99 } elsif ($ARCHIVES{$_}) {
100 $input->param('archive', $_);
101 } elsif ($ARCHITECTURES{$_}) {
102 $input->param('arch', $_);
107 my ( $pkg, $suite, $format );
108 my %params_def = ( package => { default => undef, match => '^([a-z0-9.+-]+)$',
110 suite => { default => undef, match => '^(\w+)$',
112 format => { default => 'html', match => '^(\w+)$',
116 my %params = Packages::Search::parse_params( $input, \%params_def, \%opts );
118 $opts{h_suites} = { $suite => 1 };
119 $opts{h_archs} = { map { $_ => 1 } @ARCHITECTURES };
120 $opts{h_sections} = { map { $_ => 1 } @SECTIONS };
121 $opts{h_archives} = { map { $_ => 1 } @ARCHIVES };
123 #XXX: Don't use alternative output formats yet
125 if ($format eq 'html') {
126 print $input->header;
129 if ($params{errors}{package}) {
130 fatal_error( "package not valid or not specified" );
132 if ($params{errors}{suite}) {
133 fatal_error( "suite not valid or not specified" );
136 my $DL_URL = "$pkg/download";
137 my $FILELIST_URL = "$pkg/files";
138 my $DDPO_URL = "http://qa.debian.org/developer.php?email=";
140 our (%packages, %packages_all, %sources_all, %descriptions);
141 my (@results, @non_results);
142 my $page = new Packages::Page( $pkg );
143 my $package_page = "";
144 my ($short_desc, $version, $archive, $section, $subsection) = ("")x5;
146 sub gettext { return $_[0]; };
148 my $st0 = new Benchmark;
149 unless (@Packages::CGI::fatal_errors) {
150 my $dbmodtime = (stat("$DBDIR/packages_small.db"))[9];
151 if ($dbmodtime > $db_read_time) {
152 tie %packages, 'DB_File', "$DBDIR/packages_small.db",
153 O_RDONLY, 0666, $DB_BTREE
154 or die "couldn't tie DB $DBDIR/packages_small.db: $!";
155 tie %packages_all, 'DB_File', "$DBDIR/packages_all_$suite.db",
156 O_RDONLY, 0666, $DB_BTREE
157 or die "couldn't tie DB $DBDIR/packages_all_$suite.db: $!";
158 tie %sources_all, 'DB_File', "$DBDIR/sources_all_$suite.db",
159 O_RDONLY, 0666, $DB_BTREE
160 or die "couldn't tie DB $DBDIR/sources_all_$suite.db: $!";
161 tie %descriptions, 'DB_File', "$DBDIR/descriptions.db",
162 O_RDONLY, 0666, $DB_BTREE
163 or die "couldn't tie DB $DBDIR/descriptions.db: $!";
165 debug( "tied databases ($dbmodtime > $db_read_time)" );
166 $db_read_time = $dbmodtime;
169 read_entry_all( \%packages, $pkg, \@results, \@non_results, \%opts );
171 unless (@results || @non_results ) {
172 fatal_error( "No such package".
173 "{insert link to search page with substring search}" );
176 fatal_error( "Package not available in this suite" );
178 for my $entry (@results) {
179 debug( join(":", @$entry), 1 );
180 my (undef, $archive, undef, $arch, $section, $subsection,
181 $priority, $version) = @$entry;
183 my $data = $packages_all{"$pkg $arch $version"};
184 $page->merge_data($pkg, $version, $arch, $data) or debug( "Merging $pkg $arch $version FAILED", 2 );
187 $version = $page->{newest};
188 my $source = $page->get_newest( 'source' );
189 my $source_version = $page->get_newest( 'source-version' )
191 my $src_data = $sources_all{"$source $source_version"};
192 unless ($src_data) { #fucking binNMUs
193 my $versions = $page->get_versions;
194 my $sources = $page->get_arch_field( 'source' );
195 my $source_versions = $page->get_arch_field( 'source-version' );
196 foreach (version_sort keys %$versions) {
197 $source = $sources->{$versions->{$_}[0]};
198 $source = $source_versions->{$versions->{$_}[0]}
200 $src_data = $sources_all{"$source $source_version"};
203 error( "couldn't find source package" ) unless $src_data;
205 $page->add_src_data( $source, $source_version, $src_data );
207 my $st1 = new Benchmark;
208 my $std = timediff($st1, $st0);
209 debug( "Data search and merging took ".timestr($std) );
211 my $encodedpkg = uri_escape( $pkg );
212 my ($v_str, $v_str_arch, $v_str_arr) = $page->get_version_string();
213 my $did = $page->get_newest( 'description' );
214 $archive = $page->get_newest( 'archive' );
215 $section = $page->get_newest( 'section' );
216 $subsection = $page->get_newest( 'subsection' );
217 my $filenames = $page->get_arch_field( 'filename' );
218 my $file_md5sums = $page->get_arch_field( 'md5sum' );
219 my $archives = $page->get_arch_field( 'archive' );
220 my $sizes_inst = $page->get_arch_field( 'installed-size' );
221 my $sizes_deb = $page->get_arch_field( 'size' );
222 my @archs = sort $page->get_architectures;
224 # process description
226 my $desc = $descriptions{$did};
227 $short_desc = encode_entities( $1, "<>&\"" )
228 if $desc =~ s/^(.*)$//m;
229 my $long_desc = encode_entities( $desc, "<>&\"" );
231 $long_desc =~ s,((ftp|http|https)://[\S~-]+?/?)((\>\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go; # syntax highlighting -> '];
232 $long_desc =~ s/\A //o;
233 $long_desc =~ s/\n /\n/sgo;
234 $long_desc =~ s/\n.\n/\n<p>\n/go;
235 $long_desc =~ s/(((\n|\A) [^\n]*)+)/\n<pre>$1\n<\/pre>/sgo;
236 # $long_desc = conv_desc( $lang, $long_desc );
237 # $short_desc = conv_desc( $lang, $short_desc );
239 my %all_suites = map { $_->[2] => 1 } (@results, @non_results);
240 foreach (suites_sort(keys %all_suites)) {
242 $package_page .= "[ <strong>$_</strong> ] ";
245 "[ <a href=\"../$_/".uri_escape($pkg)."\">$_</a> ] ";
249 $package_page .= simple_menu( [ gettext( "Distribution:" ),
250 gettext( "Overview over this suite" ),
253 [ gettext( "Section:" ),
254 gettext( "All packages in this section" ),
255 "/$suite/$subsection/",
259 my $title .= sprintf( gettext( "Package: %s (%s)" ), $pkg, $v_str );
260 $title .= " ".marker( $archive ) if $archive ne 'us';
261 $title .= " ".marker( $section ) if $section ne 'main';
262 $package_page .= title( $title );
264 $package_page .= "<h2>".gettext( "Versions:" )." $v_str_arch</h2>\n"
265 unless $version eq $v_str;
267 if ($suite eq "experimental") {
268 $package_page .= note( gettext( "Experimental package"),
269 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>".
270 gettext( "Users of experimental packages are encouraged to contact the package maintainers directly in case of problems." )
273 if ($subsection eq "debian-installer") {
274 note( gettext( "debian-installer udeb package"),
275 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." )
278 $package_page .= pdesc( $short_desc, $long_desc );
281 # display dependencies
283 my $dep_list = print_deps( \%packages, \%opts, $pkg,
284 $page->get_dep_field('depends'),
286 $dep_list .= print_deps( \%packages, \%opts, $pkg,
287 $page->get_dep_field('recommends'),
289 $dep_list .= print_deps( \%packages, \%opts, $pkg,
290 $page->get_dep_field('suggests'),
294 $package_page .= "<div id=\"pdeps\">\n";
295 $package_page .= sprintf( "<h2>".gettext( "Other Packages Related to %s" )."</h2>\n", $pkg );
296 if ($suite eq "experimental") {
297 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." ) );
300 $package_page .= pdeplegend( [ 'dep', gettext( 'depends' ) ],
301 [ 'rec', gettext( 'recommends' ) ],
302 [ 'sug', gettext( 'suggests' ) ], );
304 $package_page .= $dep_list;
305 $package_page .= "</div> <!-- end pdeps -->\n";
310 my $encodedpack = uri_escape( $pkg );
311 $package_page .= "<div id=\"pdownload\">";
312 $package_page .= sprintf( "<h2>".gettext( "Download %s\n" )."</h2>",
314 $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";
315 $package_page .= "<caption class=\"hidecss\">".gettext("Download for all available architectures")."</caption>\n";
316 $package_page .= "<tr>\n";
317 $package_page .= "<th>".gettext("Architecture")."</th><th>".gettext("Files")."</th><th>".gettext( "Package Size")."</th><th>".gettext("Installed Size")."</th></tr>\n";
318 foreach my $a ( @archs ) {
319 $package_page .= "<tr>\n";
320 $package_page .= "<th><a href=\"$DL_URL?arch=$a";
321 $package_page .= "&file=".uri_escape($filenames->{$a});
322 $package_page .= "&md5sum=$file_md5sums->{$a}";
323 $package_page .= "&arch=$a";
324 # there was at least one package with two
325 # different source packages on different
326 # archs where one had a security update
327 # and the other one not
328 for ($archives->{$a}) {
330 $package_page .= "&type=security"; last };
332 $package_page .= "&type=volatile"; last };
334 $package_page .= "&type=nonus"; last };
335 $package_page .= "&type=main";
337 $package_page .= "\">$a</a></th>\n";
338 $package_page .= "<td>";
339 if ( $suite ne "experimental" ) {
340 $package_page .= sprintf( "[<a href=\"%s\">".gettext( "list of files" )."</a>]\n", "$FILELIST_URL$encodedpkg&version=$suite&arch=$a", $pkg );
342 $package_page .= gettext( "no current information" );
344 $package_page .= "</td>\n<td>";
345 $package_page .= floor(($sizes_deb->{$a}/102.4)+0.5)/10;
346 $package_page .= "</td>\n<td>";
347 $package_page .= $sizes_inst->{$a};
348 $package_page .= "</td>\n</tr>";
350 $package_page .= "</table><p>".gettext ( "Size is measured in kBytes." )."</p>\n";
351 $package_page .= "</div> <!-- end pdownload -->\n";
356 $package_page .= pmoreinfo( name => $pkg, data => $page,
357 bugreports => 1, sourcedownload => 1,
358 changesandcopy => 0, 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