summaryrefslogtreecommitdiff
path: root/lib/SlackBuild/Pattern.pm
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2018-06-18 06:35:13 +0200
committerSergey Poznyakoff <gray@gnu.org.ua>2018-06-18 06:35:13 +0200
commit7118ffe16d97b2a589047408ea704133a3aa28ad (patch)
tree952b2d6a6b7668cb72883af11e3f8bdeefc52865 /lib/SlackBuild/Pattern.pm
parent7606460cdd3f501a3f385c111e78444dae843ab1 (diff)
downloadslackbuilder-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.pm133
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;
+

Return to:

Send suggestions and report system problems to the System administrator.