home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.6.1.638-MSWin32-x86.msi / _208b5e379c1be261b61417e0e49a9b4c < prev    next >
Encoding:
Text File  |  2004-04-13  |  8.6 KB  |  310 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;
  83.     $glob =~ s/\?/./g;
  84.     $glob =~ s/\*/.*?/g;
  85.  
  86.     return qr/$l$i$glob$r/;
  87. }
  88.  
  89. #=============================================================================
  90. # Query matching code.
  91. #=============================================================================
  92. sub do_search {
  93.     my ($self, $terms, $matches) = @_;
  94.     my $op = shift @$terms;
  95.     return $self->do_and($terms, $matches) if $op eq 'and';
  96.     return $self->do_or ($terms, $matches) if $op eq 'or';
  97.     warn "Invalid search.\n";
  98.     return ();
  99. }
  100.  
  101. sub do_and {
  102.     my $self = shift;
  103.     my ($terms, $matches) = @_;
  104.     my @matches = @$matches;
  105.     for my $term (@$terms) {
  106.     if (ref $term eq 'HASH') {
  107.         @matches = 
  108.           grep { my $o = $self->match($_, $term->{field}, $term->{value});
  109.              $term->{not} ? not $o : $o 
  110.            } @matches;
  111.     }
  112.     elsif (ref $term eq 'ARRAY') {
  113.         @matches = $self->do_search($term, \@matches);
  114.     }
  115.     }
  116.     return @matches;
  117. }
  118.   
  119. sub do_or {
  120.     my $self = shift;
  121.     my ($terms, $matches) = @_;
  122.     my @matches;
  123.     my %matches;
  124.     for my $term (@$terms) {
  125.     my @new;
  126.     if (ref $term eq 'HASH') {
  127.         @new = (grep {my $o = $self->match($_, $term->{field}, $term->{value});
  128.               $term->{not} ? not $o : $o }
  129.             grep { not $matches{$_->name} }
  130.             @$matches);
  131.     }
  132.     elsif (ref $term eq 'ARRAY') {
  133.         @new = $self->do_search($term, $matches);
  134.     }
  135.     for my $n (@new) {
  136.             $matches{$n->name}++ and next;
  137.         push @matches, $n;
  138.         }
  139.     }
  140.     return @matches;
  141. }
  142.  
  143. #=============================================================================
  144. # Query parsing code.
  145. #=============================================================================
  146. sub _query {
  147.     my $self = shift;
  148.     my $query = shift;
  149.     my ($terms, $left) = $self->_terms($query);
  150.     return ($terms, $left) if ref $terms eq 'ARRAY';
  151.     ($terms, $left) = $self->_termopterms($query);
  152.     return ($terms, $left) if ref $terms eq 'ARRAY';
  153.     return (undef, $query);
  154. }
  155.  
  156. sub _termopterms {
  157.     my $self = shift;
  158.     my $query = shift;
  159.     my @terms = ('or', ['and']);
  160.     my ($yes1, $yes2, $left) = (undef, undef, $query);
  161.     while (1) {
  162.     ($yes1, $left) = $self->_term($left);
  163.     return (undef, $left) unless defined $yes1;
  164.     ($yes2, $left) = $self->_op($left);
  165.     push @{$terms[$#terms]}, $yes1;
  166.     last unless defined $yes2;
  167.     push @terms, ['and'] if $yes2 =~ /or/i;
  168.     }
  169.     return \@terms, $left;
  170. }
  171.  
  172. sub _terms {
  173.     my $self = shift;
  174.     my $query = shift;
  175.     my @terms = ('and');
  176.     my ($yes, $left) = (undef, $query);
  177.     while (1) {
  178.     ($yes, $left) = $self->_term($left);
  179.     last unless defined $yes;
  180.     push @terms, $yes;
  181.     }
  182.     return undef, $query unless $left eq '';
  183.     return \@terms, $left;
  184. }
  185.  
  186. sub _term {
  187.     my $self = shift;
  188.     my $query = shift;
  189.     my ($yes, $left) = $self->_term_1($query);
  190.     return ($yes, $left) if defined $yes;
  191.     ($yes, $left) = $self->_term_2($query);
  192.     return ($yes, $left) if defined $yes;
  193.     ($yes, $left) = $self->_term_3($query);
  194.     return ($yes, $left) if defined $yes;
  195.     return (undef, $query);
  196. }
  197.  
  198. sub _term_1 {
  199.     my $self = shift;
  200.     my $query = shift;
  201.     my $term = { not => 0 };
  202.     my ($yes, $left) = (undef, $query);
  203.     ($yes, $left) = $self->_not($left);
  204.     $term->{not} = 1 if defined $yes;
  205.     ($yes, $left) = $self->_field($left);
  206.     return (undef, $query) unless defined $yes;
  207.     return (undef, $query) unless $left =~ /^=/;
  208.     $term->{field} = $yes;
  209.     ($yes, $left) = $self->_glob2regex($self->_glob(substr($left, 1)));
  210.     return (undef, $query) unless defined $yes;
  211.     $term->{value} = $yes;
  212.     return ($term, $left);
  213. }
  214.  
  215. sub _term_2 {
  216.     my $self = shift;
  217.     my $query = shift;
  218.     my $term = { not => 0 };
  219.     my ($yes, $left) = (undef, $query);
  220.     ($yes, $left) =  $self->_not($left);
  221.     $term->{not} = 1 if defined $yes;
  222.     ($yes, $left) = $self->_glob2regex($self->_glob($left));
  223.     return (undef, $query) unless defined $yes;
  224.     $term->{value} = $yes;
  225.     $term->{field} = "NAME";
  226.     return ($term, $left);
  227. }
  228.  
  229. sub _term_3 {
  230.     my $self = shift;
  231.     my $query = shift;
  232.     my ($yes, $left) = (undef, $query);
  233.     return (undef, $query) unless $left =~ s/^\s*\(//;
  234.     ($yes, $left) = $self->_query($left);
  235.     return (undef, $query) unless defined $yes;
  236.     return (undef, $query) unless $left =~ s/^\s*\)//;
  237.     return ($yes, $left);
  238. }
  239.  
  240. # Returns (OP, REMAINDER) or (undef, QUERY) on failure
  241. sub _op {
  242.     my $self = shift;
  243.     my $query = shift;
  244.     return 'and', $query if $query =~ s/^\s*and\s+//i;
  245.     return 'or', $query if $query =~ s/^\s*or\s+//i;
  246.     return undef, $query;
  247. }
  248.  
  249. # Returns (OP, REMAINDER) or (undef, QUERY) on failure
  250. sub _not {
  251.     my $self = shift;
  252.     my $query = shift;
  253.     return 'not', $query if $query =~ s/^\s*not\s+//i;
  254.     return undef, $query;
  255. }
  256.  
  257. # Returns (OP, REMAINDER) or (undef, QUERY) on failure
  258. sub _field {
  259.     my $self = shift;
  260.     my $query = shift;
  261.     return $1, $query 
  262.       if $query =~ s/^\s*([A-Za-z_][A-Za-z0-9_]*)//;
  263.     return undef, $query;
  264. }
  265.  
  266. # Returns (OP, REMAINDER) or (undef, QUERY) on failure
  267. sub _glob {
  268.     my $self = shift;
  269.     my $query = shift;
  270.     my ($yes, $left);
  271.     ($yes, $left) = $self->_glob_1($query);
  272.     return ($yes, $left) if defined $yes;
  273.     ($yes, $left) = $self->_glob_2($query);
  274.     return ($yes, $left) if defined $yes;
  275.     return undef, $query;
  276. }
  277.  
  278. # Returns (OP, REMAINDER) or (undef, QUERY) on failure
  279. sub _glob_1 {
  280.     my $self = shift;
  281.     my $query = shift;
  282.     return $1, substr($query, length($1))
  283.       if $query =~ /^([][\-:\.^\$,\w*?\\]+)/;
  284.     return undef, $query;
  285. }
  286.  
  287. my $quoted_re = qr'(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\")|(?:\')(?:[^\\\']*(?:\\.[^\\\']*)*)(?:\')|(?:\`)(?:[^\\\`]*(?:\\.[^\\\`]*)*)(?:\`))';
  288.  
  289. # Returns (OP, REMAINDER) or (undef, QUERY) on failure
  290. sub _glob_2 {
  291.     my $self = shift;
  292.     my $query = shift;
  293.     if ($query =~ s/^($quoted_re)//) {
  294.     my $quoted = $1;
  295.     substr($quoted, 0, 1) = "";
  296.     substr($quoted, -1) = "";
  297.     return $quoted, $query;
  298.     }
  299.     return undef, $query;
  300. }
  301.  
  302. sub _glob2regex {
  303.     my $self = shift;
  304.     my $glob = shift;
  305.     return (undef, @_) unless defined $glob;
  306.     return glob_to_regex($glob, $self->{casei}), @_;
  307. }
  308.  
  309. 1;
  310.