X-Git-Url: https://git.deb.at/?a=blobdiff_plain;f=cgi-bin%2Fsearch_packages.pl;h=6497f0610250cf8b6bbeeb201e001758e6a07837;hb=2f4ce394d77ced790c9550044a3638df660cc989;hp=e5bcae588de9ea1205dda557e7831aeae86aeea9;hpb=65ac54e423b34976913aa218301a02b3f7dda4eb;p=deb%2Fpackages.git
diff --git a/cgi-bin/search_packages.pl b/cgi-bin/search_packages.pl
index e5bcae5..6497f06 100755
--- a/cgi-bin/search_packages.pl
+++ b/cgi-bin/search_packages.pl
@@ -1,5 +1,5 @@
#!/usr/bin/perl -wT
-#
+# $Id$
# search_packages.pl -- CGI interface to the Packages files on packages.debian.org
#
# Copyright (C) 1998 James Treacy
@@ -20,52 +20,72 @@ use HTML::Entities;
use DB_File;
use Benchmark;
-use lib "../lib";
-
use Deb::Versions;
+use Packages::CGI;
use Packages::Search qw( :all );
use Packages::HTML ();
-my $thisscript = $Packages::HTML::SEARCH_CGI;
-my $HOME = "http://www.debian.org";
-my $ROOT = "";
-my $SEARCHPAGE = "http://packages.debian.org/";
-my @SUITES = qw( oldstable stable testing unstable experimental );
-my @DISTS = @SUITES;
-my @SECTIONS = qw( main contrib non-free );
-my @ARCHIVES = qw( us security installer );
-my @ARCHITECTURES = qw( alpha amd64 arm hppa hurd-i386 i386 ia64
- kfreebsd-i386 mips mipsel powerpc s390 sparc );
-my %SUITES = map { $_ => 1 } @SUITES;
-my %SECTIONS = map { $_ => 1 } @SECTIONS;
-my %ARCHIVES = map { $_ => 1 } @ARCHIVES;
-my %ARCHITECTURES = map { $_ => 1 } @ARCHITECTURES;
+&Packages::CGI::reset;
$ENV{PATH} = "/bin:/usr/bin";
# Read in all the variables set by the form
my $input;
-if ($ARGV[0] eq 'php') {
+if ($ARGV[0] && ($ARGV[0] eq 'php')) {
$input = new CGI(\*STDIN);
} else {
$input = new CGI;
}
my $pet0 = new Benchmark;
+my $tet0 = new Benchmark;
# use this to disable debugging in production mode completly
my $debug_allowed = 1;
my $debug = $debug_allowed && $input->param("debug");
-$debug = 0 if not defined($debug);
-$Search::Param::debug = 1 if $debug > 1;
+$debug = 0 if !defined($debug) || $debug !~ /^\d+$/o;
+$Packages::CGI::debug = $debug;
-# If you want, just print out a list of all of the variables and exit.
-print $input->header if $debug;
-# print $input->dump;
-# exit;
+# read the configuration
+our $config_read_time ||= 0;
+our $db_read_time ||= 0;
+our ( $topdir, $ROOT, @SUITES, @SECTIONS, @ARCHIVES, @ARCHITECTURES );
+
+# FIXME: move to own module
+my $modtime = (stat( "../config.sh" ))[9];
+if ($modtime > $config_read_time) {
+ if (!open (C, '<', "../config.sh")) {
+ error( "Internal: Cannot open configuration file." );
+ }
+ while ( You have searched for ${source_wording}packages $exact_wording $keyword_enc in $suite_wording, $section_wording, and $arch_wording. You have searched for $keyword_enc in packages names and descriptions in $suite_wording, $section_wording, and $arch_wording$exact_wording. Your search was too wide so we will only display exact matches. At least $too_many_hits results have been omitted and will not be displayed. Please consider using a longer keyword or more keywords. Can't find that package. Can't find that package, at least not in that suite ".
- ( $search_on_sources ? "" : " and on that architecture" ).
- ". You have searched only for exact matches of the package name. You can try to search for package names that contain your search string. Can't find that string. Can't find that string, at least not in that suite ($suites_enc, section $sections_enc) and on that architecture ($archs_enc). You have searched only for words exactly matching your keywords. You can try to search allowing subword matching. ".( $printed ? "Or you" : "You" )." can try a different search on the Packages search page. $index_line Found $no_results matching packages,";
- if ($end == $start) {
- print " displaying package $end.
" if $debug;
-
-if ($format eq 'html') {
-print Packages::HTML::header( title => 'Package Search Results' ,
- lang => 'en',
- title_tag => 'Debian Package Search Results',
- print_title_above => 1,
- print_search_field => 'packages',
- search_field_values => {
- keywords => $keyword_enc,
- searchon => $searchon,
- arch => $archs_enc,
- suite => $suites_enc,
- section => $sections_enc,
- subword => $subword,
- exact => $exact,
- case => $case,
- },
- );
-}
-
-# read the configuration
-my $topdir;
-if (!open (C, "../config.sh")) {
- print "\nInternal Error: Cannot open configuration file.\n\n"
-if $format eq 'html';
- exit 0;
-}
-while (
" if $debug > 2;
-
-sub read_entry {
- my ($hash, $key, $results) = @_;
- my $result = $hash->{$key};
- foreach (split /\000/, $result) {
- my @data = split ( /\s/, $_, 7 );
- print "DEBUG: Considering entry ".join( ':', @data)."
" if $debug > 2;
- if ($suites{$data[0]} && ($archs{$data[1]} || $data[1] eq 'all')
- && $sections{$data[2]}) {
- print "DEBUG: Using entry ".join( ':', @data)."
" if $debug > 2;
- push @$results, [ $key, @data ];
- }
- }
-}
-sub read_src_entry {
- my ($hash, $key, $results) = @_;
- my $result = $hash->{$key};
-
- foreach (split /\000/, $result) {
- my @data = split ( /\s/, $_, 5 );
- print "DEBUG: Considering entry ".join( ':', @data)."
" if $debug > 2;
- if ($suites{$data[0]} && $sections{$data[1]}) {
- print "DEBUG: Using entry ".join( ':', @data)."
" if $debug > 2;
- push @$results, [ $key, @data ];
- }
- }
-}
-sub do_names_search {
- my ($keyword, $file, $postfix_file, $read_entry) = @_;
-
- $keyword = lc $keyword unless $case_bool;
-
- my $obj = tie my %packages, 'DB_File', "$DBDIR/$file", O_RDONLY, 0666, $DB_BTREE
- or die "couldn't tie DB $DBDIR/$file: $!";
-
- if ($exact) {
- &$read_entry( \%packages, $keyword, \@results );
- } else {
- my ($key, $prefixes) = ($keyword, '');
- my %pkgs;
- my $p_obj = tie my %pref, 'DB_File', "$DBDIR/$postfix_file", O_RDONLY, 0666, $DB_BTREE
- or die "couldn't tie postfix db $DBDIR/$postfix_file: $!";
- $p_obj->seq( $key, $prefixes, R_CURSOR );
- while (index($key, $keyword) >= 0) {
- if ($prefixes =~ /^\001(\d+)/o) {
- $too_many_hits += $1;
- } else {
- foreach (split /\000/o, $prefixes) {
- $_ = '' if $_ eq '^';
- print "DEBUG: add word $_$key
" if $debug > 2;
- $pkgs{$_.$key}++;
- }
- }
- last if $p_obj->seq( $key, $prefixes, R_NEXT ) != 0;
- last if $too_many_hits or keys %pkgs >= 100;
- }
-
- my $no_results = keys %pkgs;
- if ($too_many_hits || ($no_results >= 100)) {
- $too_many_hits += $no_results;
- %pkgs = ( $keyword => 1 );
- }
- foreach my $pkg (sort keys %pkgs) {
- &$read_entry( \%packages, $pkg, \@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') {
- do_names_search( $keyword, 'packages_small.db',
- 'package_postfixes.db', \&read_entry );
-} elsif ($searchon eq 'sourcenames') {
- do_names_search( $keyword, 'sources_small.db',
- 'source_postfixes.db', \&read_src_entry );
-} else {
-
- my @lines;
- my $regex;
- if ($case_bool) {
- if ($exact) {
- $regex = qr/\b\Q$keyword\E\b/o;
- } else {
- $regex = qr/\Q$keyword\E/o;
- }
+ if ($searchon eq 'names') {
+ push @results, @{ do_names_search( $keyword, \%packages,
+ $p_obj,
+ \&read_entry, \%opts ) };
+ } elsif ($searchon eq 'sourcenames') {
+ push @results, @{ do_names_search( $keyword, \%sources,
+ $sp_obj,
+ \&read_src_entry, \%opts ) };
} else {
- if ($exact) {
- $regex = qr/\b\Q$keyword\E\b/io;
- } else {
- $regex = qr/\Q$keyword\E/io;
- }
- }
-
- open DESC, '<', "$DBDIR/descriptions.txt" or die "couldn't open $DBDIR/descriptions.txt: $!";
- while (
" if $debug > 2;
- push @lines, $.;
- }
- close DESC;
-
- my $obj = tie my %packages, 'DB_File', "$DBDIR/packages_small.db", O_RDONLY, 0666, $DB_BTREE
- or die "couldn't tie DB $DBDIR/packages_small.db: $!";
- my $obj = tie my %did2pkg, 'DB_File', "$DBDIR/descriptions_packages.db", O_RDONLY, 0666, $DB_BTREE
- or die "couldn't tie DB $DBDIR/descriptions_packages.db: $!";
-
- my %tmp_results;
- foreach my $l (@lines) {
- my $result = $did2pkg{$l};
- foreach (split /\000/o, $result) {
- my @data = split /\s/, $_, 3;
- next unless $archs{$data[2]};
- $tmp_results{$data[0]}++;
- }
- }
- foreach my $pkg (keys %tmp_results) {
- read_entry( \%packages, $pkg, \@results );
+ push @results, @{ do_names_search( $keyword, \%packages,
+ $p_obj,
+ \&read_entry, \%opts ) };
+ push @results, @{ do_fulltext_search( $keyword, "$DBDIR/descriptions.txt",
+ \%did2pkg,
+ \%packages,
+ \&read_entry, \%opts ) };
}
}
my $st1 = new Benchmark;
my $std = timediff($st1, $st0);
-print "DEBUG: Search took ".timestr($std)."
" if $debug;
+debug( "Search took ".timestr($std) );
if ($format eq 'html') {
my $suite_wording = $suites_enc eq "all" ? "all suites"
@@ -324,20 +232,20 @@ if ($format eq 'html') {
my $arch_wording = $archs_enc eq 'any' ? "all architectures"
: "architecture(s) $archs_enc";
if (($searchon eq "names") || ($searchon eq 'sourcenames')) {
- my $source_wording = $search_on_sources ? "source " : "";
+ my $source_wording = ( $searchon eq 'sourcenames' ) ? "source " : "";
my $exact_wording = $exact ? "named" : "that names contain";
- print "Package %s
\n", $pkg;
- print "\n";
- foreach my $ver (@SUITES) {
- if (exists $pkgs{$pkg}{$ver}) {
- my @versions = version_sort keys %{$pkgs{$pkg}{$ver}};
- my $part_str = "";
- if ($part{$pkg}{$ver}{$versions[0]}) {
- $part_str = "[$part{$pkg}{$ver}{$versions[0]}]";
- }
- printf "
\n";
- }
- } elsif ($format eq 'xml') {
- require RDF::Simple::Serialiser;
- my $rdf = new RDF::Simple::Serialiser;
- $rdf->addns( debpkg => 'http://packages.debian.org/xml/01-debian-packages-rdf' );
- my @triples;
- foreach my $pkg (sort keys %pkgs) {
- foreach my $ver (@DISTS) {
- if (exists $pkgs{$pkg}{$ver}) {
- my @versions = version_sort keys %{$pkgs{$pkg}{$ver}};
- foreach my $version (@versions) {
- my $id = "$ROOT/$ver/$sect{$pkg}{$ver}{$version}/$pkg/$version";
- push @triples, [ $id, 'debpkg:package', $pkg ];
- push @triples, [ $id, 'debpkg:version', $version ];
- push @triples, [ $id, 'debpkg:section', $sect{$pkg}{$ver}{$version}, ];
- push @triples, [ $id, 'debpkg:suite', $ver ];
- push @triples, [ $id, 'debpkg:shortdesc', $desc{$pkg}{$ver}{$version} ];
- push @triples, [ $id, 'debpkg:part', $part{$pkg}{$ver}{$version} || 'main' ];
- foreach my $arch (sort keys %{$pkgs{$pkg}{$ver}{$version}}) {
- push @triples, [ $id, 'debpkg:architecture', $arch ];
+ foreach my $pkg (sort keys %pkgs) {
+ $count++;
+ next if $count < $start or $count > $end;
+ printf "
%s: %s\n",
- $v, join (" ", (sort keys %{$pkgs{$pkg}{$ver}{$v}}) );
- }
- print "Package %s
\n", $pkg;
+ print "\n";
+ foreach my $suite (@SUITES) {
+ foreach my $archive (@ARCHIVES) {
+ 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 .= " [$sect{$pkg}{$suite}{$versions[0]}]";
+ }
+ printf "
\n";
}
}
+ } else {
+ foreach (@results) {
+ my ($pkg, $archive, $suite, $section, $subsection, $priority,
+ $version) = @$_;
- print $rdf->serialise(@triples);
- }
-} else {
- foreach (@results) {
- my ($package, $suite, $section, $subsection, $priority,
- $version, $binaries) = @$_;
-
- $pkgs{$package}{$suite} = $version;
- $sect{$package}{$suite}{source} = $subsection;
- $part{$package}{$suite}{source} = $section unless $section eq 'main';
+ $pkgs{$pkg}{$suite}{$archive} = $version;
+ $subsect{$pkg}{$suite}{$archive}{source} = $subsection;
+ $sect{$pkg}{$suite}{$archive}{source} = $section
+ unless $section eq 'main';
- $binaries{$package}{$suite} = [ sort split( /\s*,\s*/, $binaries ) ];
- }
+ $binaries{$pkg}{$suite}{$archive} = find_binaries( $pkg, $archive, $suite, \%src2bin );
+ }
- if ($format eq 'html') {
- my ($start, $end) = multipageheader( scalar keys %pkgs );
- my $count = 0;
-
- foreach my $pkg (sort keys %pkgs) {
- $count++;
- next if ($count < $start) or ($count > $end);
- printf "
%s: %s\n",
+ $v, join (" ", (sort keys %{$pkgs{$pkg}{$suite}{$archive}{$v}}) );
+ }
+ print "Source package %s
\n", $pkg;
- print "\n";
- foreach my $ver (@SUITES) {
- if (exists $pkgs{$pkg}{$ver}) {
- my $part_str = "";
- if ($part{$pkg}{$ver}{source}) {
- $part_str = "[$part{$pkg}{$ver}{source}]";
- }
- printf "
\n";
}
- print "\n";
}
- } elsif ($format eq 'xml') {
- require RDF::Simple::Serialiser;
- my $rdf = new RDF::Simple::Serialiser;
- $rdf->addns( debpkg => 'http://packages.debian.org/xml/01-debian-packages-rdf' );
- my @triples;
- foreach my $pkg (sort keys %pkgs) {
- foreach my $ver (@SUITES) {
- if (exists $pkgs{$pkg}{$ver}) {
- my $id = "$ROOT/$ver/source/$pkg";
-
- push @triples, [ $id, 'debpkg:package', $pkg ];
- push @triples, [ $id, 'debpkg:type', 'source' ];
- push @triples, [ $id, 'debpkg:section', $sect{$pkg}{$ver}{source} ];
- push @triples, [ $id, 'debpkg:version', $pkgs{$pkg}{$ver} ];
- push @triples, [ $id, 'debpkg:part', $part{$pkg}{$ver}{source} || 'main' ];
-
- foreach my $bp (@{$binaries{$pkg}{$ver}}) {
- push @triples, [ $id, 'debpkg:binary', $bp ];
- }
- }
- }
- }
- print $rdf->serialise(@triples);
- }
-}
-
-if ($format eq 'html') {
- &printindexline( scalar keys %pkgs );
- &printfooter;
-}
-
-exit;
-
-sub printindexline {
- my $no_results = shift;
-
- my $index_line;
- if ($no_results > $results_per_page) {
-
- $index_line = prevlink($input,\%params)." | ".
- indexline( $input, \%params, $no_results)." | ".
- nextlink($input,\%params, $no_results);
-
- print "
Binary packages: ";
- my @bp_links;
- foreach my $bp (@{$binaries{$pkg}{$ver}}) {
- my $sect = 'section';
-
- my $bp_link;
- if ($sect) {
- $bp_link = sprintf( "%s",
- $ver, $sect, uri_escape( $bp ), $bp );
- } else {
- $bp_link = $bp;
+ if ($opts{format} eq 'html') {
+ my ($start, $end) = multipageheader( $input, scalar keys %pkgs, \%opts );
+ my $count = 0;
+
+ foreach my $pkg (sort keys %pkgs) {
+ $count++;
+ next if ($count < $start) or ($count > $end);
+ printf "Source package %s
\n", $pkg;
+ print "\n";
+ foreach my $suite (@SUITES) {
+ foreach my $archive (@ARCHIVES) {
+ if (exists $pkgs{$pkg}{$suite}{$archive}) {
+ my $origin_str = "";
+ if ($sect{$pkg}{$suite}{$archive}{source}) {
+ $origin_str .= " [$sect{$pkg}{$suite}{$archive}{source}]";
+ }
+ printf( "
Binary packages: ";
+ my @bp_links;
+ foreach my $bp (@{$binaries{$pkg}{$suite}{$archive}}) {
+ my $bp_link = sprintf( "%s",
+ $suite.(($archive ne 'us')?"/$archive":''), uri_escape( $bp ), $bp );
+ push @bp_links, $bp_link;
+ }
+ print join( ", ", @bp_links );
+ print "
Results per page: "; - my @resperpagelinks; - for (50, 100, 200) { - if ($results_per_page == $_) { - push @resperpagelinks, $_; - } else { - push @resperpagelinks, resperpagelink($input,\%params,$_); - } - } - if ($params{values}{number}{final} =~ /^all$/i) { - push @resperpagelinks, "all"; - } else { - push @resperpagelinks, resperpagelink($input, \%params,"all"); - } - print join( " | ", @resperpagelinks )."
"; - } - return ( $start, $end ); + printindexline( $input, scalar keys %pkgs, \%opts ); } - -sub printfooter { -print <