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,
56 # FIXME: move to own module
57 my $modtime = (stat( "../config.sh" ))[9];
58 if ($modtime > $config_read_time) {
59 if (!open (C, '<', "../config.sh")) {
60 error( "Internal: Cannot open configuration file." );
65 $topdir = $1 if /^\s*topdir="?([^\"]*)"?\s*$/o;
66 $ROOT = $1 if /^\s*root="?([^\"]*)"?\s*$/o;
67 $Packages::HTML::HOME = $1 if /^\s*home="?([^\"]*)"?\s*$/o;
68 $Packages::HTML::SEARCH_CGI = $1 if /^\s*searchcgi="?([^\"]*)"?\s*$/o;
69 $Packages::HTML::SEARCH_PAGE = $1 if /^\s*searchpage="?([^\"]*)"?\s*$/o;
70 $Packages::HTML::WEBMASTER_MAIL = $1 if /^\s*webmaster="?([^\"]*)"?\s*$/o;
71 $Packages::HTML::CONTACT_MAIL = $1 if /^\s*contact="?([^\"]*)"?\s*$/o;
72 $Packages::HTML::BUG_URL = $1 if /^\s*bug_url="?([^\"]*)"?\s*$/o;
73 $Packages::HTML::SRC_BUG_URL = $1 if /^\s*src_bug_url="?([^\"]*)"?\s*$/o;
74 $Packages::HTML::QA_URL = $1 if /^\s*qa_url="?([^\"]*)"?\s*$/o;
75 $FTP_SITES{us} = $1 if /^\s*ftpsite="?([^\"]*)"?\s*$/o;
76 $FTP_SITES{$1} = $2 if /^\s*(\w+)_ftpsite="?([^\"]*)"?\s*$/o;
77 @SUITES = split(/\s+/, $1) if /^\s*suites="?([^\"]*)"?\s*$/o;
78 @SECTIONS = split(/\s+/, $1) if /^\s*sections="?([^\"]*)"?\s*$/o;
79 @ARCHIVES = split(/\s+/, $1) if /^\s*archives="?([^\"]*)"?\s*$/o;
80 @ARCHITECTURES = split(/\s+/, $1) if /^\s*architectures="?([^\"]*)"?\s*$/o;
83 debug( "read config ($modtime > $config_read_time)" );
84 $config_read_time = $modtime;
86 my $DBDIR = $topdir . "/files/db";
87 my $thisscript = $Packages::HTML::SEARCH_CGI;
89 if (my $path = $input->param('path')) {
90 my @components = map { lc $_ } split /\//, $path;
92 my %SUITES = map { $_ => 1 } @SUITES;
93 my %SECTIONS = map { $_ => 1 } @SECTIONS;
94 my %ARCHIVES = map { $_ => 1 } @ARCHIVES;
95 my %ARCHITECTURES = map { $_ => 1 } @ARCHITECTURES;
97 foreach (@components) {
99 $input->param('suite', $_);
100 } elsif ($SECTIONS{$_}) {
101 $input->param('section', $_);
102 } elsif ($ARCHIVES{$_}) {
103 $input->param('archive', $_);
104 } elsif ($ARCHITECTURES{$_}) {
105 $input->param('arch', $_);
110 my ( $pkg, $suite, $format );
111 my %params_def = ( package => { default => undef, match => '^([a-z0-9.+-]+)$',
113 suite => { default => undef, match => '^(\w+)$',
115 format => { default => 'html', match => '^(\w+)$',
119 my %params = Packages::Search::parse_params( $input, \%params_def, \%opts );
121 $opts{h_suites} = { $suite => 1 };
122 $opts{h_archs} = { map { $_ => 1 } @ARCHITECTURES };
123 $opts{h_sections} = { map { $_ => 1 } @SECTIONS };
124 $opts{h_archives} = { map { $_ => 1 } @ARCHIVES };
126 #XXX: Don't use alternative output formats yet
128 if ($format eq 'html') {
129 print $input->header;
132 if ($params{errors}{package}) {
133 fatal_error( "package not valid or not specified" );
135 if ($params{errors}{suite}) {
136 fatal_error( "suite not valid or not specified" );
139 my $DL_URL = "$pkg/download";
140 my $FILELIST_URL = "$pkg/files";
141 my $DDPO_URL = "http://qa.debian.org/developer.php?email=";
143 our (%packages, %packages_all, %sources_all, %descriptions);
144 my (@results, @non_results);
145 my $page = new Packages::Page( $pkg );
146 my $package_page = "";
147 my ($short_desc, $version, $archive, $section, $subsection) = ("")x5;
149 sub gettext { return $_[0]; };
151 my $st0 = new Benchmark;
152 unless (@Packages::CGI::fatal_errors) {
153 my $dbmodtime = (stat("$DBDIR/packages_small.db"))[9];
154 if ($dbmodtime > $db_read_time) {
155 tie %packages, 'DB_File', "$DBDIR/packages_small.db",
156 O_RDONLY, 0666, $DB_BTREE
157 or die "couldn't tie DB $DBDIR/packages_small.db: $!";
158 tie %packages_all, 'DB_File', "$DBDIR/packages_all_$suite.db",
159 O_RDONLY, 0666, $DB_BTREE
160 or die "couldn't tie DB $DBDIR/packages_all_$suite.db: $!";
161 tie %sources_all, 'DB_File', "$DBDIR/sources_all_$suite.db",
162 O_RDONLY, 0666, $DB_BTREE
163 or die "couldn't tie DB $DBDIR/sources_all_$suite.db: $!";
164 tie %descriptions, 'DB_File', "$DBDIR/descriptions.db",
165 O_RDONLY, 0666, $DB_BTREE
166 or die "couldn't tie DB $DBDIR/descriptions.db: $!";
168 debug( "tied databases ($dbmodtime > $db_read_time)" );
169 $db_read_time = $dbmodtime;
172 read_entry_all( \%packages, $pkg, \@results, \@non_results, \%opts );
174 unless (@results || @non_results ) {
175 fatal_error( "No such package".
176 "{insert link to search page with substring search}" );
179 fatal_error( "Package not available in this suite" );
181 for my $entry (@results) {
182 debug( join(":", @$entry), 1 );
183 my (undef, $archive, undef, $arch, $section, $subsection,
184 $priority, $version) = @$entry;
186 my $data = $packages_all{"$pkg $arch $version"};
187 $page->merge_data($pkg, $version, $arch, $data) or debug( "Merging $pkg $arch $version FAILED", 2 );
190 $version = $page->{newest};
191 my $source = $page->get_newest( 'source' );
192 my $source_version = $page->get_newest( 'source-version' )
194 my $src_data = $sources_all{"$source $source_version"};
195 unless ($src_data) { #fucking binNMUs
196 my $versions = $page->get_versions;
197 my $sources = $page->get_arch_field( 'source' );
198 my $source_versions = $page->get_arch_field( 'source-version' );
199 foreach (version_sort keys %$versions) {
200 $source = $sources->{$versions->{$_}[0]};
201 $source = $source_versions->{$versions->{$_}[0]}
203 $src_data = $sources_all{"$source $source_version"};
206 error( "couldn't find source package" ) unless $src_data;
208 $page->add_src_data( $source, $source_version, $src_data );
210 my $st1 = new Benchmark;
211 my $std = timediff($st1, $st0);
212 debug( "Data search and merging took ".timestr($std) );
214 my $encodedpkg = uri_escape( $pkg );
215 my ($v_str, $v_str_arch, $v_str_arr) = $page->get_version_string();
216 my $did = $page->get_newest( 'description' );
217 $archive = $page->get_newest( 'archive' );
218 $section = $page->get_newest( 'section' );
219 $subsection = $page->get_newest( 'subsection' );
220 my $filenames = $page->get_arch_field( 'filename' );
221 my $file_md5sums = $page->get_arch_field( 'md5sum' );
222 my $archives = $page->get_arch_field( 'archive' );
223 my $sizes_inst = $page->get_arch_field( 'installed-size' );
224 my $sizes_deb = $page->get_arch_field( 'size' );
225 my @archs = sort $page->get_architectures;
227 # process description
229 my $desc = $descriptions{$did};
230 $short_desc = encode_entities( $1, "<>&\"" )
231 if $desc =~ s/^(.*)$//m;
232 my $long_desc = encode_entities( $desc, "<>&\"" );
234 $long_desc =~ s,((ftp|http|https)://[\S~-]+?/?)((\>\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go; # syntax highlighting -> '];
235 $long_desc =~ s/\A //o;
236 $long_desc =~ s/\n /\n/sgo;
237 $long_desc =~ s/\n.\n/\n<p>\n/go;
238 $long_desc =~ s/(((\n|\A) [^\n]*)+)/\n<pre>$1\n<\/pre>/sgo;
239 # $long_desc = conv_desc( $lang, $long_desc );
240 # $short_desc = conv_desc( $lang, $short_desc );
242 my %all_suites = map { $_->[2] => 1 } (@results, @non_results);
243 foreach (suites_sort(keys %all_suites)) {
245 $package_page .= "[ <strong>$_</strong> ] ";
248 "[ <a href=\"../$_/".uri_escape($pkg)."\">$_</a> ] ";
252 $package_page .= simple_menu( [ gettext( "Distribution:" ),
253 gettext( "Overview over this suite" ),
256 [ gettext( "Section:" ),
257 gettext( "All packages in this section" ),
258 "/$suite/$subsection/",
262 my $title .= sprintf( gettext( "Package: %s (%s)" ), $pkg, $v_str );
263 $title .= " ".marker( $archive ) if $archive ne 'us';
264 $title .= " ".marker( $section ) if $section ne 'main';
265 $package_page .= title( $title );
267 $package_page .= "<h2>".gettext( "Versions:" )." $v_str_arch</h2>\n"
268 unless $version eq $v_str;
270 if ($suite eq "experimental") {
271 $package_page .= note( gettext( "Experimental package"),
272 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>".
273 gettext( "Users of experimental packages are encouraged to contact the package maintainers directly in case of problems." )
276 if ($subsection eq "debian-installer") {
277 note( gettext( "debian-installer udeb package"),
278 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." )
281 $package_page .= pdesc( $short_desc, $long_desc );
284 # display dependencies
287 $dep_list = print_deps( \%packages, \%opts, $pkg,
288 $page->get_dep_field('depends'),
290 $dep_list .= print_deps( \%packages, \%opts, $pkg,
291 $page->get_dep_field('recommends'),
293 $dep_list .= print_deps( \%packages, \%opts, $pkg,
294 $page->get_dep_field('suggests'),
298 $package_page .= "<div id=\"pdeps\">\n";
299 $package_page .= sprintf( "<h2>".gettext( "Other Packages Related to %s" )."</h2>\n", $pkg );
300 if ($suite eq "experimental") {
301 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." ) );
304 $package_page .= pdeplegend( [ 'dep', gettext( 'depends' ) ],
305 [ 'rec', gettext( 'recommends' ) ],
306 [ 'sug', gettext( 'suggests' ) ], );
308 $package_page .= $dep_list;
309 $package_page .= "</div> <!-- end pdeps -->\n";
315 my $encodedpack = uri_escape( $pkg );
316 $package_page .= "<div id=\"pdownload\">";
317 $package_page .= sprintf( "<h2>".gettext( "Download %s\n" )."</h2>",
319 $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";
320 $package_page .= "<caption class=\"hidecss\">".gettext("Download for all available architectures")."</caption>\n";
321 $package_page .= "<tr>\n";
322 $package_page .= "<th>".gettext("Architecture")."</th><th>".gettext("Files")."</th><th>".gettext( "Package Size")."</th><th>".gettext("Installed Size")."</th></tr>\n";
323 foreach my $a ( @archs ) {
324 $package_page .= "<tr>\n";
325 $package_page .= "<th><a href=\"$DL_URL?arch=$a";
326 $package_page .= "&file=".uri_escape($filenames->{$a});
327 $package_page .= "&md5sum=$file_md5sums->{$a}";
328 $package_page .= "&arch=$a";
329 # there was at least one package with two
330 # different source packages on different
331 # archs where one had a security update
332 # and the other one not
333 for ($archives->{$a}) {
335 $package_page .= "&type=security"; last };
337 $package_page .= "&type=volatile"; last };
339 $package_page .= "&type=nonus"; last };
340 $package_page .= "&type=main";
342 $package_page .= "\">$a</a></th>\n";
343 $package_page .= "<td>";
344 if ( $suite ne "experimental" ) {
345 $package_page .= sprintf( "[<a href=\"%s\">".gettext( "list of files" )."</a>]\n", "$FILELIST_URL$encodedpkg&version=$suite&arch=$a", $pkg );
347 $package_page .= gettext( "no current information" );
349 $package_page .= "</td>\n<td>";
350 $package_page .= floor(($sizes_deb->{$a}/102.4)+0.5)/10;
351 $package_page .= "</td>\n<td>";
352 $package_page .= $sizes_inst->{$a};
353 $package_page .= "</td>\n</tr>";
355 $package_page .= "</table><p>".gettext ( "Size is measured in kBytes." )."</p>\n";
356 $package_page .= "</div> <!-- end pdownload -->\n";
361 $package_page .= pmoreinfo( name => $pkg, data => $page,
363 bugreports => 1, sourcedownload => 1,
364 changesandcopy => 1, maintainers => 1,
371 debug( "Final page object:\n".Dumper($page), 3 );
373 print Packages::HTML::header( title => "Details of package <em>$pkg</em> in $suite" ,
376 keywords => "$suite, $archive, $section, $subsection, $version",
377 title_tag => "Details of package $pkg in $suite",
386 unless (@Packages::CGI::fatal_errors) {
389 my $tet1 = new Benchmark;
390 my $tetd = timediff($tet1, $tet0);
391 print "Total page evaluation took ".timestr($tetd)."<br>"
394 my $trailer = Packages::HTML::trailer( $ROOT );
395 $trailer =~ s/LAST_MODIFIED_DATE/gmtime()/e; #FIXME