Rewrite package matching

* lib/SlackBuild/Registry/Pattern.pm: New file.
* lib/SlackBuild/match.pm: Remove.
* lib/SlackBuild/Rc.pm (resolve): Use SlackBuild::Registry::Pattern
* lib/SlackBuild/Registry.pm (lookup): Take SlackBuild::Registry::Pattern
object as 2nd argument.
* lib/SlackBuild/Registry/Backend/FS.pm (lookup): Likewise.
* lib/SlackBuild/Registry/Record.pm (as_string): Revert temporary
changes introduced some time ago.
(match_attr, matches): Remove.
* t/regrec.t: Update.

6 files changed, 89 insertions, 74 deletions

diff --git a/lib/SlackBuild/Rc.pm b/lib/SlackBuild/Rc.pm
index f7c7357..79ac033 100644
--- a/lib/SlackBuild/Rc.pm
+++ b/lib/SlackBuild/Rc.pm
@@ -3,6 +3,7 @@ use strict;
 use warnings;
 use Carp;
 use SlackBuild::Registry::Record;
+use SlackBuild::Registry::Pattern;
 
 sub new {
     my ($class, $builder) = @_;
@@ -17,20 +18,18 @@ sub resolve {
     my @unresolved;
     foreach my $pkg (@{$self->builder->prereq}) {
 	my %q;
-	my $name;
 	if (ref($pkg) eq 'HASH') {
 	    %q = %$pkg;
-	    $name = delete $q{package};
 	} else {
-	    $name = $pkg;
+	    $q{package} = $pkg;
 	}
 	$q{arch} = { -in => [ $self->builder->arch, 'noarch' ] }
 	             unless exists $q{arch};
-	if (my $rec = $reg->lookup($name, %q)) {
+	my $pred = new SlackBuild::Registry::Pattern(%q);
+	if (my $rec = $reg->lookup($q{package}, $pred)) {
 	    push @packages, $rec->filename;
 	} else {
-	    push @unresolved,
-	         SlackBuild::Registry::Record->new($name, %q)->as_string;
+	    push @unresolved, $pred->as_string;
 	}
     }
     return (\@packages, \@unresolved);
diff --git a/lib/SlackBuild/Registry.pm b/lib/SlackBuild/Registry.pm
index 8bbc7b8..9827e3c 100644
--- a/lib/SlackBuild/Registry.pm
+++ b/lib/SlackBuild/Registry.pm
@@ -40,10 +40,8 @@ search criteria.
 =cut
 
 sub lookup {
-    my $self = shift;
-    my $pkg = shift or croak "nothing to look up";
-    local %_ = @_;
-    return $self->backend->lookup($pkg, %_);
+    my ($self, $pkg, $pattern) = @_;
+    return $self->backend->lookup($pkg, $pattern);
 }
 
 1;
diff --git a/lib/SlackBuild/Registry/Backend/FS.pm b/lib/SlackBuild/Registry/Backend/FS.pm
index 5788ead..92cc39a 100644
--- a/lib/SlackBuild/Registry/Backend/FS.pm
+++ b/lib/SlackBuild/Registry/Backend/FS.pm
@@ -52,8 +52,7 @@ search criteria.
 =cut
     
 sub lookup {
-    my ($self, $pkg, %cond) = @_;
-    my $v;
+    my ($self, $pkg, $pred) = @_;
 
     my $pat = "$pkg-*-*-*";
     
@@ -74,7 +73,7 @@ sub lookup {
 	    ($b->build || 1) <=> ($a->build || 1)
         }
     }
-    grep { $_->matches(%cond) }
+    grep { $pred->matches($_) }
     map {
 	my ($name,$path,$suffix) = fileparse($_, @suffixes);
 	if ($name =~ m{$rx}) {
diff --git a/lib/SlackBuild/match.pm b/lib/SlackBuild/Registry/Pattern.pm
index 07d909d..8d25537 100644
--- a/lib/SlackBuild/match.pm
+++ b/lib/SlackBuild/Registry/Pattern.pm
@@ -1,52 +1,51 @@
-package SlackBuild::match;
+package SlackBuild::Registry::Pattern;
 use strict;
 use warnings;
 use parent 'Exporter';
 use Carp;
 use Scalar::Util qw(looks_like_number);
-
-our @EXPORT = qw(match);
+use JSON;
 
 my %matchtab = (
     -eq => sub {
-	my ($a, $b) = @_;
+	my ($self, $a, $b) = @_;
 	(looks_like_number($a) && looks_like_number($b)) ? $a == $b : $a eq $b;
     },
     '=' => '-eq',
     '==' => '-eq',
     
     -ne => sub {
-	my ($a, $b) = @_;
+	my ($self, $a, $b) = @_;
 	(looks_like_number($a) && looks_like_number($b)) ? $a != $b : $a ne $b;
     },
     '!=' => '-ne',
     
     -lt => sub {
-	my ($a, $b) = @_;
+	my ($self, $a, $b) = @_;
 	(looks_like_number($a) && looks_like_number($b)) ? $a < $b : $a lt $b;
     },
     '<' => '-lt',
     
     -le => sub {
-	my ($a, $b) = @_;
+	my ($self, $a, $b) = @_;
 	(looks_like_number($a) && looks_like_number($b)) ? $a <= $b : $a le $b;
     },
     '<=' => '-le',
     
     -gt => sub {
-	my ($a, $b) = @_;
+	my ($self, $a, $b) = @_;
 	(looks_like_number($a) && looks_like_number($b)) ? $a > $b : $a gt $b;
     },
     '>' => '-gt',
     
     -ge => sub {
-	my ($a, $b) = @_;
+	my ($self, $a, $b) = @_;
 	(looks_like_number($a) && looks_like_number($b)) ? $a >= $b : $a ge $b;
     },
     '>=' => '-ge',
     
     -in => sub {
-	my ($a, $b) = @_;
+	my ($self, $a, $b) = @_;
 	croak 'argument to -in must be array'
 	    unless ref($b) eq 'ARRAY';
 	foreach my $v (@$b) {
@@ -57,8 +56,18 @@ my %matchtab = (
     }
 );
 
-sub match {
-    my ($val, $pred) = @_;
+sub new {
+    my $class = shift;
+    croak "Bad number of arguments" if @_ % 2;
+    my $self = bless { predicates => [], printable => [] }, $class;
+    for (my $i = 0; $i < @_; $i+=2) {
+	$self->add_predicate($_[$i], $_[$i+1]);
+    }
+    return $self;
+}
+
+sub add_predicate {
+    my ($self, $field, $pred) = @_;
 
     my ($fun, $arg);
     if (ref($pred) eq 'ARRAY') {
@@ -82,5 +91,44 @@ sub match {
     croak "unknown predicate: $fun"
 	unless (exists($matchtab{$fun}));
 
-    &{$matchtab{$fun}}($val, $arg);
+    $self->{index}{$field} = @{$self->{predicates}};
+    push @{$self->{predicates}}, [
+	$field,
+	sub {
+	    my ($val) = @_;
+#	    print "$field $fun $val $arg?\n";
+	    return $self->${\ $matchtab{$fun}}($val, $arg);
+    }];
+
+    push @{$self->{printable}}, { $field => { $fun => $arg } };
+}
+
+sub matches {
+    my ($self, $obj) = @_;
+#    print "OBJ=$obj\n";
+    foreach my $pred (@{$self->{predicates}}) {
+	my ($field, $fun) = @$pred;
+	return 0 unless &{$fun}($obj->${\$field});
+    }
+    return 1;
 }
+
+my %order = (
+    package => 1,
+    version => 2,
+    arch => 3,
+    build => 4,
+    filename => 5,
+    date => 6
+);
+
+sub as_string {
+    my $self = shift;
+    JSON->new->canonical(1)->encode(
+	[sort { ($order{ (keys($a))[0]} || 100) <=>
+                ($order{(keys($b))[0]} || 100) }
+	      @{$self->{printable}}]);
+}
+
+1;
+
diff --git a/lib/SlackBuild/Registry/Record.pm b/lib/SlackBuild/Registry/Record.pm
index 130dd16..3af5f96 100644
--- a/lib/SlackBuild/Registry/Record.pm
+++ b/lib/SlackBuild/Registry/Record.pm
@@ -4,7 +4,6 @@ use warnings;
 use Carp;
 use SlackBuild::Base qw(package arch build date filename);
 use SlackBuild::Registry::Version;
-use SlackBuild::match;
 use Scalar::Util qw(blessed);
 
 =head2 new
@@ -47,12 +46,9 @@ sub store {
 
 sub as_string {
     my $self = shift;
-    use Data::Dumper;
-    local $Data::Dumper::Indent = 0;
-    local $Data::Dumper::Terse = 1;
     return $self->package . '-'
-	   . ($self->version ? Dumper($self->version) : '*') . '-'
-	   . ($self->arch ? Dumper($self->arch) : '*') . '-'
+	   . ($self->version ? $self->version : '*') . '-'
+	   . ($self->arch ? $self->arch : '*') . '-'
 	   . ($self->build || '1');
 }
 
@@ -73,42 +69,6 @@ sub cmp {
     return ($self->build || 1) <=> ($other->build || 1);
 }   
 
-sub match_attr {
-    my ($self, $pred) = @_;
-    my ($meth, $arg);
-    if (ref($pred) eq 'ARRAY') {
-	croak "array must have 2 elements" unless @$pred == 2;
-        ($meth, $arg) = @$pred;
-    } elsif (ref($pred) eq 'HASH') {
-	croak "array must have 1 key" unless keys(%$pred) == 1;
-	($meth, $arg) = each %$pred;
-    } else {
-	return $self == $pred;
-    }
-    return match($self->${ \$meth }, $arg);
-}
-
-sub matches {
-    my $self = shift;
-    my $args;
-    if (@_ == 1) {
-	if (ref($_[0]) eq 'HASH') {
-	    $args = $_[0];
-	} else {
-	    croak "bad argument";
-	}
-    } elsif (@_ % 2 == 0) {
-	local %_ = @_;
-	$args = \%_;
-    } else {
-	croak "odd number of arguments";
-    }
-    while (my ($meth, $pred) = each %$args) {
-	return 0 unless match($self->${ \$meth }, $pred);
-    }
-    return 1;
-}
-
 use overload
     '""' => sub { shift->as_string },
     'cmp' => sub {
diff --git a/t/regrec.t b/t/regrec.t
index f50ba44..7d28e85 100644
--- a/t/regrec.t
+++ b/t/regrec.t
@@ -3,9 +3,10 @@ use lib qw(t lib);
 use strict;
 use warnings;
 use SlackBuild::Registry::Record;
+use SlackBuild::Registry::Pattern;
 use Test;
 
-plan tests => 6;
+plan tests => 7;
 
 my $r = new SlackBuild::Registry::Record('foo',
 	                                 arch => 'x86_64',
@@ -24,8 +25,18 @@ my $x = new SlackBuild::Registry::Record('foo',
 ok($r < $x);
 ok($r <=> $x, -1);
 
-ok($r->matches(version => { -gt => '0.2' }));
-ok($r->matches(version => { -gt => '0.2' },
-	       arch => { -in => [ qw(i386 x86_64)] }) );
-ok(!$r->matches(version => { -gt => '0.2' },
-		arch => { -eq => 'i386' }));
+ok(SlackBuild::Registry::Pattern->new(version => { -gt => '0.2' })->matches($r));
+ok(SlackBuild::Registry::Pattern->new(version => { -gt => '0.2' },
+ 	                              arch => { -in => [ qw(i386 x86_64)] })->matches($r));
+ok(!SlackBuild::Registry::Pattern->new(version => { -gt => '0.2' },
+ 		                       arch => { -eq => 'i386' })->matches($r));
+
+my $pat = new SlackBuild::Registry::Pattern(
+             arch => { -in => [qw(noarch x86_64)] },
+             build => 2,
+             package => "bar",
+    version => "1.1");
+
+ok($pat->as_string,
+   q{[{"package":{"-eq":"bar"}},{"version":{"-eq":"1.1"}},{"arch":{"-in":["noarch","x86_64"]}},{"build":{"-eq":2}}]});
+