--- /dev/null
+#!/usr/bin/perl -wT
+#
+# search_packages.pl -- CGI interface to the Packages files on packages.debian.org
+#
+# Copyright (C) 1998 James Treacy
+# Copyright (C) 2000, 2001 Josip Rodin
+# Copyright (C) 2001 Adam Heath
+# Copyright (C) 2004 Martin Schulze
+# Copyright (C) 2004 Frank Lichtenheld
+#
+# use is allowed under the terms of the GNU Public License (GPL)
+# see http://www.fsf.org/copyleft/gpl.html for a copy of the license
+
+require 5.001;
+use strict;
+use CGI qw( -oldstyle_urls );
+#use CGI::Carp qw( fatalsToBrowser );
+use POSIX;
+use URI::Escape;
+use HTML::Entities;
+use DB_File;
+use Benchmark;
+
+use lib "../lib";
+
+use Deb::Versions;
+use Packages::Search qw( :all );
+use Packages::HTML ();
+
+my $thisscript = "search_packages.pl";
+my $use_grep = 1;
+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 );
+
+$ENV{PATH} = "/bin:/usr/bin";
+
+# Read in all the variables set by the form
+my $input = new CGI;
+
+my $pet0 = new Benchmark;
+# use this to disable debugging in production mode completly
+my $debug_allowed = 0;
+my $debug = $debug_allowed && $input->param("debug");
+$Search::Param::debug = 1 if $debug > 1;
+
+# If you want, just print out a list of all of the variables and exit.
+print $input->header if $debug;
+# print $input->dump;
+# exit;
+
+my %params_def = ( keywords => { default => undef, match => '^\s*([-+\@\w\/.:]+)\s*$' },
+ suite => { default => 'stable', match => '^(\w+)$',
+ alias => 'version', array => ',',
+ replace => { all => \@SUITES } },
+ case => { default => 'insensitive', match => '^(\w+)$' },
+ official => { default => 0, match => '^(\w+)$' },
+ use_cache => { default => 1, match => '^(\w+)$' },
+ subword => { default => 0, match => '^(\w+)$' },
+ exact => { default => undef, match => '^(\w+)$' },
+ searchon => { default => 'all', match => '^(\w+)$' },
+ section => { default => 'all', match => '^([\w-]+)$',
+ alias => 'release', array => ',',
+ replace => { all => \@SECTIONS } },
+ arch => { default => 'any', match => '^(\w+)$',
+ array => ',', replace =>
+ { any => \@ARCHITECTURES } },
+ archive => { default => 'all', match => '^(\w+)$',
+ array => ',', replace =>
+ { all => \@ARCHIVES } },
+ format => { default => 'html', match => '^(\w+)$' },
+ );
+my %params = Packages::Search::parse_params( $input, \%params_def );
+
+my $format = $params{values}{format}{final};
+#XXX: Don't use alternative output formats yet
+$format = 'html';
+
+if ($format eq 'html') {
+ print $input->header;
+} elsif ($format eq 'xml') {
+# print $input->header( -type=>'application/rdf+xml' );
+ print $input->header( -type=>'text/plain' );
+}
+
+if ($params{errors}{keywords}) {
+ print "Error: keyword not valid or missing" if $format eq 'html';
+ exit 0;
+}
+my $keyword = $params{values}{keywords}{final};
+my @suites = @{$params{values}{suite}{final}};
+my $official = $params{values}{official}{final};
+my $use_cache = $params{values}{use_cache}{final};
+my $case = $params{values}{case}{final};
+my $case_bool = ( $case !~ /insensitive/ );
+my $subword = $params{values}{subword}{final};
+my $exact = $params{values}{exact}{final};
+$exact = !$subword unless defined $exact;
+my $searchon = $params{values}{searchon}{final};
+my @sections = @{$params{values}{section}{final}};
+my @archs = @{$params{values}{arch}{final}};
+my $page = $params{values}{page}{final};
+my $results_per_page = $params{values}{number}{final};
+
+# for URL construction
+my $suites_param = join ',', @{$params{values}{suite}{no_replace}};
+my $sections_param = join ',', @{$params{values}{section}{no_replace}};
+my $archs_param = join ',', @{$params{values}{arch}{no_replace}};
+
+# for output
+my $keyword_enc = encode_entities $keyword;
+my $searchon_enc = encode_entities $searchon;
+my $suites_enc = encode_entities join ', ', @{$params{values}{suite}{no_replace}};
+my $sections_enc = encode_entities join ', ', @{$params{values}{section}{no_replace}};
+my $archs_enc = encode_entities join ', ', @{$params{values}{arch}{no_replace}};
+my $pet1 = new Benchmark;
+my $petd = timediff($pet1, $pet0);
+print "DEBUG: Parameter evaluation took ".timestr($petd)."<br>" 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 (<C>) {
+ $topdir = $1 if (/^\s*topdir="?(.*)"?\s*$/);
+}
+close (C);
+
+my $FLATDIR = $topdir . "/files/flat";
+my $search_on_sources = 0;
+
+my %descr;
+my %sections;
+
+sub find_desc
+{
+ my $pkg = shift;
+ my $suite = shift;
+ my $part = shift;
+ my $descr = '';
+
+ unless (exists $descr{$suite}{$part}) {
+ $descr{$suite}{$part} = {};
+ tie %{$descr{$suite}{$part}}, 'DB_File', "$FLATDIR/$suite/$part/Description", O_RDONLY
+ or return "Error while loading descriptions database: $!";
+ }
+
+ return $descr{$suite}{$part}{$pkg};
+}
+
+sub find_section
+{
+ my $pkg = shift;
+ my $suite = shift;
+ my $part = shift;
+ my $section = '';
+
+ unless (exists $sections{$suite}{$part}) {
+ $sections{$suite}{$part} = {};
+ tie %{$sections{$suite}{$part}}, 'DB_File', "$FLATDIR/$suite/$part/Section", O_RDONLY
+ or return undef;
+ }
+
+ return $sections{$suite}{$part}{$pkg};
+}
+
+my $st0 = new Benchmark;
+tie my %cache, 'DB_File', "$topdir/files/search.cache/search.cache", O_RDWR|O_CREAT or $use_cache = 0;
+my $cached;
+my @results;
+my $cache_key = $keyword.$exact.$subword.$searchon.$suites_param.$sections_param.$archs_param;
+if ($searchon eq 'sourcenames') {
+ $search_on_sources = 1;
+}
+if ($use_cache && ($cached = $cache{$cache_key})) {
+ @results = split /\n/, $cached;
+ print "DEBUG: Used cached results<br><pre>$cached</pre>" if $debug;
+} else {
+ my $searchkeyword = $keyword;
+ my $grep_searchkeyword = $keyword;
+ $searchkeyword =~ s/[.]/\\./;
+ if (($searchon eq 'names') || ($searchon eq 'sourcenames')) {
+ # asserting that all package names are lower case
+ $searchkeyword = lc($searchkeyword) unless $case_bool;
+ $case_bool = 1;
+ $grep_searchkeyword = "^[^ ]*$searchkeyword" unless $exact;
+ $searchkeyword = "^\\S*$searchkeyword" unless $exact;
+ } else {
+ $grep_searchkeyword = "\\(^$searchkeyword\\b\\|\\b$searchkeyword\\b\\)"
+ if $subword != 1;
+ $searchkeyword = "\\b$searchkeyword\\b"
+ if $subword != 1;
+ }
+
+# FIXME
+# check if the Packages files are there
+#my @files = glob ("$fdir/$file");
+#if ($#files == -1) {
+# XXX has to be updated for new architectures
+# if ($format eq 'html') {
+# if (($version eq "stable" and $arch =~ /^(hurd|sh)$/)
+# || ($version eq "oldstable" and $arch =~ /^amd64$/)) {
+# print "Error: the $arch architecture didn't exist in $version.<br>\n"
+# ."Please go back and choose a different distribution.\n";
+# } else {
+# print "Error: Packages/Sources file not found.<br>\n"
+# ."If the problem persists, please inform $ENV{SERVER_ADMIN}.\n";
+# printf "<p>$file</p>";
+# }
+# &printfooter;
+# }
+# exit;
+#}
+
+ my @files;
+ foreach my $s (@suites) {
+ foreach my $sec (@sections) {
+ foreach my $a (@archs) {
+ foreach my $archive (@ARCHIVES) {
+ if (($searchon eq 'names' or $searchon eq 'sourcenames')
+ and $exact) {
+ my ( %packages, $file );
+ if ($search_on_sources) {
+ $file = "$FLATDIR/$s/$sec/Sources.$archive.db";
+ } else {
+ $file = "$FLATDIR/$s/$sec/Packages-$a.$archive.db";
+ }
+ if (-f $file) {
+ print "DEBUG: Use file $file<br>"
+ if $debug > 1;
+
+ tie %packages, 'DB_File', $file, O_RDONLY
+ or die "Couldn't open packages file $file: $!";
+
+ if (my $data = $packages{$searchkeyword}) {
+ print "DEBUG: Found result $data<br>"
+ if $debug > 1;
+ push @results, "$file:$data";
+ }
+ }
+ } else {
+ my $file;
+ if ($search_on_sources) {
+ $file = "$FLATDIR/$s/$sec/Sources.$archive";
+ } else {
+ $file = "$FLATDIR/$s/$sec/Packages-$a.$archive";
+ }
+ if (-f $file) {
+ print "DEBUG: Use file $file<br>"
+ if $debug > 1;
+
+ # use_grep is currently way faster, though
+ # I can't pinpoint exactly why, yet
+ # most probably the perl regexes are
+ # slow compared to the simpler grep
+ # regexes
+ unless ($use_grep) {
+ open my $pkg_fh, '<', $file
+ or die "Couldn't open packages file $file: $!";
+
+ foreach (<$pkg_fh>) {
+ if (/$searchkeyword/o) {
+ print "DEBUG: Found result $_<br>"
+ if $debug > 1;
+
+ push @results, "$file:$_";
+ }
+ }
+ } else {
+ push @files, $file;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+
+ if ($use_grep) {
+ if (@files) {
+ my @grep = ( 'grep', '-H' );
+ push @grep, '-i' unless $case_bool;
+ push @grep, $grep_searchkeyword;
+ push @grep, @files;
+
+ print "DEBUG: starting grep command '".
+ substr("@grep",0,100)."[...]'<br>" if $debug;
+ open my $grep_out, '-|', @grep or
+ die "grep failed: $!";
+ @results = <$grep_out>;
+ }
+ }
+
+ $cache{$cache_key} = join "", @results;
+}
+
+my $st1 = new Benchmark;
+my $std = timediff($st1, $st0);
+print "DEBUG: Search took ".timestr($std)."<br>" if $debug;
+
+if ($format eq 'html') {
+ my $suite_wording = $suites_enc eq "all" ? "all suites"
+ : "suite(s) <em>$suites_enc</em>";
+ my $section_wording = $sections_enc eq 'all' ? "all sections"
+ : "section(s) <em>$sections_enc</em>";
+ my $arch_wording = $archs_enc eq 'any' ? "all architectures"
+ : "architecture(s) <em>$archs_enc</em>";
+ if (($searchon eq "names") || ($searchon eq 'sourcenames')) {
+ my $source_wording = $search_on_sources ? "source " : "";
+ my $exact_wording = $exact ? "named" : "that names contain";
+ print "<p>You have searched for ${source_wording}packages $exact_wording <em>$keyword_enc</em> in $suite_wording, $section_wording, and $arch_wording.</p>";
+ } else {
+ my $exact_wording = $exact ? "" : " (including subword matching)";
+ print "<p>You have searched for <em>$keyword_enc</em> in packages names and descriptions in $suite_wording, $section_wording, and $arch_wording$exact_wording.</p>";
+ }
+}
+
+if (!@results) {
+ if ($format eq 'html') {
+ my $keyword_esc = uri_escape( $keyword );
+ my $printed = 0;
+ if (($searchon eq "names") || ($searchon eq 'sourcenames')) {
+ if (($suites_enc eq 'all')
+ && ($archs_enc eq 'any')
+ && ($sections_enc eq 'all')) {
+ print "<p><strong>Can't find that package.</strong></p>\n";
+ } else {
+ print "<p><strong>Can't find that package, at least not in that suite ".
+ ( $search_on_sources ? "" : " and on that architecture" ).
+ ".</strong></p>\n";
+ }
+
+ if ($exact) {
+ $printed = 1;
+ print "<p>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>.</p>";
+ }
+ } else {
+ if (($suites_enc eq 'all')
+ && ($archs_enc eq 'any')
+ && ($sections_enc eq 'all')) {
+ print "<p><strong>Can't find that string.</strong></p>\n";
+ } else {
+ print "<p><strong>Can't find that string, at least not in that suite ($suites_enc, section $sections_enc) and on that architecture ($archs_enc).</strong></p>\n";
+ }
+
+ unless ($subword) {
+ $printed = 1;
+ print "<p>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>.</p>";
+ }
+ }
+ print "<p>".( $printed ? "Or you" : "You" )." can try a different search on the <a href=\"$SEARCHPAGE#search_packages\">Packages search page</a>.</p>";
+
+ &printfooter;
+ }
+ exit;
+}
+
+my (%pkgs, %sect, %part, %desc, %binaries);
+my (@colon, $package, $pkg_t, $section, $ver, $arch, $foo, $binaries);
+
+unless ($search_on_sources) {
+ foreach my $line (@results) {
+ @colon = split (/:/, $line);
+ ($pkg_t, $section, $ver, $arch, $foo) = split (/ /, $#colon >1 ? $colon[1].":".$colon[2]:$colon[1], 5);
+ $section =~ s,^(non-free|contrib)/,,;
+ $section =~ s,^non-US.*$,non-US,,;
+ my ($dist,$part,undef) = $colon[0] =~ m,.*/([^/]+)/([^/]+)/Packages-([^\.]+)\.,; #$1=stable, $2=main, $3=alpha
+
+ ($package) = $pkg_t =~ m/^(.+)/; # untaint
+ $pkgs{$package}{$dist}{$ver}{$arch} = 1;
+ $sect{$package}{$dist}{$ver} = $section;
+ $part{$package}{$dist}{$ver} = $part unless $part eq 'main';
+
+ $desc{$package}{$dist}{$ver} = find_desc ($package, $dist, $part) if (! exists $desc{$package}{$dist}{$ver});
+
+ }
+
+ 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 "<h3>Package %s</h3>\n", $pkg;
+ print "<ul>\n";
+ foreach $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 = "[<span style=\"color:red\">$part{$pkg}{$ver}{$versions[0]}</span>]";
+ }
+ printf "<li><a href=\"$ROOT/%s/%s/%s\">%s</a> (%s): %s %s\n",
+ $ver, $sect{$pkg}{$ver}{$versions[0]}, $pkg, $ver, $sect{$pkg}{$ver}{$versions[0]}, $desc{$pkg}{$ver}{$versions[0]}, $part_str;
+
+ foreach my $v (@versions) {
+ printf "<br>%s: %s\n",
+ $v, join (" ", (sort keys %{$pkgs{$pkg}{$ver}{$v}}) );
+ }
+ print "</li>\n";
+ }
+ }
+ print "</ul>\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 $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 ];
+ }
+ }
+ }
+ }
+ }
+
+ print $rdf->serialise(@triples);
+ }
+} else {
+ foreach my $line (@results) {
+ chomp($line);
+ @colon = split (/:/, $line);
+ ($package, $section, $ver, $binaries) = split (/ /, $#colon >1 ? $colon[1].":".$colon[2]:$colon[1], 4);
+ $section =~ s,^(non-free|contrib)/,,;
+ $section =~ s,^non-US.*$,non-US,,;
+ $colon[0] =~ m,.*/([^/]+)/([^/]+)/Sources\.,; #$1=stable, $2=main
+
+ my ($suite, $part) = ($1, $2);
+ $pkgs{$package}{$suite} = $ver;
+ $sect{$package}{$suite}{source} = $section;
+ $part{$package}{$suite}{source} = $part unless $part eq 'main';
+
+ $binaries{$package}{$suite} = [ sort split( /\s*,\s*/, $binaries ) ];
+
+ }
+
+ 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 "<h3>Source package %s</h3>\n", $pkg;
+ print "<ul>\n";
+ foreach $ver (@DISTS) {
+ if (exists $pkgs{$pkg}{$ver}) {
+ my $part_str = "";
+ if ($part{$pkg}{$ver}{source}) {
+ $part_str = "[<span style=\"color:red\">$part{$pkg}{$ver}{source}</span>]";
+ }
+ printf "<li><a href=\"$ROOT/%s/source/%s\">%s</a> (%s): %s %s", $ver, $pkg, $ver, $sect{$pkg}{$ver}{source}, $pkgs{$pkg}{$ver}, $part_str;
+
+ print "<br>Binary packages: ";
+ my @bp_links;
+ foreach my $bp (@{$binaries{$pkg}{$ver}}) {
+ my $sect = find_section($bp, $ver, $part{$pkg}{$ver}{source}||'main') || '';
+ $sect =~ s,^(non-free|contrib)/,,;
+ $sect =~ s,^non-US.*$,non-US,,;
+ my $bp_link;
+ if ($sect) {
+ $bp_link = sprintf "<a href=\"$ROOT/%s/%s/%s\">%s</a>", $ver, $sect, uri_escape( $bp ), $bp;
+ } else {
+ $bp_link = $bp;
+ }
+ push @bp_links, $bp_link;
+ }
+ print join( ", ", @bp_links );
+ print "</li>\n";
+ }
+ }
+ print "</ul>\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 $ver (@DISTS) {
+ 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 "<p style=\"text-align:center\">$index_line</p>";
+ }
+}
+
+sub multipageheader {
+ my $no_results = shift;
+
+ my ($start, $end);
+ if ($results_per_page =~ /^all$/i) {
+ $start = 1;
+ $end = $no_results;
+ $results_per_page = $no_results;
+ } else {
+ $start = Packages::Search::start( \%params );
+ $end = Packages::Search::end( \%params );
+ if ($end > $no_results) { $end = $no_results; }
+ }
+
+ print "<p>Found <em>$no_results</em> matching packages,";
+ if ($end == $start) {
+ print " displaying package $end.</p>";
+ } else {
+ print " displaying packages $start to $end.</p>";
+ }
+
+ printindexline( $no_results );
+
+ if ($no_results > 100) {
+ print "<p>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 )."</p>";
+ }
+ return ( $start, $end );
+}
+
+sub printfooter {
+print <<END;
+</div>
+
+<hr class="hidecss">
+<p style="text-align:right;font-size:small;font-stlye:italic"><a href="$SEARCHPAGE">Packages search page</a></p>
+
+</div>
+END
+
+print $input->end_html;
+}
--- /dev/null
+package Packages::HTML;
+
+use strict;
+use warnings;
+
+use URI::Escape;
+use HTML::Entities;
+
+use Packages::Util;
+use Packages::I18N::Locale;
+use Packages::I18N::Languages;
+use Packages::I18N::LanguageNames;
+use Generated::Strings qw( gettext dgettext );
+
+our @ISA = qw( Exporter );
+our @EXPORT = qw( header title trailer file_changed time_stamp
+ read_md5_hash write_md5_hash simple_menu
+ ds_begin ds_item ds_end note title marker pdesc
+ pdeplegend pkg_list pmoreinfo );
+
+our $HOME = "http://www.debian.org";
+our $CONTACT_MAIL = 'debian-www@lists.debian.org';
+our $WEBMASTER_MAIL = 'webmaster@debian.org';
+our $SEARCH_PAGE = "http://packages.debian.org/";
+our $CGI_ROOT = "http://packages.debian.org/cgi-bin";
+our $CN_HELP_URL = "${HOME}/intro/cn";
+our $CHANGELOG_URL = '/changelogs';
+our $COPYRIGHT_URL = '/changelogs';
+our $SEARCH_URL = '/cgi-bin/search_packages.pl?searchon=names&version=all&exact=1&keywords=';
+our $SRC_SEARCH_URL = '/cgi-bin/search_packages.pl?searchon=sourcenames&version=all&exact=1&keywords=';
+our $BUG_URL = 'http://bugs.debian.org/';
+our $SRC_BUG_URL = 'http://bugs.debian.org/src:';
+our $QA_URL = 'http://packages.qa.debian.org/';
+
+
+my %img_trans = ( pt_BR => "pt", pt_PT => "pt", sv_SE => "sv" );
+
+sub img {
+ my ( $root, $url, $src, $alt, %attr ) = @_;
+ my @attr;
+
+ foreach my $a ( keys %attr ) {
+ push @attr, "$a=\"$attr{$a}\"";
+ }
+
+ return "<a href=\"$root$url\"><img src=\"$root$src\" alt=\"$alt\" @attr></a>";
+}
+
+sub simple_menu {
+ my $str = "";
+ foreach my $entry (@_) {
+ $str .= "[ $entry->[0] <a title=\"$entry->[1]\" href=\"$entry->[2]\">$entry->[3]</a> ]\n";
+ }
+ return $str;
+}
+
+sub title {
+ return "<h1>$_[0]</h1>\n";
+}
+
+sub marker {
+ return "[<span class=\"pred\">$_[0]</span>]";
+}
+
+sub note {
+ my ( $title, $note ) = @_;
+ my $str = "";
+
+ if ($note) {
+ $str .= "<h2 class=\"pred\">$title</h2>";
+ } else {
+ $note = $title;
+ }
+ $str .= "<p>$note</p>";
+ return $str;
+}
+
+sub pdesc {
+ my ( $short_desc, $long_desc ) = @_;
+ my $str = "";
+
+ $str .= "<div id=\"pdesc\">\n";
+ $str .= "<h2>$short_desc</h2>\n";
+
+ $str .= "<p>$long_desc\n";
+ $str .= "</div> <!-- end pdesc -->\n";
+
+ return $str;
+}
+
+sub pdeplegend {
+ my $str = "<table border=\"1\" summary=\"legend\"><tr>\n";
+
+ foreach my $entry (@_) {
+ $str .= "<td><img src=\"../../Pics/$entry->[0].gif\" alt=\"[$entry->[0]]\" width=\"16\" height=\"16\">= $entry->[1]</td>";
+ }
+
+ $str .= "\n</tr></table>\n";
+ return $str;
+}
+
+sub pkg_list {
+ my ( $pkgs, $lang, $env ) = @_;
+
+ my $str = "";
+ foreach my $p ( @$pkgs ) {
+ my $p_pkg = $env->{db}->get_pkg( $p );
+
+ if ( $p_pkg ) {
+ if ($p_pkg->is_virtual) {
+ $str .= "<dt><a href=\"../virtual/$p\">$p</a></dt>\n".
+ "\t<dd>".gettext("Virtual package")."</dd>\n";
+ } else {
+ my %subsections = $p_pkg->get_arch_fields( 'section',
+ $env->{archs} );
+ my $subsection = $subsections{max_unique};
+ my %desc_md5s = $p_pkg->get_arch_fields( 'description-md5',
+ $env->{archs} );
+ my $short_desc = conv_desc( $lang,
+ encode_entities( $env->{db}->get_short_desc( $desc_md5s{max_unique}, $lang ), "<>&\"" ) );
+ $str .= "<dt><a href=\"../$subsection/$p\">$p</a></dt>\n".
+ "\t<dd>$short_desc</dd>\n";
+ }
+ } else {
+ $str .= "<dt>$p</dt>\n\t<dd>".gettext("Not available")."</dd>\n";
+ }
+ }
+ if ($str) {
+ $str = "<dl>$str</dl>\n";
+ }
+
+ return $str;
+}
+
+sub pmoreinfo {
+ my %info = @_;
+
+ my $name = $info{name} or return;
+ my $env = $info{env} or return;
+ my $d = $info{data} or return;
+ my $is_source = $info{is_source};
+
+ my $str = "<div id=\"pmoreinfo\">";
+ $str .= sprintf( "<h2>".gettext( "More Information on %s" )."</h2>",
+ $name );
+
+
+ if ($info{bugreports}) {
+ my $bug_url = $is_source ? $SRC_BUG_URL : $BUG_URL;
+ $str .= "<p>\n".sprintf( gettext( "Check for <a href=\"%s\">Bug Reports</a> about %s." )."<br>\n",
+ $bug_url.$name, $name );
+ }
+
+ if ($info{sourcedownload}) {
+ $str .= gettext( "Source Package:" );
+ $str .= " <a href=\"../source/$d->{src_name}\">$d->{src_name}</a>, ".
+ gettext( "Download" ).":\n";
+
+ unless ($d->{src_files}) {
+ $str .= gettext( "Not found" );
+ } else {
+ foreach( @{$d->{src_files}} ) {
+ my ($src_file_md5, $src_file_size, $src_file_name) = @$_;
+ if ($d->{is_security}) {
+ $str .= "<a href=\"$env->{opts}{security_site}/$d->{src_directory}/$src_file_name\">[";
+ } elsif ($d->{is_volatile}) {
+ $str .= "<a href=\"$env->{opts}{volatile_site}/$d->{src_directory}/$src_file_name\">[";
+ } elsif ($d->{is_nonus}) {
+ $str .= "<a href=\"$env->{opts}{nonus_site}/$d->{src_directory}/$src_file_name\">[";
+ } else {
+ $str .= "<a href=\"$env->{opts}{debian_site}/$d->{src_directory}/$src_file_name\">[";
+ }
+ if ($src_file_name =~ /dsc$/) {
+ $str .= "dsc";
+ } else {
+ $str .= $src_file_name;
+ }
+ $str .= "]</a>\n";
+ }
+ }
+# $package_page .= sprintf( gettext( " (These sources are for version %s)\n" ), $src_version )
+# if ($src_version ne $version) && !$src_version_given_in_control;
+ }
+
+ if ($info{changesandcopy}) {
+ if ( $d->{src_directory} ) {
+ my $src_dir = $d->{src_directory};
+ (my $src_basename = $d->{src_version}) =~ s,^\d+:,,; # strip epoche
+ $src_basename = "$d->{src_name}_$src_basename";
+ $src_dir =~ s,pool/updates,pool,o;
+ $src_dir =~ s,pool/non-US,pool,o;
+ $str .= "<br>".sprintf( gettext( "View the <a href=\"%s\">Debian changelog</a>" ),
+ "$CHANGELOG_URL/$src_dir/$src_basename/changelog" )."<br>\n";
+ my $copyright_url = "$COPYRIGHT_URL/$src_dir/$src_basename/";
+ $copyright_url .= ( $is_source ? 'copyright' : "$name.copyright" );
+
+ $str .= sprintf( gettext( "View the <a href=\"%s\">copyright file</a>" ),
+ $copyright_url )."</p>";
+ }
+ }
+
+ if ($info{maintainers}) {
+ my @uploaders = @{$d->{uploaders}};
+ foreach (@uploaders) {
+ $_->[0] = encode_entities( $_->[0], '&<>' );
+ }
+ my ($maint_name, $maint_mail ) = @{shift @uploaders};
+ unless (@uploaders) {
+ $str .= "<p>\n".sprintf( gettext( "%s is responsible for this Debian package." ).
+ "\n",
+ "<a href=\"mailto:$maint_mail\">$maint_name</a>"
+ );
+ } else {
+ my $up_str = "<a href=\"mailto:$maint_mail\">$maint_name</a>";
+ my @uploaders_str;
+ foreach (@uploaders) {
+ push @uploaders_str, "<a href=\"mailto:$_->[1]\">$_->[0]</a>";
+ }
+ my $last_up = pop @uploaders_str;
+ $up_str .= ", ".join ", ", @uploaders_str if @uploaders_str;
+ $up_str .= sprintf( gettext( " and %s are responsible for this Debian package." ), $last_up );
+ $str .= "<p>\n$up_str ";
+ }
+
+ $str .= sprintf( gettext( "See the <a href=\"%s\">developer information for %s</a>." )."</p>", $QA_URL.$d->{src_name}, $name );
+ }
+
+ if ($info{search}) {
+ my $encodedname = uri_escape( $name );
+ my $search_url = $is_source ? $SRC_SEARCH_URL : $SEARCH_URL;
+ $str .= "<p>".sprintf( gettext( "Search for <a href=\"%s\">other versions of %s</a>" ), $search_url.$encodedname, $name )."</p>\n";
+ }
+
+ $str .= "</div> <!-- end pmoreinfo -->\n";
+ return $str;
+}
+
+my $ds_begin = '<dl>';
+my $ds_item_desc = '<dt>';
+my $ds_item = ':</dt><dd>';
+my $ds_item_end = '</dd>';
+my $ds_end = '</dl>';
+# my $ds_begin = '<table><tbody>';
+# my $ds_item_desc = '<tr><td>';
+# my $ds_item = '</td><td>';
+# my $ds_item_end = '</td></tr>';
+# my $ds_end = '</tbody></table>';
+
+sub ds_begin {
+ return $ds_begin;
+}
+sub ds_item {
+ return "$ds_item_desc$_[0]$ds_item$_[1]$ds_item_end\n";
+}
+sub ds_end {
+ return $ds_end;
+}
+
+sub header {
+ my (%params) = @_;
+
+ my $DESC_LINE;
+ if (defined $params{desc}) {
+ $DESC_LINE = "<meta name=\"Description\" content=\"$params{desc}\">";
+ }
+ else {
+ $DESC_LINE = '';
+ }
+
+ my $title_keywords = $params{title_keywords} || $params{title} || '';
+ my $title_tag = $params{title_tag} || $params{title} || '';
+ my $title_in_header = $params{page_title} || $params{title} || '';
+ my $page_title = $params{page_title} || $params{title} || '';
+ my $meta = $params{meta} || '';
+
+ if ($params{print_title_above}) {
+ $title_in_header = "<h1>$title_in_header</h1>";
+ } else {
+ $title_in_header = '';
+ }
+
+ my $search_in_header = '';
+ $params{print_search_field} ||= "";
+ if ($params{print_search_field} eq 'packages') {
+ my %values = %{$params{search_field_values}};
+ my %checked_searchon = ( names => "",
+ all => "",
+ sourcenames => "", );
+ $checked_searchon{$values{searchon}} = "checked=\"checked\"";
+ $search_in_header = <<MENU;
+<form method="GET" action="$CGI_ROOT/search_packages.pl">
+<div id="hpacketsearch">
+<input type="hidden" name="suite" value="$values{suite}">
+<input type="hidden" name="subword" value="$values{subword}">
+<input type="hidden" name="exact" value="$values{exact}">
+<input type="hidden" name="arch" value="$values{arch}">
+<input type="hidden" name="section" value="$values{section}">
+<input type="hidden" name="case" value="$values{case}">
+<input type="text" size="30" name="keywords" value="$values{keywords}" id="kw">
+<input type="submit" value="Search">
+<span style="font-size: 60%"><a href="$SEARCH_PAGE#search_packages">Full options</a></span>
+<br>
+<div style="font-size: 80%">Search on:
+<input type="radio" name="searchon" value="names" id="onlynames" $checked_searchon{names}>
+<label for="onlynames">Package names only</label>
+<input type="radio" name="searchon" value="all" id="descs" $checked_searchon{all}>
+<label for="descs">Descriptions</label>
+<br>
+<input type="radio" name="searchon" value="sourcenames" id="src" $checked_searchon{sourcenames}>
+<label for="src">Source package names</label>
+</div>
+</div> <!-- end hpacketsearch -->
+</form>
+MENU
+;
+ } elsif ($params{print_search_field} eq 'contents') {
+ my %values = %{$params{search_field_values}};
+ my %checked_searchmode = ( searchfiles => "",
+ searchfilesanddirs => "",
+ searchword => "",
+ filelist => "", );
+ $checked_searchmode{$values{searchmode}} = "checked=\"checked\"";
+ $search_in_header = <<MENU;
+<form method="GET" action="$CGI_ROOT/search_contents.pl">
+<div id="hpacketsearch">
+<input type="hidden" name="version" value="$values{version}" />
+<input type="hidden" name="arch" value="$values{arch}" />
+<input type="hidden" name="case" value="$values{case}" />
+<input type="text" size="30" name="word" id="keyword" value="$values{keyword}">
+<input type="submit" value="Search">
+<span style="font-size: 60%"><a href="$SEARCH_PAGE#search_contents">Full options</a></span>
+<br>
+<div style="font-size: 80%">Display:
+<input type=radio name="searchmode" value="searchfiles" id="searchfiles" $checked_searchmode{searchfiles}>
+<label for="searchfiles">files</label>
+<input type=radio name="searchmode" value="searchfilesanddirs" id="searchfilesanddirs" $checked_searchmode{searchfilesanddirs}>
+<label for="searchfilesanddirs">files & directories</label>
+<br>
+<input type=radio name="searchmode" value="searchword" id="searchword" $checked_searchmode{searchword}>
+<label for="searchword">subword matching</label>
+<input type=radio name="searchmode" value="filelist" id="filelist" $checked_searchmode{filelist}>
+<label for="filelist">content list</label>
+</div>
+</div> <!-- end hpacketsearch -->
+</form>
+MENU
+;
+ }
+
+ my $keywords = $params{keywords} || '';
+ my $KEYWORDS_LINE = "<meta name=\"Keywords\" content=\"debian, $keywords $title_keywords\">";
+
+ my $LANG = $params{lang};
+ my $img_lang = $img_trans{$LANG} || $LANG;
+ my $charset = get_charset($LANG);
+ my $txt = <<HEAD;
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<html lang="$LANG">
+<head>
+<title>Debian -- $title_tag</title>
+<link rev="made" href="mailto:$WEBMASTER_MAIL">
+<meta http-equiv="Content-Type" content="text/html; charset=$charset">
+<meta name="Author" content="Debian Webmaster, $WEBMASTER_MAIL">
+$KEYWORDS_LINE
+$DESC_LINE
+$meta
+<link href="$HOME/debian.css" rel="stylesheet" type="text/css" media="all">
+</head>
+<body>
+<div id="header">
+ <div id="upperheader">
+ <div id="logo">
+ <a href="$HOME/"><img src="$HOME/logos/openlogo-nd-50.png" alt="" /></a>
+HEAD
+;
+
+ $txt .= img( "$HOME/", "", "Pics/debian.png", gettext( "Debian Project" ),
+ width => 179, height => 61 );
+ $txt .= <<HEADEND;
+
+</div> <!-- end logo -->
+HEADEND
+;
+
+ $txt .= <<NAVBEGIN;
+$search_in_header
+</div> <!-- end upperheader -->
+
+NAVBEGIN
+;
+# $title_in_header
+ $txt .= "<p class=\"hidecss\"><a href=\"\#inner\">" . gettext("Skip Site Navigation")."</a></p>\n";
+ $txt .= "<div id=\"navbar\">\n<ul>".
+ "<li><a href=\"$HOME/intro/about\">".gettext( "About Debian" )."</a></li>\n".
+ "<li><a href=\"$HOME/News/\">".gettext( "News" )."</a></li>\n".
+ "<li><a href=\"$HOME/distrib/\">".gettext( "Getting Debian" )."</a></li>\n".
+ "<li><a href=\"$HOME/support\">".gettext( "Support" )."</a></li>\n".
+ "<li><a href=\"$HOME/devel/\">".gettext( "Development" )."</a></li>\n".
+ "<li><a href=\"$HOME/sitemap\">".gettext( "Site map" )."</a></li>\n".
+ "<li><a href=\"http://search.debian.org/\">".gettext( "Search" )."</a></li>\n";
+ $txt .= "</ul>\n";
+ $txt .= <<ENDNAV;
+</div> <!-- end navbar -->
+</div> <!-- end header -->
+ENDNAV
+;
+ $txt .= <<BEGINCONTENT;
+<div id="outer">
+<div id="inner">
+
+BEGINCONTENT
+;
+ if ($params{print_title_above}) {
+ $txt .= "<h1>$page_title</h1>\n";
+ }
+ if ($params{print_title_below}) {
+ $txt .= "<h1>$page_title</h1>\n";
+ }
+
+ return $txt;
+}
+
+sub trailer {
+ my ($ROOT, $NAME, $LANG, @USED_LANGS) = @_;
+ my $txt = "</div> <!-- end inner -->\n<div id=\"footer\">\n";
+ my $langs = languages( $NAME, $LANG, @USED_LANGS );
+ my $bl_class = $langs ? ' class="bordertop"' : "";
+ $txt .=
+ $langs.
+ "\n<hr class=\"hidecss\">\n" .
+ "<p$bl_class>".
+ sprintf( gettext( "Back to: <a href=\"%s/\">Debian Project homepage</a> || <a href=\"%s/\">Packages search page</a>" ), $HOME, $ROOT ).
+ "</p>\n<hr class=\"hidecss\">\n".
+ "<div id=\"fineprint\" class=\"bordertop\"><p>".
+ sprintf( gettext( "To report a problem with the web site, e-mail <a href=\"mailto:%s\">%s</a>. For other contact information, see the Debian <a href=\"%s/contact\">contact page</a>." ), $CONTACT_MAIL, $CONTACT_MAIL, $HOME).
+ "</p>\n".
+ "<p>". gettext( "Last Modified: " ). "LAST_MODIFIED_DATE".
+ "<br>\n".
+ sprintf( gettext( "Copyright © 1997-2005 <a href=\"http://www.spi-inc.org\">SPI</a>; See <a href=\"%s/license\">license terms</a>." ), "$HOME/" )."<br>\n".
+ gettext( "Debian is a registered trademark of Software in the Public Interest, Inc." ).
+ "</div> <!-- end fineprint -->\n".
+ "</div> <!-- end footer -->\n".
+ "</div> <!-- end outer -->\n".
+ "</body>\n</html>\n";
+
+ return $txt;
+}
+
+sub languages {
+ my ( $name, $lang, @used_langs ) = @_;
+
+ my $str = "";
+
+ if (@used_langs) {
+ $str .= "<hr class=\"hidecss\">\n";
+ $str .= "<!--UdmComment-->\n<p>\n";
+ $str .= gettext( "This page is also available in the following languages:\n" );
+ $str .= "</p><p class=\"navpara\">\n";
+
+ my @printed_langs = ();
+ foreach (@used_langs) {
+ next if $_ eq $lang; # Never print the current language
+ unless (get_selfname($_)) { warn "missing language $_"; next } #DEBUG
+ push @printed_langs, $_;
+ }
+ return "" unless scalar @printed_langs;
+ # Sort on uppercase to work with languages which use lowercase initial
+ # letters.
+ foreach my $cur_lang (sort langcmp @printed_langs) {
+ my $tooltip = dgettext( "langs", get_language_name($cur_lang) );
+ $str .= "<a href=\"$name.$cur_lang.html\" title=\"$tooltip\" hreflang=\"$cur_lang\" lang=\"$cur_lang\" rel=\"alternate\">".get_selfname($cur_lang);
+ $str .= " (".get_transliteration($cur_lang).")" if defined get_transliteration($cur_lang);
+ $str .= "</a>\n";
+ }
+ $str .= "\n</p><p>\n";
+ $str .= sprintf( gettext( "How to set <a href=\"%s\">the default document language</a></p>" ), $CN_HELP_URL );
+ $str .= "\n<!--/UdmComment-->\n";
+ }
+
+ return $str;
+}
+
+1;
projects / deb / packages.git / commitdiff