diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2018-06-18 06:35:13 +0200 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2018-06-18 06:35:13 +0200 |
commit | 7118ffe16d97b2a589047408ea704133a3aa28ad (patch) | |
tree | 952b2d6a6b7668cb72883af11e3f8bdeefc52865 /lib/SlackBuild/Pattern.pm | |
parent | 7606460cdd3f501a3f385c111e78444dae843ab1 (diff) | |
download | slackbuilder-7118ffe16d97b2a589047408ea704133a3aa28ad.tar.gz slackbuilder-7118ffe16d97b2a589047408ea704133a3aa28ad.tar.bz2 |
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.
Diffstat (limited to 'lib/SlackBuild/Pattern.pm')
-rw-r--r-- | lib/SlackBuild/Pattern.pm | 133 |
1 files changed, 133 insertions, 0 deletions
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; + |