home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _208b5e379c1be261b61417e0e49a9b4c < prev    next >
Encoding:
Text File  |  2004-06-01  |  8.7 KB  |  311 lines
  1. package PPM::Search;
  2.  
  3. use strict;
  4. use Data::Dumper;
  5.  
  6. $PPM::Search::VERSION = '3.00';
  7.  
  8. #=============================================================================
  9. # Public API:
  10. # PPM::Search::->new($query, $case_insensitive);
  11. #   - Returns a new PPM::Search object
  12. #   - If there was a syntax error, searching will throw an exception
  13. #   - You can check for a syntax error using $object->valid
  14. #
  15. # PPM::Search::glob_to_regex($glob, $case_insensitive);
  16. #   - The function used internally to create the regular expressions used to
  17. #     match parts of the packages. Currently used by
  18. #     PPM::Repository::PPMServer to create server-executed regular
  19. #     expressions, saving client time. Assumes that the saved network
  20. #     bandwidth far outweighs the probability of the client machine being
  21. #     faster than the server.
  22. #
  23. # $object->valid();
  24. #   - Returns 1 if there were no syntax errors parsing the query.
  25. #   - Returns 0 otherwise.
  26. #
  27. # $object->error();
  28. #   - Returns the syntax error, or undef if there was no syntax error.
  29. #
  30. # $object->search(@packages);
  31. #   - Returns the subset of @packages which match the $query
  32. #
  33. # $object->match($package, $field, $regexp)
  34. #   - The method which applies the regexp to a field in the package. Must be
  35. #     overridden in subclasses, since the base class' just throws an
  36. #     exception.
  37. #=============================================================================
  38. sub new {
  39.     my ($pkg, $query, $casei) = @_;
  40.     my $self = bless {
  41.         'query' => $query,
  42.         'casei' => $casei,
  43.     }, ref($pkg) || $pkg;
  44.     my ($terms, $left) = $self->_query($self->{'query'});
  45.     unless (defined $terms and $left eq '') {
  46.     $self->{error} = "syntax error in query format: '$query'";
  47.     }
  48.     $self->{'terms'} = $terms;
  49.     $self;
  50. }
  51.  
  52. sub valid {
  53.     my $self = shift;
  54.     return 0 if exists $self->{error};
  55.     1;
  56. }
  57.  
  58. sub error {
  59.     my $self = shift;
  60.     $self->{error};
  61. }
  62.  
  63. sub search {
  64.     my ($self, @pkgs) = @_;
  65.     $self->do_search($self->{'terms'}, \@pkgs);
  66. }
  67.  
  68. sub match {
  69.     die "Must override match() method in subclass!";
  70. }
  71.  
  72. sub glob_to_regex {
  73.     my ($glob, $casei) = @_;
  74.     my $i = $casei ? '(?i)': '';
  75.  
  76.     # If the user specified any globs, remove the implicit globs surrounding
  77.     # their query:
  78.     my $globs = ($glob =~ /[?*]/);
  79.     my $l = $globs ? '^' : '';
  80.     my $r = $globs ? '$' : '';
  81.  
  82.     $glob =~ s/\\/\\\\/g; # Just to keep the regex valid
  83.     $glob =~ s/\./\\./g;
  84.     $glob =~ s/\?/./g;
  85.     $glob =~ s/\*/.*?/g;
  86.  
  87.     return qr/$l$i$glob$r/;
  88. }
  89.  
  90. #=============================================================================
  91. # Query matching code.
  92. #=============================================================================
  93. sub do_search {
  94.     my ($self, $terms, $matches) = @_;
  95.     my $op = shift @$terms;
  96.     return $self->do_and($terms, $matches) if $op eq 'and';
  97.     return $self->do_or ($terms, $matches) if $op eq 'or';
  98.     warn "Invalid search.\n";
  99.     return ();
  100. }
  101.  
  102. sub do_and {
  103.     my $self = shift;
  104.     my ($terms, $matches) = @_;
  105.     my @matches = @$matches;
  106.     for my $term (@$terms) {
  107.     if (ref $term eq 'HASH') {
  108.         @matches = 
  109.           grep { my $o = $self->match($_, $term->{field}, $term->{value});
  110.              $term->{not} ? not $o : $o 
  111.            } @matches;
  112.     }
  113.     elsif (ref $term eq 'ARRAY') {
  114.         @matches = $self->do_search($term, \@matches);
  115.     }
  116.     }
  117.     return @matches;
  118. }
  119.   
  120. sub do_or {
  121.     my $self = shift;
  122.     my ($terms, $matches) = @_;
  123.     my @matches;
  124.     my %matches;
  125.     for my $term (@$terms) {
  126.     my @new;
  127.     if (ref $term eq 'HASH') {
  128.         @new = (grep {my $o = $self->match($_, $term->{field}, $term->{value});
  129.               $term->{not} ? not $o : $o }
  130.             grep { not $matches{$_->name} }
  131.             @$matches);
  132.     }
  133.     elsif (ref $term eq 'ARRAY') {
  134.         @new = $self->do_search($term, $matches);
  135.     }
  136.     for my $n (@new) {
  137.             $matches{$n->name}++ and next;
  138.         push @matches, $n;
  139.         }
  140.     }
  141.     return @matches;
  142. }
  143.  
  144. #=============================================================================
  145. # Query parsing code.
  146. #=============================================================================
  147. sub _query {
  148.     my $self = shift;
  149.     my $query = shift;
  150.     my ($terms, $left) = $self->_terms($query);
  151.     return ($terms, $left) if ref $terms eq 'ARRAY';
  152.     ($terms, $left) = $self->_termopterms($query);
  153.     return ($terms, $left) if ref $terms eq 'ARRAY';
  154.     return (undef, $query);
  155. }
  156.  
  157. sub _termopterms {
  158.     my $self = shift;
  159.     my $query = shift;
  160.     my @terms = ('or', ['and']);
  161.     my ($yes1, $yes2, $left) = (undef, undef, $query);
  162.     while (1) {
  163.     ($yes1, $left) = $self->_term($left);
  164.     return (undef, $left) unless defined $yes1;
  165.     ($yes2, $left) = $self->_op($left);
  166.     push @{$terms[$#terms]}, $yes1;
  167.     last unless defined $yes2;
  168.     push @terms, ['and'] if $yes2 =~ /or/i;
  169.     }
  170.     return \@terms, $left;
  171. }
  172.  
  173. sub _terms {
  174.     my $self = shift;
  175.     my $query = shift;
  176.     my @terms = ('and');
  177.     my ($yes, $left) = (undef, $query);
  178.     while (1) {
  179.     ($yes, $left) = $self->_term($left);
  180.     last unless defined $yes;
  181.     push @terms, $yes;
  182.     }
  183.     return undef, $query unless $left eq '';
  184.     return \@terms, $left;
  185. }
  186.  
  187. sub _term {
  188.     my $self = shift;
  189.     my $query = shift;
  190.     my ($yes, $left) = $self->_term_1($query);
  191.     return ($yes, $left) if defined $yes;
  192.     ($yes, $left) = $self->_term_2($query);
  193.     return ($yes, $left) if defined $yes;
  194.     ($yes, $left) = $self->_term_3($query);
  195.     return ($yes, $left) if defined $yes;
  196.     return (undef, $query);
  197. }
  198.  
  199. sub _term_1 {
  200.     my $self = shift;
  201.     my $query = shift;
  202.     my $term = { not => 0 };
  203.     my ($yes, $left) = (undef, $query);
  204.     ($yes, $left) = $self->_not($left);
  205.     $term->{not} = 1 if defined $yes;
  206.     ($yes, $left) = $self->_field($left);
  207.     return (undef, $query) unless defined $yes;
  208.     return (undef, $query) unless $left =~ /^=/;
  209.     $term->{field} = $yes;
  210.     ($yes, $left) = $self->_glob2regex($self->_glob(substr($left, 1)));
  211.     return (undef, $query) unless defined $yes;
  212.     $term->{value} = $yes;
  213.     return ($term, $left);
  214. }
  215.  
  216. sub _term_2 {
  217.     my $self = shift;
  218.     my $query = shift;
  219.     my $term = { not => 0 };
  220.     my ($yes, $left) = (undef, $query);
  221.     ($yes, $left) =  $self->_not($left);
  222.     $term->{not} = 1 if defined $yes;
  223.     ($yes, $left) = $self->_glob2regex($self->_glob($left));
  224.     return (undef, $query) unless defined $yes;
  225.     $term->{value} = $yes;
  226.     $term->{field} = "NAME";
  227.     return ($term, $left);
  228. }
  229.  
  230. sub _term_3 {
  231.     my $self = shift;
  232.     my $query = shift;
  233.     my ($yes, $left) = (undef, $query);
  234.     return (undef, $query) unless $left =~ s/^\s*\(//;
  235.     ($yes, $left) = $self->_query($left);
  236.     return (undef, $query) unless defined $yes;
  237.     return (undef, $query) unless $left =~ s/^\s*\)//;
  238.     return ($yes, $left);
  239. }
  240.  
  241. # Returns (OP, REMAINDER) or (undef, QUERY) on failure
  242. sub _op {
  243.     my $self = shift;
  244.     my $query = shift;
  245.     return 'and', $query if $query =~ s/^\s*and\s+//i;
  246.     return 'or', $query if $query =~ s/^\s*or\s+//i;
  247.     return undef, $query;
  248. }
  249.  
  250. # Returns (OP, REMAINDER) or (undef, QUERY) on failure
  251. sub _not {
  252.     my $self = shift;
  253.     my $query = shift;
  254.     return 'not', $query if $query =~ s/^\s*not\s+//i;
  255.     return undef, $query;
  256. }
  257.  
  258. # Returns (OP, REMAINDER) or (undef, QUERY) on failure
  259. sub _field {
  260.     my $self = shift;
  261.     my $query = shift;
  262.     return $1, $query 
  263.       if $query =~ s/^\s*([A-Za-z_][A-Za-z0-9_]*)//;
  264.     return undef, $query;
  265. }
  266.  
  267. # Returns (OP, REMAINDER) or (undef, QUERY) on failure
  268. sub _glob {
  269.     my $self = shift;
  270.     my $query = shift;
  271.     my ($yes, $left);
  272.     ($yes, $left) = $self->_glob_1($query);
  273.     return ($yes, $left) if defined $yes;
  274.     ($yes, $left) = $self->_glob_2($query);
  275.     return ($yes, $left) if defined $yes;
  276.     return undef, $query;
  277. }
  278.  
  279. # Returns (OP, REMAINDER) or (undef, QUERY) on failure
  280. sub _glob_1 {
  281.     my $self = shift;
  282.     my $query = shift;
  283.     return $1, substr($query, length($1))
  284.       if $query =~ /^([][\-:\.^\$,\w*?\\]+)/;
  285.     return undef, $query;
  286. }
  287.  
  288. my $quoted_re = qr'(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\")|(?:\')(?:[^\\\']*(?:\\.[^\\\']*)*)(?:\')|(?:\`)(?:[^\\\`]*(?:\\.[^\\\`]*)*)(?:\`))';
  289.  
  290. # Returns (OP, REMAINDER) or (undef, QUERY) on failure
  291. sub _glob_2 {
  292.     my $self = shift;
  293.     my $query = shift;
  294.     if ($query =~ s/^($quoted_re)//) {
  295.     my $quoted = $1;
  296.     substr($quoted, 0, 1) = "";
  297.     substr($quoted, -1) = "";
  298.     return $quoted, $query;
  299.     }
  300.     return undef, $query;
  301. }
  302.  
  303. sub _glob2regex {
  304.     my $self = shift;
  305.     my $glob = shift;
  306.     return (undef, @_) unless defined $glob;
  307.     return glob_to_regex($glob, $self->{casei}), @_;
  308. }
  309.  
  310. 1;
  311.