# see http://www.fsf.org/copyleft/gpl.html for a copy of the license
use strict;
+use lib '../lib';
use CGI qw( -oldstyle_urls );
use CGI::Carp qw( fatalsToBrowser );
use POSIX;
use Benchmark;
use Deb::Versions;
+use Packages::Config qw( $DBDIR $ROOT $SEARCH_CGI $SEARCH_PAGE
+ @SUITES @SECTIONS @ARCHIVES @ARCHITECTURES );
use Packages::CGI;
+use Packages::DB;
use Packages::Search qw( :all );
use Packages::HTML ();
$debug = 0 if !defined($debug) || $debug !~ /^\d+$/o;
$Packages::CGI::debug = $debug;
-# read the configuration
-our $config_read_time ||= 0;
-our $db_read_time ||= 0;
-our $topdir;
-our $ROOT;
-our @SUITES;
-our @SECTIONS;
-our @ARCHITECTURES;
-
-# FIXME: move to own module
-my $modtime = (stat( "../config.sh" ))[9];
-if ($modtime > $config_read_time) {
- if (!open (C, '<', "../config.sh")) {
- error( "Internal Error: Cannot open configuration file." );
- }
- while (<C>) {
- chomp;
- $topdir = $1 if /^\s*topdir="?([^\"]*)"?\s*$/o;
- $ROOT = $1 if /^\s*root="?([^\"]*)"?\s*$/o;
- $Packages::HTML::HOME = $1 if /^\s*home="?([^\"]*)"?\s*$/o;
- $Packages::HTML::SEARCH_CGI = $1 if /^\s*searchcgi="?([^\"]*)"?\s*$/o;
- $Packages::HTML::SEARCH_PAGE = $1 if /^\s*searchpage="?([^\"]*)"?\s*$/o;
- $Packages::HTML::WEBMASTER_MAIL = $1 if /^\s*webmaster="?([^\"]*)"?\s*$/o;
- $Packages::HTML::CONTACT_MAIL = $1 if /^\s*contact="?([^\"]*)"?\s*$/o;
- @SUITES = split(/\s+/, $1) if /^\s*suites="?([^\"]*)"?\s*$/o;
- @SECTIONS = split(/\s+/, $1) if /^\s*sections="?([^\"]*)"?\s*$/o;
- @ARCHITECTURES = split(/\s+/, $1) if /^\s*architectures="?([^\"]*)"?\s*$/o;
- }
- close (C);
- debug( "read config ($modtime > $config_read_time)" );
- $config_read_time = $modtime;
-}
-my $DBDIR = $topdir . "/files/db";
-my $thisscript = $Packages::HTML::SEARCH_CGI;
+&Packages::Config::init( '../' );
+&Packages::DB::init();
if (my $path = $input->param('path')) {
my @components = map { lc $_ } split /\//, $path;
my %SUITES = map { $_ => 1 } @SUITES;
my %SECTIONS = map { $_ => 1 } @SECTIONS;
+ my %ARCHIVES = map { $_ => 1 } @ARCHIVES;
my %ARCHITECTURES = map { $_ => 1 } @ARCHITECTURES;
foreach (@components) {
$input->param('suite', $_);
} elsif ($SECTIONS{$_}) {
$input->param('section', $_);
- }elsif ($ARCHITECTURES{$_}) {
+ } elsif ($ARCHIVES{$_}) {
+ $input->param('archive', $_);
+ } elsif ($ARCHITECTURES{$_}) {
$input->param('arch', $_);
+ } elsif ($_ eq 'source') {
+ $input->param('searchon','sourcenames');
}
}
}
my ( $format, $keyword, $case, $subword, $exact, $searchon,
- @suites, @sections, @archs );
+ @suites, @sections, @archives, @archs );
my %params_def = ( keywords => { default => undef,
match => '^\s*([-+\@\w\/.:]+)\s*$',
var => \$keyword },
- suite => { default => 'stable', match => '^(\w+)$',
+ suite => { default => 'stable', match => '^([\w-]+)$',
alias => 'version', array => ',',
var => \@suites,
replace => { all => \@SUITES } },
+ archive => { default => 'all', match => '^([\w-]+)$',
+ array => ',', var => \@archives,
+ replace => { all => \@ARCHIVES } },
case => { default => 'insensitive', match => '^(\w+)$',
var => \$case },
official => { default => 0, match => '^(\w+)$' },
$exact = !$subword unless defined $exact;
$opts{h_suites} = { map { $_ => 1 } @suites };
$opts{h_sections} = { map { $_ => 1 } @sections };
+$opts{h_archives} = { map { $_ => 1 } @archives };
$opts{h_archs} = { map { $_ => 1 } @archs };
# for URL construction
my $st0 = new Benchmark;
my @results;
-our ($obj, $s_obj, $p_obj, $sp_obj,
- %packages, %sources, %postf, %spostf, %src2bin, %did2pkg );
-
unless (@Packages::CGI::fatal_errors) {
- my $dbmodtime = (stat("$DBDIR/packages_small.db"))[9];
- if ($dbmodtime > $db_read_time) {
- $obj = tie %packages, 'DB_File', "$DBDIR/packages_small.db",
- O_RDONLY, 0666, $DB_BTREE
- or die "couldn't tie DB $DBDIR/packages_small.db: $!";
- $s_obj = tie %sources, 'DB_File', "$DBDIR/sources_small.db",
- O_RDONLY, 0666, $DB_BTREE
- or die "couldn't tie DB $DBDIR/sources_small.db: $!";
- $p_obj = tie %postf, 'DB_File', "$DBDIR/package_postfixes.db",
- O_RDONLY, 0666, $DB_BTREE
- or die "couldn't tie postfix db $DBDIR/package_postfixes.db: $!";
- $sp_obj = tie %spostf, 'DB_File', "$DBDIR/source_postfixes.db",
- O_RDONLY, 0666, $DB_BTREE
- or die "couldn't tie postfix db $DBDIR/source_postfixes.db: $!";
- tie %src2bin, 'DB_File', "$DBDIR/sources_packages.db",
- O_RDONLY, 0666, $DB_BTREE
- or die "couldn't open $DBDIR/sources_packages.db: $!";
- tie %did2pkg, 'DB_File', "$DBDIR/descriptions_packages.db",
- O_RDONLY, 0666, $DB_BTREE
- or die "couldn't tie DB $DBDIR/descriptions_packages.db: $!";
-
- debug( "tied databases ($dbmodtime > $db_read_time)" );
- $db_read_time = $dbmodtime;
- }
-
if ($searchon eq 'names') {
push @results, @{ do_names_search( $keyword, \%packages,
$p_obj,
if ($exact) {
$printed++;
- hint( "You have searched only for exact matches of the package name. You can try to search for <a href=\"$thisscript?exact=0&searchon=$searchon&suite=$suites_param&case=$case&section=$sections_param&keywords=$keyword_esc&arch=$archs_param\">package names that contain your search string</a>." );
+ hint( "You have searched only for exact matches of the package name. You can try to search for <a href=\"$SEARCH_CGI?exact=0&searchon=$searchon&suite=$suites_param&case=$case&section=$sections_param&keywords=$keyword_esc&arch=$archs_param\">package names that contain your search string</a>." );
}
} else {
if (($suites_enc eq 'all')
unless ($subword) {
$printed++;
- hint( "You have searched only for words exactly matching your keywords. You can try to search <a href=\"$thisscript?subword=1&searchon=$searchon&suite=$suites_param&case=$case&section=$sections_param&keywords=$keyword_esc&arch=$archs_param\">allowing subword matching</a>." );
+ hint( "You have searched only for words exactly matching your keywords. You can try to search <a href=\"$SEARCH_CGI?subword=1&searchon=$searchon&suite=$suites_param&case=$case&section=$sections_param&keywords=$keyword_esc&arch=$archs_param\">allowing subword matching</a>." );
}
}
- hint( ( $printed ? "Or you" : "You" )." can try a different search on the <a href=\"$Packages::HTML::SEARCH_PAGE#search_packages\">Packages search page</a>." );
+ hint( ( $printed ? "Or you" : "You" )." can try a different search on the <a href=\"$SEARCH_PAGE#search_packages\">Packages search page</a>." );
}
}
print_hints();
print_debug();
if (@results) {
- my (%pkgs, %sect, %part, %desc, %binaries);
+ my (%pkgs, %subsect, %sect, %desc, %binaries, %provided_by);
unless ($opts{searchon} eq 'sourcenames') {
foreach (@results) {
- my ($pkg_t, $suite, $arch, $section, $subsection,
+ my ($pkg_t, $archive, $suite, $arch, $section, $subsection,
$priority, $version, $desc) = @$_;
my ($pkg) = $pkg_t =~ m/^(.+)/; # untaint
- $pkgs{$pkg}{$suite}{$version}{$arch} = 1;
- $sect{$pkg}{$suite}{$version} = $subsection;
- $part{$pkg}{$suite}{$version} = $section
- unless $section eq 'main';
-
- $desc{$pkg}{$suite}{$version} = $desc;
+ if ($arch ne 'virtual') {
+ $pkgs{$pkg}{$suite}{$archive}{$version}{$arch} = 1;
+ $subsect{$pkg}{$suite}{$archive}{$version} = $subsection;
+ $sect{$pkg}{$suite}{$archive}{$version} = $section
+ unless $section eq 'main';
+
+ $desc{$pkg}{$suite}{$archive}{$version} = $desc;
+ } else {
+ $provided_by{$pkg}{$suite}{$archive} = [ split /\s+/, $desc ];
+ }
}
+my @pkgs = sort(keys %pkgs, keys %provided_by);
if ($opts{format} eq 'html') {
- my ($start, $end) = multipageheader( $input, scalar keys %pkgs, \%opts );
+ my ($start, $end) = multipageheader( $input, scalar @pkgs, \%opts );
my $count = 0;
- foreach my $pkg (sort keys %pkgs) {
+ foreach my $pkg (@pkgs) {
$count++;
next if $count < $start or $count > $end;
printf "<h3>Package %s</h3>\n", $pkg;
print "<ul>\n";
foreach my $suite (@SUITES) {
- if (exists $pkgs{$pkg}{$suite}) {
- my @versions = version_sort keys %{$pkgs{$pkg}{$suite}};
- my $part_str = "";
- if ($part{$pkg}{$suite}{$versions[0]}) {
- $part_str = "[<span style=\"color:red\">$part{$pkg}{$suite}{$versions[0]}</span>]";
+ foreach my $archive (@ARCHIVES) {
+ my $path = $suite.(($archive ne 'us')?"/$archive":'');
+ if (exists $pkgs{$pkg}{$suite}{$archive}) {
+ my @versions = version_sort keys %{$pkgs{$pkg}{$suite}{$archive}};
+ my $origin_str = "";
+ if ($sect{$pkg}{$suite}{$archive}{$versions[0]}) {
+ $origin_str .= " [<span style=\"color:red\">$sect{$pkg}{$suite}{$versions[0]}</span>]";
+ }
+ printf "<li><a href=\"$ROOT/%s/%s\">%s</a> (%s): %s %s\n",
+ $path, $pkg, $path, $subsect{$pkg}{$suite}{$archive}{$versions[0]},
+ $desc{$pkg}{$suite}{$archive}{$versions[0]}, $origin_str;
+
+ foreach my $v (@versions) {
+ printf "<br>%s: %s\n",
+ $v, join (" ", (sort keys %{$pkgs{$pkg}{$suite}{$archive}{$v}}) );
+ }
+ if (my $provided_by = $provided_by{$pkg}{$suite}{$archive}) {
+ print '<br>also provided by: ',
+ join( ', ', map { "<a href=\"$ROOT/$path/$_\">$_</a>" } @$provided_by);
+ }
+ print "</li>\n";
+ } elsif (my $provided_by = $provided_by{$pkg}{$suite}{$archive}) {
+ printf "<li><a href=\"$ROOT/%s/%s\">%s</a>: Virtual package<br>",
+ $path, $pkg, $path;
+ print 'provided by: ',
+ join( ', ', map { "<a href=\"$ROOT/$path/$_\">$_</a>" } @$provided_by);
}
- printf "<li><a href=\"$ROOT/%s/%s\">%s</a> (%s): %s %s\n",
- $suite, $pkg, $suite, $sect{$pkg}{$suite}{$versions[0]},
- $desc{$pkg}{$suite}{$versions[0]}, $part_str;
-
- foreach my $v (@versions) {
- printf "<br>%s: %s\n",
- $v, join (" ", (sort keys %{$pkgs{$pkg}{$suite}{$v}}) );
- }
- print "</li>\n";
}
}
print "</ul>\n";
}
} else {
foreach (@results) {
- my ($pkg, $suite, $section, $subsection, $priority,
+ my ($pkg, $archive, $suite, $section, $subsection, $priority,
$version) = @$_;
- $pkgs{$pkg}{$suite} = $version;
- $sect{$pkg}{$suite}{source} = $subsection;
- $part{$pkg}{$suite}{source} = $section
+ $pkgs{$pkg}{$suite}{$archive} = $version;
+ $subsect{$pkg}{$suite}{$archive}{source} = $subsection;
+ $sect{$pkg}{$suite}{$archive}{source} = $section
unless $section eq 'main';
- $binaries{$pkg}{$suite} = find_binaries( $pkg, $suite, \%src2bin );
+ $binaries{$pkg}{$suite}{$archive} = find_binaries( $pkg, $archive, $suite, \%src2bin );
}
if ($opts{format} eq 'html') {
printf "<h3>Source package %s</h3>\n", $pkg;
print "<ul>\n";
foreach my $suite (@SUITES) {
- if (exists $pkgs{$pkg}{$suite}) {
- my $part_str = "";
- if ($part{$pkg}{$suite}{source}) {
- $part_str = "[<span style=\"color:red\">$part{$pkg}{$suite}{source}</span>]";
- }
- printf( "<li><a href=\"$ROOT/%s/source/%s\">%s</a> (%s): %s %s",
- $suite, $pkg, $suite, $sect{$pkg}{$suite}{source},
- $pkgs{$pkg}{$suite}, $part_str );
-
- print "<br>Binary packages: ";
- my @bp_links;
- foreach my $bp (@{$binaries{$pkg}{$suite}}) {
- my $bp_link = sprintf( "<a href=\"$ROOT/%s/%s\">%s</a>",
- $suite, uri_escape( $bp ), $bp );
- push @bp_links, $bp_link;
+ foreach my $archive (@ARCHIVES) {
+ if (exists $pkgs{$pkg}{$suite}{$archive}) {
+ my $origin_str = "";
+ if ($sect{$pkg}{$suite}{$archive}{source}) {
+ $origin_str .= " [<span style=\"color:red\">$sect{$pkg}{$suite}{$archive}{source}</span>]";
+ }
+ printf( "<li><a href=\"$ROOT/%s/source/%s\">%s</a> (%s): %s %s",
+ $suite.(($archive ne 'us')?"/$archive":''), $pkg, $suite.(($archive ne 'us')?"/$archive":''), $subsect{$pkg}{$suite}{$archive}{source},
+ $pkgs{$pkg}{$suite}{$archive}, $origin_str );
+
+ print "<br>Binary packages: ";
+ my @bp_links;
+ foreach my $bp (@{$binaries{$pkg}{$suite}{$archive}}) {
+ my $bp_link = sprintf( "<a href=\"$ROOT/%s/%s\">%s</a>",
+ $suite.(($archive ne 'us')?"/$archive":''), uri_escape( $bp ), $bp );
+ push @bp_links, $bp_link;
+ }
+ print join( ", ", @bp_links );
+ print "</li>\n";
}
- print join( ", ", @bp_links );
- print "</li>\n";
}
}
print "</ul>\n";
#print_results(\@results, \%opts) if @results;;
my $tet1 = new Benchmark;
my $tetd = timediff($tet1, $tet0);
-print "Total page evaluation took ".timestr($petd)."<br>"
+print "Total page evaluation took ".timestr($tetd)."<br>"
if $debug_allowed;
my $trailer = Packages::HTML::trailer( $ROOT );