summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2017-11-30 16:25:28 +0100
committerSergey Poznyakoff <gray@gnu.org.ua>2017-11-30 16:25:28 +0100
commita14e7a93f2e6c164cde74cc2359c28312cc814d1 (patch)
tree0b85f544e77eaf3ee1c44ab72c2182e2e441c808
parent18c46014ea554d19989b6a1b3a773254fefda092 (diff)
downloadslackbuilder-a14e7a93f2e6c164cde74cc2359c28312cc814d1.tar.gz
slackbuilder-a14e7a93f2e6c164cde74cc2359c28312cc814d1.tar.bz2
Improve registry record matcher.
String conditions like "<OP>TEXT", where <OP> is a comparizon operator are recognized. Thus, e.g. "version => '>=1.2' is treated as "version => { '-ge' => '1.2' }" * lib/SlackBuild/match.pm (match): Handle conditions like ">foo". (matchtab): Provide aliases. * lib/SlackBuild/Registry/Backend/FS.pm (lookup): Use Registry::Record->matches to select matching records.
-rw-r--r--lib/SlackBuild/Registry/Backend/FS.pm38
-rw-r--r--lib/SlackBuild/match.pm23
2 files changed, 31 insertions, 30 deletions
diff --git a/lib/SlackBuild/Registry/Backend/FS.pm b/lib/SlackBuild/Registry/Backend/FS.pm
index d554f9e..2ecd27a 100644
--- a/lib/SlackBuild/Registry/Backend/FS.pm
+++ b/lib/SlackBuild/Registry/Backend/FS.pm
@@ -52,37 +52,15 @@ search criteria.
=cut
sub lookup {
- my ($self, $pkg, %keys) = @_;
+ my ($self, $pkg, %cond) = @_;
my $v;
- my $pat = "$pkg-";
- $pat .= ($keys{version} || '*') . '-';
- $pat .= ($keys{arch} || '*') . '-';
- if ($keys{build}) {
- $pat .= $keys{build};
- }
- $pat .= '*';
+ my $pat = "$pkg-*-*-*";
- my $rx = '^' . qr($pkg) . '-';
- $rx .= '(?<version>';
- if ($keys{version}) {
- $rx .= qr($keys{version});
- } else {
- $rx .= '\d+(\.\d+)+.*?';
- }
- $rx .= ')-(?<arch>';
- if ($keys{arch}) {
- $rx .= qr($keys{arch});
- } else {
- $rx .= regexp_opt(@architectures);
- }
- $rx .= ')-(?<build>';
- if ($keys{build}) {
- $rx .= qr($keys{build});
- } else {
- $rx .= '\d+';
- }
- $rx .= ')(?<pfx>.*)$';
+ my $rx = '^' . qr($pkg) . '-'
+ . '(?<version>\d+(\.\d+)+.*?)-(?<arch>'
+ . regexp_opt(@architectures)
+ .= ')-(?<build>\d+)(?<rest>.*)$';
my @result = sort {
my $d;
@@ -96,7 +74,9 @@ sub lookup {
} else {
($b->build || 1) <=> ($a->build || 1)
}
- } map {
+ }
+ grep { $_->matches(%cond) }
+ map {
my ($name,$path,$suffix) = fileparse($_, @suffixes);
if ($name =~ m{$rx}) {
my $st = stat($_);
diff --git a/lib/SlackBuild/match.pm b/lib/SlackBuild/match.pm
index 9b99d95..9ddb9b9 100644
--- a/lib/SlackBuild/match.pm
+++ b/lib/SlackBuild/match.pm
@@ -12,26 +12,39 @@ my %matchtab = (
my ($a, $b) = @_;
(looks_like_number($a) && looks_like_number($b)) ? $a == $b : $a eq $b;
},
+ '=' => '-eq',
+ '==' => '-eq',
+
-ne => sub {
my ($a, $b) = @_;
(looks_like_number($a) && looks_like_number($b)) ? $a != $b : $a ne $b;
},
+ '!=' => '-ne',
+
-lt => sub {
my ($a, $b) = @_;
(looks_like_number($a) && looks_like_number($b)) ? $a < $b : $a lt $b;
},
+ '<' => '-lt',
+
-le => sub {
my ($a, $b) = @_;
(looks_like_number($a) && looks_like_number($b)) ? $a <= $b : $a le $b;
},
+ '<=' => '-le',
+
-gt => sub {
my ($a, $b) = @_;
(looks_like_number($a) && looks_like_number($b)) ? $a > $b : $a gt $b;
},
+ '>' => '-gt',
+
-ge => sub {
my ($a, $b) = @_;
(looks_like_number($a) && looks_like_number($b)) ? $a > $b : $a ge $b;
},
+ '>=' => '-ge',
+
-in => sub {
my ($a, $b) = @_;
croak 'argument to -in must be array'
@@ -54,10 +67,18 @@ sub match {
} 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 {
- return $val == $pred;
+ $fun = '-eq';
+ $arg = $pred;
}
+ while (exists($matchtab{$fun}) && !ref($matchtab{$fun})) {
+ $fun = $matchtab{$fun};
+ }
+
croak "unknown predicate: $fun"
unless (exists($matchtab{$fun}));

Return to:

Send suggestions and report system problems to the System administrator.