From: Vincent Pit <vince@profvince.com>
Date: Thu, 26 Feb 2009 15:18:34 +0000 (+0100)
Subject: Allow translating glob and sql jokers at the same time
X-Git-Tag: v1.03~3
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=a86792e2f3991cbfdda962a94f851bfb44e9ed8e;p=perl%2Fmodules%2FRegexp-Wildcards.git

Allow translating glob and sql jokers at the same time
---

diff --git a/lib/Regexp/Wildcards.pm b/lib/Regexp/Wildcards.pm
index 1b3b4e9..abb59f0 100644
--- a/lib/Regexp/Wildcards.pm
+++ b/lib/Regexp/Wildcards.pm
@@ -404,7 +404,7 @@ The C<capture> method returns the L<Regexp::Wildcards> object.
 =head2 C<convert $wc [ , $type ]>
 
 Converts the wildcard expression C<$wc> into a regular expression according to the options stored into the L<Regexp::Wildcards> object, or to C<$type> if it's supplied.
-It successively escapes all unprotected regexp special characters that doesn't hold any meaning for wildcards, then replace C<'jokers'> or C<'sql'> and C<'commas'> or C<'brackets'> (depending on the L</do> or L</type> options), all of this by applying the C<'capture'> rules specified in the constructor or by L</capture>.
+It successively escapes all unprotected regexp special characters that doesn't hold any meaning for wildcards, then replace C<'jokers'>, C<'sql'> and C<'commas'> or C<'brackets'> (depending on the L</do> or L</type> options), all of this by applying the C<'capture'> rules specified in the constructor or by L</capture>.
 
 =cut
 
@@ -413,21 +413,32 @@ sub convert {
  _check_self $self;
  my $config = (defined $type) ? $self->_type($type) : $self;
  return unless defined $wc;
+
+ my $e = $config->{escape};
+ # Escape :
+ # - an even number of \ that doesn't protect a regexp/wildcard metachar
+ # - an odd number of \ that doesn't protect a wildcard metachar
+ $wc =~ s/
+  (?<!\\)(
+   (?:\\\\)*
+   (?:
+     [^\w\s\\$e]
+    |
+     \\
+     (?: [^\W$e] | \s | $ )
+   )
+  )
+ /\\$1/gx;
+
  my $do = $config->{do};
- my $e  = $config->{escape};
- $wc =~ s/(?<!\\)((?:\\\\)*[^\w\s\\$e])/\\$1/g;
- if ($do->{jokers}) {
-  $wc = $self->_jokers($wc);
- } elsif ($do->{sql}) {
-  $wc = $self->_sql($wc);
- }
+ $wc = $self->_jokers($wc) if $do->{jokers};
+ $wc = $self->_sql($wc)    if $do->{sql};
  if ($do->{brackets}) {
   $wc = $self->_bracketed($wc);
- } elsif ($do->{commas}) {
-  if ($wc =~ /(?<!\\)(?:\\\\)*,/) { # win32 allows comma-separated lists
-   $wc = $self->{'c_brackets'} . $self->_commas($wc) . ')';
-  }
+ } elsif ($do->{commas} and $wc =~ /(?<!\\)(?:\\\\)*,/) {
+  $wc = $self->{'c_brackets'} . $self->_commas($wc) . ')';
  }
+
  return $wc;
 }
 
