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