Allow translating glob and sql jokers at the same time

[perl/modules/Regexp-Wildcards.git] / lib / Regexp / Wildcards.pm

diff --git a/lib/Regexp/Wildcards.pm b/lib/Regexp/Wildcards.pm
index b70b593edaae910d4adacef7773bce5b5bd6160c..abb59f0fefde1543312419d3a3a3f4cca5205a63 100644 (file)
--- a/lib/Regexp/Wildcards.pm
+++ b/lib/Regexp/Wildcards.pm
@@ -104,31 +104,36 @@ sub _validate {
  my $valid = shift;
  my $old   = shift;
  $old = { } unless defined $old;
- my $c;
+
+ my %opts;
  if (@_ <= 1) {
-  $c = { set => $_[0] };
+  $opts{set} = defined $_[0] ? $_[0] : { };
  } elsif (@_ % 2) {
   croak 'Arguments must be passed as an unique scalar or as key => value pairs';
  } else {
-  my %args = @_;
-  $c = { map { (exists $args{$_}) ? ($_ => $args{$_}) : () } qw/set add rem/ };
+  %opts = @_;
  }
+
+ my %checked;
  for (qw/set add rem/) {
-  my $v = $c->{$_};
-  next unless defined $v;
+  my $opt = $opts{$_};
+  next unless defined $opt;
   my $cb = {
    ''      => sub { +{ ($_[0] => 1) x (exists $valid->{$_[0]}) } },
    'ARRAY' => sub { +{ map { ($_ => 1) x (exists $valid->{$_}) } @{$_[0]} } },
    'HASH'  => sub { +{ map { ($_ => $_[0]->{$_}) x (exists $valid->{$_}) }
                         keys %{$_[0]} } }
-  }->{ ref $v };
+  }->{ ref $opt };
   croak 'Wrong option set' unless $cb;
-  $c->{$_} = $cb->($v);
+  $checked{$_} = $cb->($opt);
  }
- my $config = (exists $c->{set}) ? $c->{set} : $old;
- $config->{$_} = $c->{add}->{$_} for grep $c->{add}->{$_},
-                                                keys %{$c->{add} || {}};
- delete $config->{$_} for grep $c->{rem}->{$_}, keys %{$c->{rem} || {}};
+
+ my $config = (exists $checked{set}) ? $checked{set} : $old;
+ $config->{$_} = $checked{add}->{$_} for grep $checked{add}->{$_},
+                                          keys %{$checked{add} || {}};
+ delete $config->{$_}                for grep $checked{rem}->{$_},
+                                          keys %{$checked{rem} || {}};
+
  $config;
 }
 
@@ -394,10 +399,12 @@ C<'brackets'> will capture matching C<{ ... , ... }> alternations.
     $rw->capture(rem => 'greedy');           # No more greed please.
     $rw->capture();                          # Capture nothing.
 
+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
 
@@ -406,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;
 }
 
@@ -473,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;
@@ -487,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;