Improve package pattern matcher

* MANIFEST.SKIP: New file.
* lib/SlackBuild/Registry/Pattern.pm: Rewrite as a subclass of
SlackBuild::Pattern.
* lib/SlackBuild/Pattern.pm: New file. Abstract structured pattern class.
* lib/SlackBuild/Rc.pm: Update invocation of the lookup method
* lib/SlackBuild/Registry.pm (lookup): Take single argument.
* lib/SlackBuild/Registry/Backend/FS.pm (lookup): Take single argument.
Allow for arbitrary prefix in front of the version number (e.g.
btrfs-progs-v4.5.3.txz)
* t/regrec.t: Update.

7 files changed, 164 insertions, 129 deletions

diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP
index 859ca13..1d373fa 100644
--- a/MANIFEST.SKIP
+++ b/MANIFEST.SKIP
@@ -57,4 +57,7 @@
 ^debug.sh
 ^tmp
 ^buildreq
-^\.emacs\.*
\ No newline at end of file
+^\.emacs\.*
+\.tar$
+\.tar\.(gz|bz2)$
+\bcore\b
diff --git a/lib/SlackBuild/Pattern.pm b/lib/SlackBuild/Pattern.pm
new file mode 100644
index 0000000..4187c07
--- /dev/null
+++ b/lib/SlackBuild/Pattern.pm
@@ -0,0 +1,133 @@
+package SlackBuild::Pattern;
+use strict;
+use warnings;
+use Carp;
+use Scalar::Util qw(looks_like_number);
+use JSON;
+
+my %matchtab = (
+    -eq => sub {
+	my ($self, $a, $b) = @_;
+	(looks_like_number($a) && looks_like_number($b)) ? $a == $b : $a eq $b;
+    },
+    '=' => '-eq',
+    '==' => '-eq',
+    
+    -ne => sub {
+	my ($self, $a, $b) = @_;
+	(looks_like_number($a) && looks_like_number($b)) ? $a != $b : $a ne $b;
+    },
+    '!=' => '-ne',
+    
+    -lt => sub {
+	my ($self, $a, $b) = @_;
+	(looks_like_number($a) && looks_like_number($b)) ? $a < $b : $a lt $b;
+    },
+    '<' => '-lt',
+    
+    -le => sub {
+	my ($self, $a, $b) = @_;
+	(looks_like_number($a) && looks_like_number($b)) ? $a <= $b : $a le $b;
+    },
+    '<=' => '-le',
+    
+    -gt => sub {
+	my ($self, $a, $b) = @_;
+	(looks_like_number($a) && looks_like_number($b)) ? $a > $b : $a gt $b;
+    },
+    '>' => '-gt',
+    
+    -ge => sub {
+	my ($self, $a, $b) = @_;
+	(looks_like_number($a) && looks_like_number($b)) ? $a >= $b : $a ge $b;
+    },
+    '>=' => '-ge',
+    
+    -in => sub {
+	my ($self, $a, $b) = @_;
+	croak 'argument to -in must be array'
+	    unless ref($b) eq 'ARRAY';
+	foreach my $v (@$b) {
+	    return 1
+		if (looks_like_number($a) && looks_like_number($v))
+		    ? $a == $v : $a eq $v;
+	}
+    }
+);
+
+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') {
+	croak "array must have 2 elements" unless @$pred == 2;
+        ($fun, $arg) = @$pred;
+    } elsif (ref($pred) eq 'HASH') {
+	croak "array must have 1 key" unless keys(%$pred) == 1;
+	($fun, $arg) = each %$pred;
+    } elsif ($pred =~ m{^([<=>]=?)(.*)}) {
+	$fun = $1;
+	$arg = $2;
+    } else {
+	$fun = '-eq';
+	$arg = $pred;
+    }
+
+    while (exists($matchtab{$fun}) && !ref($matchtab{$fun})) {
+	$fun = $matchtab{$fun};
+    }
+    
+    croak "unknown predicate: $fun"
+	unless (exists($matchtab{$fun}));
+
+    $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;
+}
+
+sub as_string {
+    my $self = shift;
+    JSON->new->canonical(1)->encode(
+	[sort { $self->predcmp($a, $b) } @{$self->{printable}}]);
+}
+
+sub predcmp {
+    my ($self, $a, $b) = @_;
+    (keys($a))[0] cmp (keys($b))[0];
+}
+
+sub get_predicate {
+    my ($self, $field) = @_;
+    if (exists($self->{index}{$field})) {
+	$self->{printable}[$self->{index}{$field}]{$field};
+    }
+}
+1;
+
diff --git a/lib/SlackBuild/Rc.pm b/lib/SlackBuild/Rc.pm
index 79ac033..022386a 100644
--- a/lib/SlackBuild/Rc.pm
+++ b/lib/SlackBuild/Rc.pm
@@ -26,7 +26,7 @@ sub resolve {
 	$q{arch} = { -in => [ $self->builder->arch, 'noarch' ] }
 	             unless exists $q{arch};
 	my $pred = new SlackBuild::Registry::Pattern(%q);
-	if (my $rec = $reg->lookup($q{package}, $pred)) {
+	if (my $rec = $reg->lookup($pred)) {
 	    push @packages, $rec->filename;
 	} else {
 	    push @unresolved, $pred->as_string;
diff --git a/lib/SlackBuild/Registry.pm b/lib/SlackBuild/Registry.pm
index 9827e3c..85c92ad 100644
--- a/lib/SlackBuild/Registry.pm
+++ b/lib/SlackBuild/Registry.pm
@@ -32,16 +32,16 @@ sub new {
 
 =head2 lookup
 
-    @a = $x->lookup(PACKAGE, [version=>X], [arch=>Y], [build=>Z])
+    @a = $x->lookup($pattern)
 
 Returns a sorted array of SlackBuild::Registry::Record objects matching the
-search criteria.
+B<SlackBuild::Registry::Pattern> object B<$pattern>.
 
 =cut
 
 sub lookup {
-    my ($self, $pkg, $pattern) = @_;
-    return $self->backend->lookup($pkg, $pattern);
+    my ($self, $pattern) = @_;
+    return $self->backend->lookup($pattern);
 }
 
 1;
diff --git a/lib/SlackBuild/Registry/Backend/FS.pm b/lib/SlackBuild/Registry/Backend/FS.pm
index 92cc39a..f71e72a 100644
--- a/lib/SlackBuild/Registry/Backend/FS.pm
+++ b/lib/SlackBuild/Registry/Backend/FS.pm
@@ -44,22 +44,24 @@ my @suffixes = qw(.tgz .txz);
 
 =head2 lookup
 
-    @a = $backend->lookup(PACKAGE, [version=>X], [arch=>Y], [build=>Z])
+    @a = $backend->lookup($pattern)
 
 Returns a sorted array of SlackBuild::Registry::Record objects matching the
-search criteria.    
+B<SlackBuild::Registry::Pattern> object B<$pattern>.
     
 =cut
     
 sub lookup {
-    my ($self, $pkg, $pred) = @_;
-
+    my ($self, $pred) = @_;
+    my $pkg = $pred->package;
+    
     my $pat = "$pkg-*-*-*";
     
     my $rx = '^' . qr($pkg) . '-'
-	   . '(?<version>\d+(?:\.\d+)*.*?)-(?<arch>'
-	   . regexp_opt(@architectures)
-	   .= ')-(?<build>\d+)(?<rest>.*)$';
+	   . '(?<vpfx>.*?)'
+	   . '(?<version>\d+(?:\.\d+)*.*?)'
+	   . '-(?<arch>' . regexp_opt(@architectures) . ')'
+	   . '-(?<build>\d+)(?<rest>[[:punct:]].*)?$';
     my @result = sort {
 	my $d;
 	if ($d = ($a->package || '') cmp ($b->package || '')) {
diff --git a/lib/SlackBuild/Registry/Pattern.pm b/lib/SlackBuild/Registry/Pattern.pm
index 8d25537..2b1b025 100644
--- a/lib/SlackBuild/Registry/Pattern.pm
+++ b/lib/SlackBuild/Registry/Pattern.pm
@@ -1,117 +1,8 @@
 package SlackBuild::Registry::Pattern;
 use strict;
 use warnings;
-use parent 'Exporter';
 use Carp;
-use Scalar::Util qw(looks_like_number);
-use JSON;
-
-my %matchtab = (
-    -eq => sub {
-	my ($self, $a, $b) = @_;
-	(looks_like_number($a) && looks_like_number($b)) ? $a == $b : $a eq $b;
-    },
-    '=' => '-eq',
-    '==' => '-eq',
-    
-    -ne => sub {
-	my ($self, $a, $b) = @_;
-	(looks_like_number($a) && looks_like_number($b)) ? $a != $b : $a ne $b;
-    },
-    '!=' => '-ne',
-    
-    -lt => sub {
-	my ($self, $a, $b) = @_;
-	(looks_like_number($a) && looks_like_number($b)) ? $a < $b : $a lt $b;
-    },
-    '<' => '-lt',
-    
-    -le => sub {
-	my ($self, $a, $b) = @_;
-	(looks_like_number($a) && looks_like_number($b)) ? $a <= $b : $a le $b;
-    },
-    '<=' => '-le',
-    
-    -gt => sub {
-	my ($self, $a, $b) = @_;
-	(looks_like_number($a) && looks_like_number($b)) ? $a > $b : $a gt $b;
-    },
-    '>' => '-gt',
-    
-    -ge => sub {
-	my ($self, $a, $b) = @_;
-	(looks_like_number($a) && looks_like_number($b)) ? $a >= $b : $a ge $b;
-    },
-    '>=' => '-ge',
-    
-    -in => sub {
-	my ($self, $a, $b) = @_;
-	croak 'argument to -in must be array'
-	    unless ref($b) eq 'ARRAY';
-	foreach my $v (@$b) {
-	    return 1
-		if (looks_like_number($a) && looks_like_number($v))
-		    ? $a == $v : $a eq $v;
-	}
-    }
-);
-
-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') {
-	croak "array must have 2 elements" unless @$pred == 2;
-        ($fun, $arg) = @$pred;
-    } elsif (ref($pred) eq 'HASH') {
-	croak "array must have 1 key" unless keys(%$pred) == 1;
-	($fun, $arg) = each %$pred;
-    } elsif ($pred =~ m{^([<=>]=?)(.*)}) {
-	$fun = $1;
-	$arg = $2;
-    } else {
-	$fun = '-eq';
-	$arg = $pred;
-    }
-
-    while (exists($matchtab{$fun}) && !ref($matchtab{$fun})) {
-	$fun = $matchtab{$fun};
-    }
-    
-    croak "unknown predicate: $fun"
-	unless (exists($matchtab{$fun}));
-
-    $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;
-}
+use parent 'SlackBuild::Pattern';
 
 my %order = (
     package => 1,
@@ -122,12 +13,17 @@ my %order = (
     date => 6
 );
 
-sub as_string {
+sub predcmp {
+    my ($self, $a, $b) = @_;
+    ($order{ (keys($a))[0]} || 100) <=>
+	($order{(keys($b))[0]} || 100);
+}
+
+sub package {
     my $self = shift;
-    JSON->new->canonical(1)->encode(
-	[sort { ($order{ (keys($a))[0]} || 100) <=>
-                ($order{(keys($b))[0]} || 100) }
-	      @{$self->{printable}}]);
+    my $h = $self->get_predicate('package') or return;
+    return unless (keys(%$h))[0] eq '-eq';
+    return (values(%$h))[0];
 }
 
 1;
diff --git a/t/regrec.t b/t/regrec.t
index 7d28e85..516480a 100644
--- a/t/regrec.t
+++ b/t/regrec.t
@@ -39,4 +39,5 @@ my $pat = new SlackBuild::Registry::Pattern(
 
 ok($pat->as_string,
    q{[{"package":{"-eq":"bar"}},{"version":{"-eq":"1.1"}},{"arch":{"-in":["noarch","x86_64"]}},{"build":{"-eq":2}}]});
-             
+
+print $pat->package,"\n";