# 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+)$' },
#XXX: Don't use alternative output formats yet
$format = 'html';
if ($format eq 'html') {
- print $input->header;
+ print $input->header( -charset => 'utf-8' );
}
if ($params{errors}{keywords}) {
$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,
push @results, @{ do_names_search( $keyword, \%sources,
$sp_obj,
\&read_src_entry, \%opts ) };
+ } elsif ($searchon eq 'contents') {
+ require "./search_contents.pl";
+ &contents($input);
} else {
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, %archives, %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') {
+ my $real_archive;
+ if ($archive =~ /^(security|non-US)$/) {
+ $real_archive = $archive;
+ $archive = 'us';
+ }
+
+ $pkgs{$pkg}{$suite}{$archive}{$version}{$arch} = 1;
+ $subsect{$pkg}{$suite}{$archive}{$version} = $subsection;
+ $sect{$pkg}{$suite}{$archive}{$version} = $section
+ unless $section eq 'main';
+ $archives{$pkg}{$suite}{$archive}{$version} = $real_archive
+ if $real_archive;
+
+ $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 $count = 0;
+ #my ($start, $end) = multipageheader( $input, scalar @pkgs, \%opts );
+ print "<p>Found <em>".(scalar @pkgs)."</em> matching packages,";
+ #my $count = 0;
- foreach my $pkg (sort keys %pkgs) {
- $count++;
- next if $count < $start or $count > $end;
+ 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) {
+ next if $archive eq 'security';
+ next if $archive eq 'non-US';
+ my $path = $suite.(($archive ne 'us')?"/$archive":'');
+ if (exists $pkgs{$pkg}{$suite}{$archive}) {
+ my %archs_printed;
+ 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}{$archive}{$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) {
+ my $archive_str = "";
+ if ($archives{$pkg}{$suite}{$archive}{$v}) {
+ $archive_str .= " [<span style=\"color:red\">$archives{$pkg}{$suite}{$archive}{$v}</span>]";
+ }
+
+ my @archs_to_print = grep { !$archs_printed{$_} } sort keys %{$pkgs{$pkg}{$suite}{$archive}{$v}};
+ printf "<br>%s$archive_str: %s\n",
+ $v, join (" ", @archs_to_print )
+ if @archs_to_print;
+ $archs_printed{$_}++ foreach @archs_to_print;
+ }
+ 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
+ my $real_archive = '';
+ if ($archive =~ /^(security|non-US)$/) {
+ $real_archive = $archive;
+ $archive = 'us';
+ }
+ if (($real_archive eq $archive) &&
+ $pkgs{$pkg}{$suite}{$archive} &&
+ (version_cmp( $pkgs{$pkg}{$suite}{$archive}, $version ) >= 0)) {
+ next;
+ }
+ $pkgs{$pkg}{$suite}{$archive} = $version;
+ $subsect{$pkg}{$suite}{$archive}{source} = $subsection;
+ $sect{$pkg}{$suite}{$archive}{source} = $section
unless $section eq 'main';
+ $archives{$pkg}{$suite}{$archive}{source} = $real_archive
+ if $real_archive;
- $binaries{$pkg}{$suite} = find_binaries( $pkg, $suite, \%src2bin );
+ $binaries{$pkg}{$suite}{$archive} = find_binaries( $pkg, $archive, $suite, \%src2bin );
}
if ($opts{format} eq 'html') {
- my ($start, $end) = multipageheader( $input, scalar keys %pkgs, \%opts );
- my $count = 0;
+ #my ($start, $end) = multipageheader( $input, scalar keys %pkgs, \%opts );
+ print "<p>Found <em>".(scalar keys %pkgs)."</em> matching packages,";
+ #my $count = 0;
foreach my $pkg (sort keys %pkgs) {
- $count++;
- next if ($count < $start) or ($count > $end);
+ #$count++;
+ #next if ($count < $start) or ($count > $end);
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>]";
+ }
+ if ($archives{$pkg}{$suite}{$archive}{source}) {
+ $origin_str .= " [<span style=\"color:red\">$archives{$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";
}
}
}
- printindexline( $input, scalar keys %pkgs, \%opts );
+ #printindexline( $input, scalar keys %pkgs, \%opts );
}
#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 );
projects / deb / packages.git / blobdiff