lib/Packages/Search.pm

   1 #
   2 # Packages::Search
   3 #
   4 # Copyright (C) 2004-2006 Frank Lichtenheld <frank@lichtenheld.de>
   5 #
   6 # The code is based on the old search_packages.pl script that
   7 # was:
   8 #
   9 # Copyright (C) 1998 James Treacy
  10 # Copyright (C) 2000, 2001 Josip Rodin
  11 # Copyright (C) 2001 Adam Heath
  12 # Copyright (C) 2004 Martin Schulze
  13 #
  14 #    This program is free software; you can redistribute it and/or modify
  15 #    it under the terms of the GNU General Public License as published by
  16 #    the Free Software Foundation; either version 1 of the License, or
  17 #    (at your option) any later version.
  18 #
  19 #    This program is distributed in the hope that it will be useful,
  20 #    but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 #    GNU General Public License for more details.
  23 #
  24 #    You should have received a copy of the GNU General Public License
  25 #    along with this program; if not, write to the Free Software
  26 #    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  27 #
  28
  29 =head1 NAME
  30
  31 Packages::Search -
  32
  33 =head1 SYNOPSIS
  34
  35 =head1 DESCRIPTION
  36
  37 =over 4
  38
  39 =cut
  40
  41 package Packages::Search;
  42
  43 use strict;
  44 use warnings;
  45
  46 use CGI qw( -oldstyle_urls );
  47 use POSIX;
  48 use HTML::Entities;
  49 use DB_File;
  50
  51 use Deb::Versions;
  52 use Packages::CGI;
  53 use Exporter;
  54
  55 our @ISA = qw( Exporter );
  56
  57 our @EXPORT_OK = qw( nextlink prevlink indexline
  58                      resperpagelink
  59                      read_entry read_entry_all read_entry_simple
  60                      read_src_entry read_src_entry_all find_binaries
  61                      do_names_search do_fulltext_search
  62                      printindexline multipageheader );
  63 our %EXPORT_TAGS = ( all => [ @EXPORT_OK ] );
  64
  65 our $VERSION = 0.01;
  66
  67 our $USE_PAGED_MODE = 1;
  68 use constant DEFAULT_PAGE => 1;
  69 use constant DEFAULT_RES_PER_PAGE => 50;
  70 our %page_params = ( page => { default => DEFAULT_PAGE,
  71                                match => '(\d+)' },
  72                      number => { default => DEFAULT_RES_PER_PAGE,
  73                                  match => '(\d+)' } );
  74
  75 our $too_many_hits = 0;
  76
  77 sub parse_params {
  78     my ( $cgi, $params_def, $opts ) = @_;
  79
  80     my %params_ret = ( values => {}, errors => {} );
  81     my %params;
  82     if ($USE_PAGED_MODE) {
  83         debug( "Use PAGED_MODE", 2 );
  84         %params = %$params_def;
  85         foreach (keys %page_params) {
  86             delete $params{$_};
  87         }
  88         %params = ( %params, %page_params );
  89     } else {
  90         %params = %$params_def;
  91     }
  92
  93     foreach my $param ( keys %params ) {
  94
  95         debug( "Param <strong>$param</strong>", 2 );
  96
  97         my $p_value_orig = $cgi->param($param);
  98
  99         if (!defined($p_value_orig)
 100             && defined $params_def->{$param}{alias}
 101             && defined $cgi->param($params_def->{$param}{alias})) {
 102             $p_value_orig = $cgi->param($params_def->{$param}{alias});
 103             debug( "Used alias <strong>$params_def->{$param}{alias}</strong>",
 104                    2 );
 105         }
 106
 107         my @p_value = ($p_value_orig);
 108
 109         debug( "Value (Orig) ".($p_value_orig||""), 2 );
 110
 111         if ($params_def->{$param}{array} && defined $p_value_orig) {
 112             @p_value = split /$params_def->{$param}{array}/, $p_value_orig;
 113             debug( "Value (Array Split) ". join('##',@p_value), 2 );
 114         }
 115
 116         if ($params_def->{$param}{match} && defined $p_value_orig) {
 117             @p_value = map
 118             { $_ =~ m/$params_def->{$param}{match}/; $_ = $1 }
 119             @p_value;
 120         }
 121         @p_value = grep { defined $_ } @p_value;
 122
 123         debug( "Value (Match) ". join('##',@p_value), 2 );
 124
 125         unless (@p_value) {
 126             if (defined $params{$param}{default}) {
 127                 @p_value = ($params{$param}{default});
 128             } else {
 129                 @p_value = undef;
 130                 $params_ret{errors}{$param} = "undef";
 131                 next;
 132             }
 133         }
 134
 135         debug( "Value (Default) ". join('##',@p_value), 2 );
 136         my @p_value_no_replace = @p_value;
 137
 138         if ($params{$param}{replace} && @p_value) {
 139             @p_value = ();
 140             foreach my $pattern (keys %{$params{$param}{replace}}) {
 141                 foreach (@p_value_no_replace) {
 142                     if ($_ eq $pattern) {
 143                         my $replacement = $params{$param}{replace}{$_};
 144                         if (ref $replacement) {
 145                             push @p_value, @$replacement;
 146                         } else {
 147                             push @p_value, $replacement;
 148                         }
 149                     } else {
 150                         push @p_value, $_;
 151                     }
 152                 }
 153             }
 154         }
 155
 156         debug( "Value (Final) ". join('##',@p_value), 2 );
 157
 158         if ($params_def->{$param}{array}) {
 159             $params_ret{values}{$param} = {
 160                 orig => $p_value_orig,
 161                 no_replace => \@p_value_no_replace,
 162                 final => \@p_value,
 163             };
 164             @{$params_def->{$param}{var}} = @p_value
 165                 if $params_def->{$param}{var};
 166         } else {
 167             $params_ret{values}{$param} = {
 168                 orig => $p_value_orig,
 169                 no_replace => $p_value_no_replace[0],
 170                 final => $p_value[0],
 171             };
 172             ${$params_def->{$param}{var}} = $p_value[0]
 173                 if $params_def->{$param}{var};
 174         }
 175         $opts->{$param} = $params_ret{values}{$param}{final} if $opts;
 176     }
 177
 178     if ($USE_PAGED_MODE) {
 179         $cgi->delete( "page" );
 180         $cgi->delete( "number" );
 181     }
 182
 183     return %params_ret;
 184 }
 185
 186 sub start {
 187     my $params = shift;
 188
 189     my $page = $params->{values}{page}{final}
 190     || DEFAULT_PAGE;
 191     my $res_per_page = $params->{values}{number}{final}
 192     || DEFAULT_RES_PER_PAGE;
 193
 194     return 1 if $res_per_page =~ /^all$/i;
 195     return $res_per_page * ($page - 1) + 1;
 196 }
 197
 198 sub end {
 199     my $params = shift;
 200
 201     use Data::Dumper;
 202     debug( "end: ".Dumper($params) );
 203     my $page = $params->{page}
 204     || DEFAULT_PAGE;
 205     my $res_per_page = $params->{number}
 206     || DEFAULT_RES_PER_PAGE;
 207
 208     return $page * $res_per_page;
 209 }
 210
 211 sub indexline {
 212     my ($cgi, $params, $num_res) = @_;
 213
 214     my $index_line = "";
 215     my $page = $params->{page}
 216     || DEFAULT_PAGE;
 217     my $res_per_page = $params->{number}
 218     || DEFAULT_RES_PER_PAGE;
 219     my $numpages = ceil($num_res /
 220                         $res_per_page);
 221     for (my $i = 1; $i <= $numpages; $i++) {
 222         if ($i == $page) {
 223             $index_line .= $i;
 224         } else {
 225             $index_line .= "<a href=\"".encode_entities($cgi->self_url).
 226                 "&amp;page=$i&amp;number=$res_per_page\">".
 227                 "$i</a>";
 228         }
 229         if ($i < $numpages) {
 230            $index_line .= " | ";
 231         }
 232     }
 233     return $index_line;
 234 }
 235
 236 sub nextlink {
 237     my ($cgi, $params, $no_results ) = @_;
 238
 239     my $page = $params->{page}
 240     || DEFAULT_PAGE;
 241     $page++;
 242     my $res_per_page = $params->{number}
 243     || DEFAULT_RES_PER_PAGE;
 244
 245     if ((($page-1)*$res_per_page + 1) > $no_results) {
 246         return "&gt;&gt;";
 247     }
 248
 249     return "<a href=\"".encode_entities($cgi->self_url).
 250         "&amp;page=$page&amp;number=$res_per_page\">&gt;&gt;</a>";
 251 }
 252
 253 sub prevlink {
 254     my ($cgi, $params ) = @_;
 255
 256     my $page = $params->{page}
 257     || DEFAULT_PAGE;
 258     $page--;
 259     if (!$page) {
 260         return "&lt;&lt;";
 261     }
 262
 263     my $res_per_page = $params->{number}
 264     || DEFAULT_RES_PER_PAGE;
 265
 266     return "<a href=\"".encode_entities($cgi->self_url).
 267         "&amp;page=$page&amp;number=$res_per_page\">&lt;&lt;</a>";
 268 }
 269
 270 sub resperpagelink {
 271     my ($cgi, $params, $res_per_page ) = @_;
 272
 273     my $page;
 274     if ($res_per_page =~ /^all$/i) {
 275         $page = 1;
 276     } else {
 277         $page = ceil(start( $params ) / $res_per_page);
 278     }
 279
 280     return "<a href=\"".encode_entities($cgi->self_url).
 281         "&amp;page=$page&amp;number=$res_per_page\">$res_per_page</a>";
 282 }
 283
 284 sub printindexline {
 285     my ( $input, $no_results, $opts ) = @_;
 286
 287     my $index_line;
 288     if ($no_results > $opts->{number}) {
 289
 290         $index_line = prevlink( $input, $opts)." | ".
 291             indexline( $input, $opts, $no_results)." | ".
 292             nextlink( $input, $opts, $no_results);
 293
 294         print "<p style=\"text-align:center\">$index_line</p>";
 295     }
 296 }
 297
 298 sub multipageheader {
 299     my ( $input, $no_results, $opts ) = @_;
 300
 301     my ($start, $end);
 302     if ($opts->{number} =~ /^all$/i) {
 303         $start = 1;
 304         $end = $no_results;
 305         $opts->{number} = $no_results;
 306         $opts->{number_all}++;
 307     } else {
 308         $start = Packages::Search::start( $opts );
 309         $end = Packages::Search::end( $opts );
 310         if ($end > $no_results) { $end = $no_results; }
 311     }
 312
 313     print "<p>Found <em>$no_results</em> matching packages,";
 314     if ($end == $start) {
 315         print " displaying package $end.</p>";
 316     } else {
 317         print " displaying packages $start to $end.</p>";
 318     }
 319
 320     printindexline( $input, $no_results, $opts );
 321
 322     if ($no_results > 100) {
 323         print "<p>Results per page: ";
 324         my @resperpagelinks;
 325         for (50, 100, 200) {
 326             if ($opts->{number} == $_) {
 327                 push @resperpagelinks, $_;
 328             } else {
 329                 push @resperpagelinks, resperpagelink($input,$opts,$_);
 330             }
 331         }
 332         if ($opts->{number_all}) {
 333             push @resperpagelinks, "all";
 334         } else {
 335             push @resperpagelinks, resperpagelink($input, $opts, "all");
 336         }
 337         print join( " | ", @resperpagelinks )."</p>";
 338     }
 339     return ( $start, $end );
 340 }
 341
 342 sub read_entry_all {
 343     my ($hash, $key, $results, $non_results, $opts) = @_;
 344     my $result = $hash->{$key} || '';
 345     foreach (split /\000/o, $result) {
 346         my @data = split ( /\s/o, $_, 8 );
 347         debug( "Considering entry ".join( ':', @data), 2);
 348         if ($opts->{h_archives}{$data[0]} && $opts->{h_suites}{$data[1]}
 349             && ($opts->{h_archs}{$data[2]} || $data[2] eq 'all'
 350                 || $data[2] eq 'virtual')
 351             && ($opts->{h_sections}{$data[3]} || $data[3] eq 'v')) {
 352             debug( "Using entry ".join( ':', @data), 2);
 353             push @$results, [ $key, @data ];
 354         } else {
 355             push @$non_results, [ $key, @data ];
 356         }
 357     }
 358 }
 359 sub read_entry {
 360     my ($hash, $key, $results, $opts) = @_;
 361     my @non_results;
 362     read_entry_all( $hash, $key, $results, \@non_results, $opts );
 363 }
 364 sub read_entry_simple {
 365     my ($hash, $key, $archives, $suite) = @_;
 366     my $result = $hash->{$key} || '';
 367     my @data_fuzzy;
 368     foreach (split /\000/o, $result) {
 369         my @data = split ( /\s/o, $_, 8 );
 370         debug( "Considering entry ".join( ':', @data), 2);
 371         if ($data[1] eq $suite) {
 372             if ($archives->{$data[0]}) {
 373                 debug( "Using entry ".join( ':', @data), 2);
 374                 return \@data;
 375             } elsif ($data[0] eq 'us') {
 376                 debug( "Fuzzy entry ".join( ':', @data), 2);
 377                 @data_fuzzy = @data;
 378             }
 379         }
 380     }
 381     return \@data_fuzzy;
 382 }
 383 sub read_src_entry_all {
 384     my ($hash, $key, $results, $non_results, $opts) = @_;
 385     my $result = $hash->{$key} || '';
 386     foreach (split /\000/o, $result) {
 387         my @data = split ( /\s/o, $_, 6 );
 388         debug( "Considering entry ".join( ':', @data), 2);
 389         if ($opts->{h_archives}{$data[0]}
 390             && $opts->{h_suites}{$data[1]}
 391             && $opts->{h_sections}{$data[2]}) {
 392             debug( "Using entry ".join( ':', @data), 2);
 393             push @$results, [ $key, @data ];
 394         } else {
 395             push @$non_results, [ $key, @data ];
 396         }
 397     }
 398 }
 399 sub read_src_entry {
 400     my ($hash, $key, $results, $opts) = @_;
 401     my @non_results;
 402     read_src_entry_all( $hash, $key, $results, \@non_results, $opts );
 403 }
 404 sub do_names_search {
 405     my ($keyword, $packages, $postfixes, $read_entry, $opts) = @_;
 406     my @results;
 407
 408     $keyword = lc $keyword unless $opts->{case_bool};
 409
 410     if ($opts->{exact}) {
 411         &$read_entry( $packages, $keyword, \@results, $opts );
 412     } else {
 413         my ($key, $prefixes) = ($keyword, '');
 414         my %pkgs;
 415         $postfixes->seq( $key, $prefixes, R_CURSOR );
 416         while (index($key, $keyword) >= 0) {
 417             if ($prefixes =~ /^\001(\d+)/o) {
 418                 $too_many_hits += $1;
 419             } else {
 420                 foreach (split /\000/o, $prefixes) {
 421                     $_ = '' if $_ eq '^';
 422                     debug( "add word $_$key", 2);
 423                     $pkgs{$_.$key}++;
 424                 }
 425             }
 426             last if $postfixes->seq( $key, $prefixes, R_NEXT ) != 0;
 427             last if $too_many_hits or keys %pkgs >= 100;
 428         }
 429
 430         my $no_results = keys %pkgs;
 431         if ($too_many_hits || ($no_results >= 100)) {
 432             $too_many_hits += $no_results;
 433             %pkgs = ( $keyword => 1 );
 434         }
 435         foreach my $pkg (sort keys %pkgs) {
 436             &$read_entry( $packages, $pkg, \@results, $opts );
 437         }
 438     }
 439     return \@results;
 440 }
 441 sub do_fulltext_search {
 442     my ($keyword, $file, $did2pkg, $packages, $read_entry, $opts) = @_;
 443     my @results;
 444
 445 # NOTE: this needs to correspond with parse-packages!
 446     my @lines;
 447     $keyword =~ tr [A-Z] [a-z];
 448     if ($opts->{exact}) {
 449         $keyword = " $keyword ";
 450     }
 451     $keyword =~ s/[(),.-]+//og;
 452     $keyword =~ s#[^a-z0-9_/+]+# #og;
 453
 454     open DESC, '<', "$file"
 455         or die "couldn't open $file: $!";
 456     while (<DESC>) {
 457         next if index $_, $keyword < 0;
 458         debug( "Matched line $.", 2);
 459         push @lines, $.;
 460     }
 461     close DESC;
 462
 463     my %tmp_results;
 464     foreach my $l (@lines) {
 465         my $result = $did2pkg->{$l};
 466         foreach (split /\000/o, $result) {
 467             my @data = split /\s/, $_, 3;
 468             next unless $opts->{h_archs}{$data[2]};
 469             $tmp_results{$data[0]}++;
 470         }
 471     }
 472     foreach my $pkg (keys %tmp_results) {
 473         &$read_entry( $packages, $pkg, \@results, $opts );
 474     }
 475     return \@results;
 476 }
 477
 478 sub find_binaries {
 479     my ($pkg, $archive, $suite, $src2bin) = @_;
 480
 481     my $bins = $src2bin->{$pkg} || '';
 482     my %bins;
 483     foreach (split /\000/o, $bins) {
 484         my @data = split /\s/, $_, 5;
 485
 486         debug( "find_binaries: considering @data", 3 );
 487         if (($data[0] eq $archive)
 488             && ($data[1] eq $suite)) {
 489             $bins{$data[2]}++;
 490             debug( "find_binaries: using @data", 3 );
 491         }
 492     }
 493
 494     return [ keys %bins ];
 495 }
 496
 497
 498 1;