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_src_entry find_binaries
  60                      do_names_search do_fulltext_search
  61                      printindexline multipageheader );
  62 our %EXPORT_TAGS = ( all => [ @EXPORT_OK ] );
  63
  64 our $VERSION = 0.01;
  65
  66 our $USE_PAGED_MODE = 1;
  67 use constant DEFAULT_PAGE => 1;
  68 use constant DEFAULT_RES_PER_PAGE => 50;
  69 our %page_params = ( page => { default => DEFAULT_PAGE,
  70                                match => '(\d+)' },
  71                      number => { default => DEFAULT_RES_PER_PAGE,
  72                                  match => '(\d+)' } );
  73
  74 our $too_many_hits = 0;
  75
  76 sub parse_params {
  77     my ( $cgi, $params_def, $opts ) = @_;
  78
  79     my %params_ret = ( values => {}, errors => {} );
  80     my %params;
  81     if ($USE_PAGED_MODE) {
  82         debug( "Use PAGED_MODE", 2 );
  83         %params = %$params_def;
  84         foreach (keys %page_params) {
  85             delete $params{$_};
  86         }
  87         %params = ( %params, %page_params );
  88     } else {
  89         %params = %$params_def;
  90     }
  91
  92     foreach my $param ( keys %params ) {
  93
  94         debug( "Param <strong>$param</strong>", 2 );
  95
  96         my $p_value_orig = $cgi->param($param);
  97
  98         if (!defined($p_value_orig)
  99             && defined $params_def->{$param}{alias}
 100             && defined $cgi->param($params_def->{$param}{alias})) {
 101             $p_value_orig = $cgi->param($params_def->{$param}{alias});
 102             debug( "Used alias <strong>$params_def->{$param}{alias}</strong>",
 103                    2 );
 104         }
 105
 106         my @p_value = ($p_value_orig);
 107
 108         debug( "Value (Orig) ".($p_value_orig||""), 2 );
 109
 110         if ($params_def->{$param}{array} && defined $p_value_orig) {
 111             @p_value = split /$params_def->{$param}{array}/, $p_value_orig;
 112             debug( "Value (Array Split) ". join('##',@p_value), 2 );
 113         }
 114
 115         if ($params_def->{$param}{match} && defined $p_value_orig) {
 116             @p_value = map
 117             { $_ =~ m/$params_def->{$param}{match}/; $_ = $1 }
 118             @p_value;
 119         }
 120         @p_value = grep { defined $_ } @p_value;
 121
 122         debug( "Value (Match) ". join('##',@p_value), 2 );
 123
 124         unless (@p_value) {
 125             if (defined $params{$param}{default}) {
 126                 @p_value = ($params{$param}{default});
 127             } else {
 128                 @p_value = undef;
 129                 $params_ret{errors}{$param} = "undef";
 130                 next;
 131             }
 132         }
 133
 134         debug( "Value (Default) ". join('##',@p_value), 2 );
 135         my @p_value_no_replace = @p_value;
 136
 137         if ($params{$param}{replace} && @p_value) {
 138             @p_value = ();
 139             foreach my $pattern (keys %{$params{$param}{replace}}) {
 140                 foreach (@p_value_no_replace) {
 141                     if ($_ eq $pattern) {
 142                         my $replacement = $params{$param}{replace}{$_};
 143                         if (ref $replacement) {
 144                             push @p_value, @$replacement;
 145                         } else {
 146                             push @p_value, $replacement;
 147                         }
 148                     } else {
 149                         push @p_value, $_;
 150                     }
 151                 }
 152             }
 153         }
 154
 155         debug( "Value (Final) ". join('##',@p_value), 2 );
 156
 157         if ($params_def->{$param}{array}) {
 158             $params_ret{values}{$param} = {
 159                 orig => $p_value_orig,
 160                 no_replace => \@p_value_no_replace,
 161                 final => \@p_value,
 162             };
 163             @{$params_def->{$param}{var}} = @p_value
 164                 if $params_def->{$param}{var};
 165         } else {
 166             $params_ret{values}{$param} = {
 167                 orig => $p_value_orig,
 168                 no_replace => $p_value_no_replace[0],
 169                 final => $p_value[0],
 170             };
 171             ${$params_def->{$param}{var}} = $p_value[0]
 172                 if $params_def->{$param}{var};
 173         }
 174         $opts->{$param} = $params_ret{values}{$param}{final} if $opts;
 175     }
 176
 177     if ($USE_PAGED_MODE) {
 178         $cgi->delete( "page" );
 179         $cgi->delete( "number" );
 180     }
 181
 182     return %params_ret;
 183 }
 184
 185 sub start {
 186     my $params = shift;
 187
 188     my $page = $params->{values}{page}{final}
 189     || DEFAULT_PAGE;
 190     my $res_per_page = $params->{values}{number}{final}
 191     || DEFAULT_RES_PER_PAGE;
 192
 193     return 1 if $res_per_page =~ /^all$/i;
 194     return $res_per_page * ($page - 1) + 1;
 195 }
 196
 197 sub end {
 198     my $params = shift;
 199
 200     use Data::Dumper;
 201     debug( "end: ".Dumper($params) );
 202     my $page = $params->{page}
 203     || DEFAULT_PAGE;
 204     my $res_per_page = $params->{number}
 205     || DEFAULT_RES_PER_PAGE;
 206
 207     return $page * $res_per_page;
 208 }
 209
 210 sub indexline {
 211     my ($cgi, $params, $num_res) = @_;
 212
 213     my $index_line = "";
 214     my $page = $params->{page}
 215     || DEFAULT_PAGE;
 216     my $res_per_page = $params->{number}
 217     || DEFAULT_RES_PER_PAGE;
 218     my $numpages = ceil($num_res /
 219                         $res_per_page);
 220     for (my $i = 1; $i <= $numpages; $i++) {
 221         if ($i == $page) {
 222             $index_line .= $i;
 223         } else {
 224             $index_line .= "<a href=\"".encode_entities($cgi->self_url).
 225                 "&amp;page=$i&amp;number=$res_per_page\">".
 226                 "$i</a>";
 227         }
 228         if ($i < $numpages) {
 229            $index_line .= " | ";
 230         }
 231     }
 232     return $index_line;
 233 }
 234
 235 sub nextlink {
 236     my ($cgi, $params, $no_results ) = @_;
 237
 238     my $page = $params->{page}
 239     || DEFAULT_PAGE;
 240     $page++;
 241     my $res_per_page = $params->{number}
 242     || DEFAULT_RES_PER_PAGE;
 243
 244     if ((($page-1)*$res_per_page + 1) > $no_results) {
 245         return "&gt;&gt;";
 246     }
 247
 248     return "<a href=\"".encode_entities($cgi->self_url).
 249         "&amp;page=$page&amp;number=$res_per_page\">&gt;&gt;</a>";
 250 }
 251
 252 sub prevlink {
 253     my ($cgi, $params ) = @_;
 254
 255     my $page = $params->{page}
 256     || DEFAULT_PAGE;
 257     $page--;
 258     if (!$page) {
 259         return "&lt;&lt;";
 260     }
 261
 262     my $res_per_page = $params->{number}
 263     || DEFAULT_RES_PER_PAGE;
 264
 265     return "<a href=\"".encode_entities($cgi->self_url).
 266         "&amp;page=$page&amp;number=$res_per_page\">&lt;&lt;</a>";
 267 }
 268
 269 sub resperpagelink {
 270     my ($cgi, $params, $res_per_page ) = @_;
 271
 272     my $page;
 273     if ($res_per_page =~ /^all$/i) {
 274         $page = 1;
 275     } else {
 276         $page = ceil(start( $params ) / $res_per_page);
 277     }
 278
 279     return "<a href=\"".encode_entities($cgi->self_url).
 280         "&amp;page=$page&amp;number=$res_per_page\">$res_per_page</a>";
 281 }
 282
 283 sub printindexline {
 284     my ( $input, $no_results, $opts ) = @_;
 285
 286     my $index_line;
 287     if ($no_results > $opts->{number}) {
 288
 289         $index_line = prevlink( $input, $opts)." | ".
 290             indexline( $input, $opts, $no_results)." | ".
 291             nextlink( $input, $opts, $no_results);
 292
 293         print "<p style=\"text-align:center\">$index_line</p>";
 294     }
 295 }
 296
 297 sub multipageheader {
 298     my ( $input, $no_results, $opts ) = @_;
 299
 300     my ($start, $end);
 301     if ($opts->{number} =~ /^all$/i) {
 302         $start = 1;
 303         $end = $no_results;
 304         $opts->{number} = $no_results;
 305         $opts->{number_all}++;
 306     } else {
 307         $start = Packages::Search::start( $opts );
 308         $end = Packages::Search::end( $opts );
 309         if ($end > $no_results) { $end = $no_results; }
 310     }
 311
 312     print "<p>Found <em>$no_results</em> matching packages,";
 313     if ($end == $start) {
 314         print " displaying package $end.</p>";
 315     } else {
 316         print " displaying packages $start to $end.</p>";
 317     }
 318
 319     printindexline( $input, $no_results, $opts );
 320
 321     if ($no_results > 100) {
 322         print "<p>Results per page: ";
 323         my @resperpagelinks;
 324         for (50, 100, 200) {
 325             if ($opts->{number} == $_) {
 326                 push @resperpagelinks, $_;
 327             } else {
 328                 push @resperpagelinks, resperpagelink($input,$opts,$_);
 329             }
 330         }
 331         if ($opts->{number_all}) {
 332             push @resperpagelinks, "all";
 333         } else {
 334             push @resperpagelinks, resperpagelink($input, $opts, "all");
 335         }
 336         print join( " | ", @resperpagelinks )."</p>";
 337     }
 338     return ( $start, $end );
 339 }
 340
 341 sub read_entry {
 342     my ($hash, $key, $results, $opts) = @_;
 343     my $result = $hash->{$key} || '';
 344     foreach (split /\000/, $result) {
 345         my @data = split ( /\s/, $_, 8 );
 346         debug( "Considering entry ".join( ':', @data), 2);
 347         if ($opts->{h_archives}{$data[0]} && $opts->{h_suites}{$data[1]}
 348             && ($opts->{h_archs}{$data[2]} || $data[2] eq 'all')
 349             && $opts->{h_sections}{$data[3]}) {
 350             debug( "Using entry ".join( ':', @data), 2);
 351             push @$results, [ $key, @data ];
 352         }
 353     }
 354 }
 355 sub read_src_entry {
 356     my ($hash, $key, $results, $opts) = @_;
 357     my $result = $hash->{$key} || '';
 358     foreach (split /\000/, $result) {
 359         my @data = split ( /\s/, $_, 6 );
 360         debug( "Considering entry ".join( ':', @data), 2);
 361         if ($opts->{h_archives}{$data[0]}
 362             && $opts->{h_suites}{$data[1]}
 363             && $opts->{h_sections}{$data[2]}) {
 364             debug( "Using entry ".join( ':', @data), 2);
 365             push @$results, [ $key, @data ];
 366         }
 367     }
 368 }
 369 sub do_names_search {
 370     my ($keyword, $packages, $postfixes, $read_entry, $opts) = @_;
 371     my @results;
 372
 373     $keyword = lc $keyword unless $opts->{case_bool};
 374
 375     if ($opts->{exact}) {
 376         &$read_entry( $packages, $keyword, \@results, $opts );
 377     } else {
 378         my ($key, $prefixes) = ($keyword, '');
 379         my %pkgs;
 380         $postfixes->seq( $key, $prefixes, R_CURSOR );
 381         while (index($key, $keyword) >= 0) {
 382             if ($prefixes =~ /^\001(\d+)/o) {
 383                 $too_many_hits += $1;
 384             } else {
 385                 foreach (split /\000/o, $prefixes) {
 386                     $_ = '' if $_ eq '^';
 387                     debug( "add word $_$key", 2);
 388                     $pkgs{$_.$key}++;
 389                 }
 390             }
 391             last if $postfixes->seq( $key, $prefixes, R_NEXT ) != 0;
 392             last if $too_many_hits or keys %pkgs >= 100;
 393         }
 394
 395         my $no_results = keys %pkgs;
 396         if ($too_many_hits || ($no_results >= 100)) {
 397             $too_many_hits += $no_results;
 398             %pkgs = ( $keyword => 1 );
 399         }
 400         foreach my $pkg (sort keys %pkgs) {
 401             &$read_entry( $packages, $pkg, \@results, $opts );
 402         }
 403     }
 404     return \@results;
 405 }
 406 sub do_fulltext_search {
 407     my ($keyword, $file, $did2pkg, $packages, $read_entry, $opts) = @_;
 408     my @results;
 409
 410     my @lines;
 411     my $regex;
 412     if ($opts->{case_bool}) {
 413         if ($opts->{exact}) {
 414             $regex = qr/\b\Q$keyword\E\b/o;
 415         } else {
 416             $regex = qr/\Q$keyword\E/o;
 417         }
 418     } else {
 419         if ($opts->{exact}) {
 420             $regex = qr/\b\Q$keyword\E\b/io;
 421         } else {
 422             $regex = qr/\Q$keyword\E/io;
 423         }
 424     }
 425
 426     open DESC, '<', "$file"
 427         or die "couldn't open $file: $!";
 428     while (<DESC>) {
 429         $_ =~ $regex or next;
 430         debug( "Matched line $.", 2);
 431         push @lines, $.;
 432     }
 433     close DESC;
 434
 435     my %tmp_results;
 436     foreach my $l (@lines) {
 437         my $result = $did2pkg->{$l};
 438         foreach (split /\000/o, $result) {
 439             my @data = split /\s/, $_, 3;
 440             next unless $opts->{h_archs}{$data[2]};
 441             $tmp_results{$data[0]}++;
 442         }
 443     }
 444     foreach my $pkg (keys %tmp_results) {
 445         &$read_entry( $packages, $pkg, \@results, $opts );
 446     }
 447     return \@results;
 448 }
 449
 450 sub find_binaries {
 451     my ($pkg, $archive, $suite, $src2bin) = @_;
 452
 453     my $bins = $src2bin->{$pkg} || '';
 454     my %bins;
 455     foreach (split /\000/o, $bins) {
 456         my @data = split /\s/, $_, 5;
 457
 458         if (($data[0] eq $archive)
 459             && ($data[1] eq $suite)) {
 460             $bins{$data[2]}++;
 461         }
 462     }
 463
 464     return [ keys %bins ];
 465 }
 466
 467
 468 1;