diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2018-06-17 13:53:26 +0200 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2018-06-17 13:53:26 +0200 |
commit | 7606460cdd3f501a3f385c111e78444dae843ab1 (patch) | |
tree | 55a011638287f121cfbb0e7663a1f0ea5893469d /lib/SlackBuild/Registry | |
parent | 00e5b428ef80f2898142a5e1bbc71cf10142545e (diff) | |
download | slackbuilder-7606460cdd3f501a3f385c111e78444dae843ab1.tar.gz slackbuilder-7606460cdd3f501a3f385c111e78444dae843ab1.tar.bz2 |
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.
Diffstat (limited to 'lib/SlackBuild/Registry')
-rw-r--r-- | lib/SlackBuild/Registry/Backend/FS.pm | 5 | ||||
-rw-r--r-- | lib/SlackBuild/Registry/Pattern.pm | 134 | ||||
-rw-r--r-- | lib/SlackBuild/Registry/Record.pm | 44 |
3 files changed, 138 insertions, 45 deletions
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/Registry/Pattern.pm b/lib/SlackBuild/Registry/Pattern.pm new file mode 100644 index 0000000..8d25537 --- /dev/null +++ b/lib/SlackBuild/Registry/Pattern.pm @@ -0,0 +1,134 @@ +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; +} + +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 { |