From fcf58d2cfebe669734c0d0e9877adbfbc9aa729d Mon Sep 17 00:00:00 2001
From: Gisle Aas <gisle@aas.no>
Date: Wed, 24 Sep 2008 10:38:25 +0200
Subject: [PATCH] RT#39551: Allow the Distroprefs 'match' entries to be negated
---
MANIFEST | 1 +
lib/CPAN.pm | 5 ++
lib/CPAN/Distroprefs.pm | 67 +++++++++++++++++++-------
t/43distroprefspref.t | 123 +++++++++++++++++++++++++++++++++++++++++++++++
4 files changed, 179 insertions(+), 17 deletions(-)
create mode 100644 t/43distroprefspref.t
diff --git a/MANIFEST b/MANIFEST
index 5af62ab..4dbb92b 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -394,6 +394,7 @@ t/30shell.t
t/31sessions.t
t/41distribution.t
t/42distroprefs.t
+t/43distroprefspref.t
t/50pod.t
t/51pod.t
t/52podcover.t
diff --git a/lib/CPAN.pm b/lib/CPAN.pm
index 7fab633..4eb7d24 100644
--- a/lib/CPAN.pm
+++ b/lib/CPAN.pm
@@ -11695,9 +11695,11 @@ C<expect>.
match:
module: "Dancing::Queen"
distribution: "^CHACHACHA/Dancing-"
+ not_distribution: "\.zip$"
perl: "/usr/local/cariba-perl/bin/perl"
perlconfig:
archname: "freebsd"
+ not_cc: "gcc"
env:
DANCING_FLOOR: "Shubiduh"
disabled: 1
@@ -11815,6 +11817,7 @@ CPAN mantra. See below under I<Processing Instructions>.
A hashref with one or more of the keys C<distribution>, C<modules>,
C<perl>, C<perlconfig>, and C<env> that specify if a document is
targeted at a specific CPAN distribution or installation.
+Keys prefixed with C<not_> negates the corresponding match.
The corresponding values are interpreted as regular expressions. The
C<distribution> related one will be matched against the canonical
@@ -11829,9 +11832,11 @@ absolute path).
The value associated with C<perlconfig> is itself a hashref that is
matched against corresponding values in the C<%Config::Config> hash
living in the C<Config.pm> module.
+Keys prefixed with C<not_> negates the corresponding match.
The value associated with C<env> is itself a hashref that is
matched against corresponding values in the C<%ENV> hash.
+Keys prefixed with C<not_> negates the corresponding match.
If more than one restriction of C<module>, C<distribution>, etc. is
specified, the results of the separately computed match values must
diff --git a/lib/CPAN/Distroprefs.pm b/lib/CPAN/Distroprefs.pm
index 664ddb7..708a6f1 100644
--- a/lib/CPAN/Distroprefs.pm
+++ b/lib/CPAN/Distroprefs.pm
@@ -201,33 +201,63 @@ sub data { shift->{data} }
sub has_any_match { $_[0]->data->{match} ? 1 : 0 }
-sub has_match { exists $_[0]->data->{match}{$_[1]} }
+sub has_match {
+ my $match = $_[0]->data->{match} || return 0;
+ exists $match->{$_[1]} || exists $match->{"not_$_[1]"}
+}
sub has_valid_subkeys {
grep { exists $_[0]->data->{match}{$_} }
+ map { $_, "not_$_" }
$_[0]->match_attributes
}
sub _pattern {
- my ($self, $key) = @_;
- return eval sprintf 'qr{%s}', $self->data->{match}{$key};
+ my $re = shift;
+ return eval sprintf 'qr{%s}', $re;
+}
+
+sub _match_scalar {
+ my ($match, $data) = @_;
+ my $qr = _pattern($match);
+ return $data =~ /$qr/;
+}
+
+sub _match_hash {
+ my ($match, $data) = @_;
+ for my $mkey (keys %$match) {
+ (my $dkey = $mkey) =~ s/^not_//;
+ my $val = defined $data->{$dkey} ? $data->{$dkey} : '';
+ if (_match_scalar($match->{$mkey}, $val)) {
+ return 0 if $mkey =~ /^not_/;
+ }
+ else {
+ return 0 if $mkey !~ /^not_/;
+ }
+ }
+ return 1;
+}
+
+sub _match {
+ my ($self, $key, $data, $matcher) = @_;
+ my $m = $self->data->{match};
+ if (exists $m->{$key}) {
+ return 0 unless $matcher->($m->{$key}, $data);
+ }
+ if (exists $m->{"not_$key"}) {
+ return 0 if $matcher->($m->{"not_$key"}, $data);
+ }
+ return 1;
}
sub _scalar_match {
my ($self, $key, $data) = @_;
- my $qr = $self->_pattern($key);
- return $data =~ /$qr/ ? 1 : 0;
+ return $self->_match($key, $data, \&_match_scalar);
}
sub _hash_match {
my ($self, $key, $data) = @_;
- my $match = $self->data->{match}{$key};
- for my $mkey (keys %$match) {
- my $val = defined $data->{$mkey} ? $data->{$mkey} : '';
- my $qr = eval sprintf 'qr{%s}', $match->{$mkey};
- return 0 unless $val =~ /$qr/;
- }
- return 1;
+ return $self->_match($key, $data, \&_match_hash);
}
# do not take the order of C<keys %$match> because "module" is by far the
@@ -236,11 +266,14 @@ sub match_attributes { qw(env distribution perl perlconfig module) }
sub match_module {
my ($self, $modules) = @_;
- my $qr = $self->_pattern('module');
- for my $module (@$modules) {
- return 1 if $module =~ /$qr/;
- }
- return 0;
+ return $self->_match("module", $modules, sub {
+ my($match, $data) = @_;
+ my $qr = _pattern($match);
+ for my $module (@$data) {
+ return 1 if $module =~ /$qr/;
+ }
+ return 0;
+ });
}
sub match_distribution { shift->_scalar_match(distribution => @_) }
diff --git a/t/43distroprefspref.t b/t/43distroprefspref.t
new file mode 100644
index 0000000..b2acd4f
--- /dev/null
+++ b/t/43distroprefspref.t
@@ -0,0 +1,123 @@
+use strict;
+
+use Test::More;
+use CPAN::Distroprefs;
+
+plan tests => 21;
+
+my $p;
+
+# start with something simple
+$p = CPAN::Distroprefs::Pref->new({
+ data => {
+ match => {
+ distribution => "^XML",
+ },
+ },
+});
+
+ok($p->data);
+ok($p->has_match("distribution"));
+ok(!$p->has_match("perl"));
+ok($p->has_any_match);
+ok($p->has_valid_subkeys);
+
+ok($p->matches({
+ distribution => "XML::Parser",
+}));
+
+ok(!$p->matches({
+ distribution => "Foo::XML",
+}));
+
+# still simple, but now a negated match
+$p = CPAN::Distroprefs::Pref->new({
+ data => {
+ match => {
+ not_distribution => "^XML",
+ },
+ },
+});
+
+ok($p->data);
+ok($p->has_match("distribution"));
+ok(!$p->has_match("perl"));
+ok($p->has_any_match);
+ok($p->has_valid_subkeys);
+
+ok(!$p->matches({
+ distribution => "XML::Parser",
+}));
+
+ok($p->matches({
+ distribution => "Foo::XML",
+}));
+
+# try some complicated matches
+$p = CPAN::Distroprefs::Pref->new({
+ data => {
+ match => {
+ distribution => "^XML",
+ not_distribution => "Parser",
+ perlconfig => {
+ osname => "linux",
+ not_cc => "^gcc\$",
+ },
+ },
+ },
+});
+
+ok(!$p->matches({
+ distribution => "XML::Parser",
+}));
+
+ok($p->matches({
+ distribution => "XML::Foo",
+ perlconfig => {
+ osname => "linux",
+ cc => "cc",
+ },
+}));
+
+ok(!$p->matches({
+ distribution => "XML::Foo",
+ perlconfig => {
+ osname => "linux",
+ cc => "gcc",
+ },
+}));
+
+ok(!$p->matches({
+ distribution => "XML::Foo",
+ perlconfig => {
+ osname => "darwin",
+ cc => "cc",
+ },
+}));
+
+# try match on module
+$p = CPAN::Distroprefs::Pref->new({
+ data => {
+ match => {
+ module => "^LWP",
+ not_module => "Foo",
+ },
+ },
+});
+
+ok($p->matches({
+ module => ["LWP::UserAgent"],
+}));
+
+ok(!$p->matches({
+ module => ["LWP::UserAgent", "LWP::Foo"],
+}));
+
+ok(!$p->matches({
+ module => ["Bar"],
+}));
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 2
+# End:
--
1.6.0.GIT
