summaryrefslogtreecommitdiff
path: root/lib/SlackBuild/Registry
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2018-06-17 13:53:26 +0200
committerSergey Poznyakoff <gray@gnu.org.ua>2018-06-17 13:53:26 +0200
commit7606460cdd3f501a3f385c111e78444dae843ab1 (patch)
tree55a011638287f121cfbb0e7663a1f0ea5893469d /lib/SlackBuild/Registry
parent00e5b428ef80f2898142a5e1bbc71cf10142545e (diff)
downloadslackbuilder-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.pm5
-rw-r--r--lib/SlackBuild/Registry/Pattern.pm134
-rw-r--r--lib/SlackBuild/Registry/Record.pm44
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 {

Return to:

Send suggestions and report system problems to the System administrator.