@@ -480,8 +491,6 @@ sub _extract ($) { extract_bracketed $_[0], '{',  qr/.*?(?<!\\)(?:\\\\)*(?={)/ }
 sub _jokers {
  my $self = shift;
  local $_ = $_[0];
- # escape an odd number of \ that doesn't protect a regexp/wildcard special char
- s/(?<!\\)((?:\\\\)*\\(?:[\w\s]|$))/\\$1/g;
  # substitute ? preceded by an even number of \
  my $s = $self->{c_single};
  s/(?<!\\)((?:\\\\)*)\?/$1$s/g;
@@ -494,8 +503,6 @@ sub _jokers {
 sub _sql {
  my $self = shift;
  local $_ = $_[0];
- # escape an odd number of \ that doesn't protect a regexp/wildcard special char
- s/(?<!\\)((?:\\\\)*\\(?:[^\W_]|\s|$))/\\$1/g;
  # substitute _ preceded by an even number of \
  my $s = $self->{c_single};
  s/(?<!\\)((?:\\\\)*)_/$1$s/g;
diff --git a/t/20-jokers.t b/t/20-jokers.t
index 3b21478..262a2aa 100644
--- a/t/20-jokers.t
+++ b/t/20-jokers.t
@@ -3,43 +3,46 @@
 use strict;
 use warnings;
 
-use Test::More tests => 2 * (4 + 2 + 7 + 8 + 6 + 2) * 3;
+use Test::More tests => 3 * (4 + 2 + 7 + 8 + 6 + 2) * 3;
 
 use Regexp::Wildcards;
 
 sub try {
  my ($rw, $s, $x, $y) = @_;
  $y = $x unless defined $y;
- my $t = $rw->{type};
- is($rw->convert('ab' . $x),      'ab' . $y,      $s . ' (begin) ['.$t.']');
- is($rw->convert('a' . $x . 'b'), 'a' . $y . 'b', $s . ' (middle) ['.$t.']');
- is($rw->convert($x . 'ab'),      $y . 'ab',      $s . ' (end) ['.$t.']');
+ my $d = $rw->{do};
+ $d = join ' ', keys %$d if ref($d) eq 'HASH';
+ is($rw->convert('ab' . $x),      'ab' . $y,      $s . " (begin) [$d]");
+ is($rw->convert('a' . $x . 'b'), 'a' . $y . 'b', $s . " (middle) [$d]");
+ is($rw->convert($x . 'ab'),      $y . 'ab',      $s . " (end) [$d]");
 }
 
 sub alltests {
- my ($t, $one, $any) = @_;
+ my ($d, $one, $any) = @_;
 
  my $rw = Regexp::Wildcards->new;
- $rw->type($t);
+ $rw->do(set => $d);
+
+ $d = join ' ', keys %$d if ref($d) eq 'HASH';
 
  # Simple
 
  try $rw, "simple $any", $any, '.*';
  try $rw, "simple $one", $one, '.';
 
- is($rw->convert($one.$any.'ab', $t), '..*ab',
-    "simple $one and $any (begin) [$t]");
- is($rw->convert($one.'a'.$any.'b', $t), '.a.*b',
-    "simple $one and $any (middle) [$t]");
- is($rw->convert($one.'ab'.$any, $t), '.ab.*',
-    "simple $one and $any (end) [$t]");
+ is($rw->convert($one.$any.'ab'), '..*ab',
+    "simple $one and $any (begin) [$d]");
+ is($rw->convert($one.'a'.$any.'b'), '.a.*b',
+    "simple $one and $any (middle) [$d]");
+ is($rw->convert($one.'ab'.$any), '.ab.*',
+    "simple $one and $any (end) [$d]");
 
- is($rw->convert($any.'ab'.$one, $t), '.*ab.',
-    "simple $any and $one (begin) [$t]");
- is($rw->convert('a'.$any.'b'.$one, $t), 'a.*b.',
-    "simple $any and $one (middle) [$t]");
- is($rw->convert('ab'.$any.$one, $t), 'ab.*.',
-    "simple $any and $one (end) [$t]");
+ is($rw->convert($any.'ab'.$one), '.*ab.',
+    "simple $any and $one (begin) [$d]");
+ is($rw->convert('a'.$any.'b'.$one), 'a.*b.',
+    "simple $any and $one (middle) [$d]");
+ is($rw->convert('ab'.$any.$one), 'ab.*.',
+    "simple $any and $one (end) [$d]");
 
  # Multiple
 
@@ -101,5 +104,6 @@ sub alltests {
  try $rw, "mixed $one and \\$one", $one.'\\'.$one.$one, '.\\'.$one.'.';
 }
 
-alltests 'jokers', '?', '*';
-alltests 'sql',    '_', '%';
+alltests 'jokers',           '?', '*';
+alltests 'sql',              '_', '%';
+alltests [ qw/jokers sql/ ], '_', '*';