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 );
27 use Packages::HTML ();
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 @SUITES = split(/\s+/, $1) if /^\s*suites="?([^\"]*)"?\s*$/o;
72 @SECTIONS = split(/\s+/, $1) if /^\s*sections="?([^\"]*)"?\s*$/o;
73 @ARCHIVES = split(/\s+/, $1) if /^\s*archives="?([^\"]*)"?\s*$/o;
74 @ARCHITECTURES = split(/\s+/, $1) if /^\s*architectures="?([^\"]*)"?\s*$/o;
77 debug( "read config ($modtime > $config_read_time)" );
78 $config_read_time = $modtime;
80 my $DBDIR = $topdir . "/files/db";
81 my $thisscript = $Packages::HTML::SEARCH_CGI;
83 if (my $path = $input->param('path')) {
84 my @components = map { lc $_ } split /\//, $path;
86 my %SUITES = map { $_ => 1 } @SUITES;
87 my %SECTIONS = map { $_ => 1 } @SECTIONS;
88 my %ARCHIVES = map { $_ => 1 } @ARCHIVES;
89 my %ARCHITECTURES = map { $_ => 1 } @ARCHITECTURES;
91 foreach (@components) {
93 $input->param('suite', $_);
94 }# elsif ($SECTIONS{$_}) {
95 # $input->param('section', $_);
96 # } elsif ($ARCHIVES{$_}) {
97 # $input->param('archive', $_);
98 # } elsif ($ARCHITECTURES{$_}) {
99 # $input->param('arch', $_);
104 my ( $pkg, $suite, $format );
105 my %params_def = ( package => { default => undef, match => '^([a-z0-9.+-]+)$',
107 suite => { default => undef, match => '^(\w+)$',
109 format => { default => 'html', match => '^(\w+)$',
113 my %params = Packages::Search::parse_params( $input, \%params_def, \%opts );
115 $opts{h_suites} = { $suite => 1 };
116 $opts{h_archs} = { map { $_ => 1 } @ARCHITECTURES };
117 $opts{h_sections} = { map { $_ => 1 } @SECTIONS };
118 $opts{h_archives} = { map { $_ => 1 } @ARCHIVES };
120 #XXX: Don't use alternative output formats yet
122 if ($format eq 'html') {
123 print $input->header;
126 if ($params{errors}{package}) {
127 fatal_error( "package not valid or not specified" );
129 if ($params{errors}{suite}) {
130 fatal_error( "suite not valid or not specified" );
133 my $DL_URL = "$pkg/download";
134 my $FILELIST_URL = "$pkg/files";
135 my $DDPO_URL = "http://qa.debian.org/developer.php?email=";
137 our (%packages, %packages_all);
138 my (@results, @non_results);
140 unless (@Packages::CGI::fatal_errors) {
141 my $dbmodtime = (stat("$DBDIR/packages_small.db"))[9];
142 if ($dbmodtime > $db_read_time) {
143 tie %packages, 'DB_File', "$DBDIR/packages_small.db",
144 O_RDONLY, 0666, $DB_BTREE
145 or die "couldn't tie DB $DBDIR/packages_small.db: $!";
146 tie %packages_all, 'DB_File', "$DBDIR/packages_all_$suite.db",
147 O_RDONLY, 0666, $DB_BTREE
148 or die "couldn't tie DB $DBDIR/packages_all_$suite.db: $!";
149 debug( "tied databases ($dbmodtime > $db_read_time)" );
150 $db_read_time = $dbmodtime;
153 read_entry_all( \%packages, $pkg, \@results, \@non_results, \%opts );
155 unless (@results || @non_results ) {
156 fatal_error( "No such package".
157 "{insert link to search page with substring search}" );
160 fatal_error( "Package not available in this suite" );
165 print Packages::HTML::header( title => "Details of package <em>$pkg</em> in $suite" ,
167 title_tag => "Details of package $pkg in $suite",
168 print_title_above => 1
176 unless (@Packages::CGI::fatal_errors) {
178 my %all_suites = map { $_->[2] => 1 } (@results, @non_results);
179 foreach (suites_sort(keys %all_suites)) {
181 print "<strong>$_</strong> | ";
183 print "<a href=\"../$_/".uri_escape($pkg)."\">$_</a> | ";
188 my $page = new Packages::Page( $pkg );
190 for my $entry (@results) {
191 print join ":", @$entry;
193 my (undef, $archive, undef, $arch, $section, $subsection,
194 $priority, $version) = @$entry;
195 print "<pre>".$packages_all{"$pkg $arch $version"}."</pre>";
198 # my %versions = $pkg->get_arch_versions( $env->{archs} );
199 # my %subsuites = $pkg->get_arch_fields( 'subdistribution',
201 # my %filenames = $pkg->get_arch_fields( 'filename',
203 # my %file_md5s = $pkg->get_arch_fields( 'md5sum',
206 # my $subsuite_kw = $d->{subsuite} || $env->{distribution};
207 # my $size_kw = exists $d->{sizes_deb}{i386} ? $d->{sizes_deb}{i386} : first_val($d->{sizes_deb});
210 # foreach my $lang (@{$env->{langs}}) {
211 # &Generated::Strings::string_lang($lang);
213 # my $dirname = "$env->{dest_dir}/$d->{subsection}";
214 # my $filename = "$dirname/$name.$lang.html";
216 # unless (( $lang eq 'en' )
217 # || $env->{db}->is_translated( $name, $d->{version},
218 # ${$versions{v2a}{$d->{version}}}[0],
222 # progress() if $env->{opts}{progress};
225 # # process description
227 # my $short_desc = encode_entities( $env->{db}->get_short_desc( $d->{desc_md5},
228 # $lang ), "<>&\"" );
229 # my $long_desc = encode_entities( $env->{db}->get_long_desc( $d->{desc_md5},
230 # $lang ), "<>&\"" );
232 # $long_desc =~ s,((ftp|http|https)://[\S~-]+?/?)((\>\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go; # syntax highlighting -> '];
233 # $long_desc =~ s/\A //o;
234 # $long_desc =~ s/\n /\n/sgo;
235 # $long_desc =~ s/\n.\n/\n<p>\n/go;
236 # $long_desc =~ s/(((\n|\A) [^\n]*)+)/\n<pre>$1\n<\/pre>/sgo;
238 # $long_desc = conv_desc( $lang, $long_desc );
239 # $short_desc = conv_desc( $lang, $short_desc );
244 # my $package_page = header( title => $name, lang => $lang,
245 # desc => $short_desc,
246 # keywords => "$env->{distribution}, $subsuite_kw, $d->{section}, $d->{subsection}, size:$size_kw $d->{version}" );
247 # $package_page .= simple_menu( [ gettext( "Distribution:" ),
248 # gettext( "Overview over this distribution" ),
250 # $env->{distribution} ],
251 # [ gettext( "Section:" ),
252 # gettext( "All packages in this section" ),
253 # "../$d->{subsection}/",
254 # $d->{subsection} ],
257 # my $title .= sprintf( gettext( "Package: %s (%s)" ), $name, $d->{v_str_simple} );
258 # $title .= " ".marker( $d->{subsuite} ) if $d->{subsuite};
259 # $title .= " ".marker( $d->{section} ) if $d->{section} ne 'main';
260 # $package_page .= title( $title );
262 # $package_page .= "<h2>".gettext( "Versions:" )." $d->{v_str_arch}</h2>\n"
263 # unless $d->{version} eq $d->{v_str_simple};
265 # if ($env->{distribution} eq "experimental") {
266 # $package_page .= note( gettext( "Experimental package"),
267 # 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>".
268 # gettext( "Users of experimental packages are encouraged to contact the package maintainers directly in case of problems." )
271 # if ($d->{section} eq "debian-installer") {
272 # $package_page .= note( gettext( "debian-installer udeb package"),
273 # 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." )
276 # $package_page .= pdesc( $short_desc, $long_desc );
279 # # display dependencies
281 # my $dep_list = print_deps( $env, $lang, $pkg, $d->{depends}, 'depends' );
282 # $dep_list .= print_deps( $env, $lang, $pkg, $d->{recommends}, 'recommends' );
283 # $dep_list .= print_deps( $env, $lang, $pkg, $d->{suggests}, 'suggests' );
286 # $package_page .= "<div id=\"pdeps\">\n";
287 # $package_page .= sprintf( "<h2>".gettext( "Other Packages Related to %s" )."</h2>\n", $name );
288 # if ($env->{distribution} eq "experimental") {
289 # $package_page .= 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." ) );
292 # $package_page .= pdeplegend( [ 'dep', gettext( 'depends' ) ],
293 # [ 'rec', gettext( 'recommends' ) ],
294 # [ 'sug', gettext( 'suggests' ) ], );
296 # $package_page .= $dep_list;
297 # $package_page .= "</div> <!-- end pdeps -->\n";
303 # my $encodedpack = uri_escape( $name );
304 # $package_page .= "<div id=\"pdownload\">";
305 # $package_page .= sprintf( "<h2>".gettext( "Download %s\n" )."</h2>",
307 # $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";
308 # $package_page .= "<caption class=\"hidecss\">".gettext("Download for all available architectures")."</caption>\n";
309 # $package_page .= "<tr>\n";
310 # $package_page .= "<th>".gettext("Architecture")."</th><th>".gettext("Files")."</th><th>".gettext( "Package Size")."</th><th>".gettext("Installed Size")."</th></tr>\n";
311 # foreach my $a ( @all_archs ) {
312 # if ( exists $versions{a2v}{$a} ) {
313 # $package_page .= "<tr>\n";
314 # $package_page .= "<th><a href=\"$DL_URL?arch=$a";
315 # # \&\;file=\" method=\"post\">\n<p>";
316 # $package_page .= "&file=".uri_escape($filenames{a2f}->{$a});
317 # $package_page .= "&md5sum=$file_md5s{a2f}->{$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 # if ($subsuites{a2f}{$a}
324 # && ($subsuites{a2f}{$a} =~ /security/o) ) {
325 # $package_page .= "&type=security";
326 # } elsif ($subsuites{a2f}{$a}
327 # && ($subsuites{a2f}{$a} =~ /volatile/o) ) {
328 # $package_page .= "&type=volatile";
329 # } elsif ($d->{is_nonus}) {
330 # $package_page .= "&type=nonus";
332 # $package_page .= "&type=main";
334 # $package_page .= "\">$a</a></th>\n";
335 # $package_page .= "<td>";
336 # if ( $env->{distribution} ne "experimental" ) {
337 # $package_page .= sprintf( "[<a href=\"%s\">".gettext( "list of files" )."</a>]\n", "$FILELIST_URL$encodedpack&version=$env->{distribution}&arch=$a", $name );
339 # $package_page .= "no files";
341 # $package_page .= "</td>\n<td>";
342 # my $size = $d->{sizes_deb}{$a};
343 # $package_page .= "$size";
344 # $package_page .= "</td>\n<td>";
345 # my $inst_size = $d->{sizes_inst}{$a};
346 # $package_page .= "$inst_size";
347 # $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 => $name, env => $env, data => $d,
357 # bugreports => 1, sourcedownload => 1,
358 # changesandcopy => 1, maintainers => 1,
365 # foreach my $l (@{$env->{langs}}) {
366 # next if $l eq $lang;
367 # push @tr_langs, $l if ( $l eq 'en' )
368 # || $env->{db}->is_translated( $name, $d->{version},
369 # ${$versions{v2a}{$d->{version}}}[0],
372 # $package_page .= trailer( '../..', $name, $lang, @tr_langs );
376 my $tet1 = new Benchmark;
377 my $tetd = timediff($tet1, $tet0);
378 print "Total page evaluation took ".timestr($tetd)."<br>"
381 my $trailer = Packages::HTML::trailer( $ROOT );
382 $trailer =~ s/LAST_MODIFIED_DATE/gmtime()/e; #FIXME