use strict;
use warnings;
-use Carp qw/croak/;
-use Text::Balanced qw/extract_bracketed/;
+use Carp qw<croak>;
+use Scalar::Util qw<blessed>;
+use Text::Balanced qw<extract_bracketed>;
=head1 NAME
=head1 VERSION
-Version 1.02
+Version 1.04
=cut
-use vars qw/$VERSION/;
+use vars qw<$VERSION>;
BEGIN {
- $VERSION = '1.02';
+ $VERSION = '1.04';
}
=head1 SYNOPSIS
$re = $rw->convert('%a_c%', 'sql'); # Turn SQL wildcards into regexps.
$rw = Regexp::Wildcards->new(
- do => [ qw/jokers brackets/ ], # Do jokers and brackets.
- capture => [ qw/any greedy/ ], # Capture *'s greedily.
+ do => [ qw<jokers brackets> ], # Do jokers and brackets.
+ capture => [ qw<any greedy> ], # Capture *'s greedily.
);
$rw->do(add => 'groups'); # Don't escape groups.
- $rw->capture(rem => [ qw/greedy/ ]); # Actually we want non-greedy matches.
+ $rw->capture(rem => [ qw<greedy> ]); # Actually we want non-greedy matches.
$re = $rw->convert('*a{,(b)?}?c*'); # '(.*?)a(?:|(b).).c(.*?)'
$rw->capture(); # No more captures.
sub _check_self {
croak 'First argument isn\'t a valid ' . __PACKAGE__ . ' object'
- unless ref $_[0] and $_[0]->isa(__PACKAGE__);
+ unless blessed $_[0] and $_[0]->isa(__PACKAGE__);
}
my %types = (
- jokers => [ qw/jokers/ ],
- sql => [ qw/sql/ ],
- commas => [ qw/commas/ ],
- brackets => [ qw/brackets/ ],
- unix => [ qw/jokers brackets/ ],
- win32 => [ qw/jokers commas/ ],
+ jokers => [ qw<jokers> ],
+ sql => [ qw<sql> ],
+ commas => [ qw<commas> ],
+ brackets => [ qw<brackets> ],
+ unix => [ qw<jokers brackets> ],
+ win32 => [ qw<jokers commas> ],
);
-$types{$_} = $types{win32} for qw/dos os2 MSWin32 cygwin/;
-$types{$_} = $types{unix} for qw/linux
+$types{$_} = $types{win32} for qw<dos os2 MSWin32 cygwin>;
+$types{$_} = $types{unix} for qw<linux
darwin machten next
aix irix hpux dgux dynixptx
bsdos freebsd openbsd
svr4 solaris sunos dec_osf
- sco_sv unicos unicosmk/;
+ sco_sv unicos unicosmk>;
my %escapes = (
jokers => '?*',
: '(.*?)')
: '.*' },
brackets => sub { $_[1] ? '(' : '(?:'; },
- greedy => undef
+ greedy => undef,
);
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 = @_;
}
- for (qw/set add rem/) {
- my $v = $c->{$_};
- next unless defined $v;
+
+ my %checked;
+ for (qw<set add rem>) {
+ 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;
}
sub _do {
my $self = shift;
+
my $config;
- $config->{do} = $self->_validate(\%escapes, $self->{do}, @_);
- $config->{escape} = '';
+ $config->{do} = $self->_validate(\%escapes, $self->{do}, @_);
+ $config->{escape} = '';
$config->{escape} .= $escapes{$_} for keys %{$config->{do}};
- $config->{escape} = quotemeta $config->{escape};
+ $config->{escape} = quotemeta $config->{escape};
+
$config;
}
sub do {
my $self = shift;
_check_self $self;
- my $config = $self->_do(@_);
+
+ my $config = $self->_do(@_);
$self->{$_} = $config->{$_} for keys %$config;
+
$self;
}
sub _capture {
my $self = shift;
+
my $config;
$config->{capture} = $self->_validate(\%captures, $self->{capture}, @_);
$config->{greedy} = delete $config->{capture}->{greedy};
$config->{'c_' . $_} = $captures{$_}->($config, $config->{capture}->{$_})
if $captures{$_}; # Skip 'greedy'
}
+
$config;
}
sub capture {
my $self = shift;
_check_self $self;
- my $config = $self->_capture(@_);
+
+ my $config = $self->_capture(@_);
$self->{$_} = $config->{$_} for keys %$config;
+
$self;
}
sub _type {
my ($self, $type) = @_;
- $type = 'unix' unless defined $type;
- croak 'Wrong type' unless exists $types{$type};
- my $config = $self->_do($types{$type});
+ $type = 'unix' unless defined $type;
+ croak 'Wrong type' unless exists $types{$type};
+
+ my $config = $self->_do($types{$type});
$config->{type} = $type;
+
$config;
}
sub type {
my $self = shift;
_check_self $self;
- my $config = $self->_type(@_);
+
+ my $config = $self->_type(@_);
$self->{$_} = $config->{$_} for keys %$config;
+
$self;
}
sub new {
my $class = shift;
- $class = ref($class) || $class || __PACKAGE__;
+ $class = blessed($class) || $class || __PACKAGE__;
+
croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
my %args = @_;
- my $self = { };
- bless $self, $class;
+
+ my $self = bless { }, $class;
+
if (defined $args{do}) {
$self->do($args{do});
} else {
$self->type($args{type});
}
+
$self->capture($args{capture});
}
-=head2 C<< new [ do => $what E<verbar> type => $type ], capture => $captures >>
+=head2 C<new>
+
+ my $rw = Regexp::Wildcards->new(do => $what, capture => $capture);
+ my $rw = Regexp::Wildcards->new(type => $type, capture => $capture);
Constructs a new L<Regexp::Wildcard> object.
C<capture> lists which atoms should be capturing.
Refer to L</capture> for more details.
-=head2 C<< do [ $what E<verbar> set => $c1, add => $c2, rem => $c3 ] >>
+=head2 C<do>
+
+ $rw->do($what);
+ $rw->do(set => $c1);
+ $rw->do(add => $c2);
+ $rw->do(rem => $c3);
Specifies the list of metacharacters to convert or to prevent for escaping.
They fit into six classes :
=item *
-C<'jokers'> converts C<?> to C<.> and C<*> to C<.*> ;
+C<'jokers'>
+
+Converts C<?> to C<.> and C<*> to C<.*>.
'a**\\*b??\\?c' ==> 'a.*\\*b..\\?c'
=item *
-C<'sql'> converts C<_> to C<.> and C<%> to C<.*> ;
+C<'sql'>
+
+Converts C<_> to C<.> and C<%> to C<.*>.
'a%%\\%b__\\_c' ==> 'a.*\\%b..\\_c'
=item *
-C<'commas'> converts all C<,> to C<|> and puts the complete resulting regular expression inside C<(?: ... )> ;
+C<'commas'>
+
+Converts all C<,> to C<|> and puts the complete resulting regular expression inside C<(?: ... )>.
'a,b{c,d},e' ==> '(?:a|b\\{c|d\\}|e)'
=item *
-C<'brackets'> converts all matching C<{ ... , ... }> brackets to C<(?: ... | ... )> alternations.
+C<'brackets'>
+
+Converts all matching C<{ ... , ... }> brackets to C<(?: ... | ... )> alternations.
If some brackets are unbalanced, it tries to substitute as many of them as possible, and then escape the remaining unmatched C<{> and C<}>.
-Commas outside of any bracket-delimited block are also escaped ;
+Commas outside of any bracket-delimited block are also escaped.
'a,b{c,d},e' ==> 'a\\,b(?:c|d)\\,e'
'{a\\{b,c}d,e}' ==> '(?:a\\{b|c)d\\,e\\}'
=item *
-C<'groups'> keeps the parenthesis C<( ... )> of the original string without escaping them.
+C<'groups'>
+
+Keeps the parenthesis C<( ... )> of the original string without escaping them.
Currently, no check is done to ensure that the parenthesis are matching.
'a(b(c))d\\(\\)' ==> (no change)
=item *
-C<'anchors'> prevents the I<beginning-of-line> C<^> and I<end-of-line> C<$> anchors to be escaped.
+C<'anchors'>
+
+Prevents the I<beginning-of-line> C<^> and I<end-of-line> C<$> anchors to be escaped.
Since C<[...]> character class are currently escaped, a C<^> will always be interpreted as I<beginning-of-line>.
'a^b$c' ==> (no change)
$rw->do(set => 'jokers'); # Only translate jokers.
$rw->do('jokers'); # Same.
- $rw->do(add => [ qw/sql commas/ ]); # Translate also SQL and commas.
+ $rw->do(add => [ qw<sql commas> ]); # Translate also SQL and commas.
$rw->do(rem => 'jokers'); # Specifying both 'sql' and 'jokers' is useless.
$rw->do(); # Translate nothing.
-=head2 C<type $type>
+The C<do> method returns the L<Regexp::Wildcards> object.
+
+=head2 C<type>
+
+ $rw->type($type);
Notifies to convert the metacharacters that corresponds to the predefined type C<$type>.
C<$type> can be any of :
The C<type> method returns the L<Regexp::Wildcards> object.
-=head2 C<< capture [ $captures E<verbar> set => $c1, add => $c2, rem => $c3 ] >>
+=head2 C<capture>
+
+ $rw->capture($captures);
+ $rw->capture(set => $c1);
+ $rw->capture(add => $c2);
+ $rw->capture(rem => $c3);
Specifies the list of atoms to capture.
This method works like L</do>, except that the classes are different :
=item *
-C<'single'> will capture all unescaped I<"exactly one"> metacharacters, i.e. C<?> for wildcards or C<_> for SQL ;
+C<'single'>
+
+Captures all unescaped I<"exactly one"> metacharacters, i.e. C<?> for wildcards or C<_> for SQL.
'a???b\\??' ==> 'a(.)(.)(.)b\\?(.)'
'a___b\\__' ==> 'a(.)(.)(.)b\\_(.)'
=item *
-C<'any'> will capture all unescaped I<"any"> metacharacters, i.e. C<*> for wildcards or C<%> for SQL ;
+C<'any'>
+
+Captures all unescaped I<"any"> metacharacters, i.e. C<*> for wildcards or C<%> for SQL.
'a***b\\**' ==> 'a(.*)b\\*(.*)'
'a%%%b\\%%' ==> 'a(.*)b\\%(.*)'
=item *
-C<'greedy'>, when used in conjunction with C<'any'>, will make the C<'any'> captures greedy (by default they are not) ;
+C<'greedy'>
+
+When used in conjunction with C<'any'>, it makes the C<'any'> captures greedy (by default they are not).
'a***b\\**' ==> 'a(.*?)b\\*(.*?)'
'a%%%b\\%%' ==> 'a(.*?)b\\%(.*?)'
=item *
-C<'brackets'> will capture matching C<{ ... , ... }> alternations.
+C<'brackets'>
+
+Capture matching C<{ ... , ... }> alternations.
'a{b\\},\\{c}' ==> 'a(b\\}|\\{c)'
$rw->capture(set => 'single'); # Only capture "exactly one" metacharacters.
$rw->capture('single'); # Same.
- $rw->capture(add => [ qw/any greedy/ ]); # Also greedily capture "any" metacharacters.
+ $rw->capture(add => [ qw<any greedy> ]); # Also greedily capture "any" metacharacters.
$rw->capture(rem => 'greedy'); # No more greed please.
$rw->capture(); # Capture nothing.
-=head2 C<convert $wc [ , $type ]>
+The C<capture> method returns the L<Regexp::Wildcards> object.
+
+=head2 C<convert>
+
+ my $rx = $rw->convert($wc);
+ my $rx = $rw->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
sub convert {
my ($self, $wc, $type) = @_;
_check_self $self;
- my $config;
- if (defined $type) {
- $config = $self->_type($type);
- } else {
- $config = $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;
+
+ $wc
}
=head1 EXPORT
=head1 DEPENDENCIES
-L<Carp> (core module since perl 5), L<Text::Balanced> (since 5.7.3).
+L<Carp> (core module since perl 5), L<Scalar::Util>, L<Text::Balanced> (since 5.7.3).
=head1 CAVEATS
=head1 COPYRIGHT & LICENSE
-Copyright 2007-2008 Vincent Pit, all rights reserved.
+Copyright 2007-2009 Vincent Pit, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
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;
# substitute * preceded by an even number of \
$s = $self->{c_any};
s/(?<!\\)((?:\\\\)*)\*+/$1$s/g;
- return $_;
+
+ $_
}
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;
# substitute % preceded by an even number of \
$s = $self->{c_any};
s/(?<!\\)((?:\\\\)*)%+/$1$s/g;
- return $_;
+
+ $_
}
sub _commas {
local $_ = $_[1];
+
# substitute , preceded by an even number of \
s/(?<!\\)((?:\\\\)*),/$1|/g;
- return $_;
+
+ $_
}
sub _brackets {
my ($self, $rest) = @_;
+
substr $rest, 0, 1, '';
chop $rest;
+
my ($re, $bracket, $prefix) = ('');
while (do { ($bracket, $rest, $prefix) = _extract $rest; $bracket }) {
$re .= $self->_commas($prefix) . $self->_brackets($bracket);
}
$re .= $self->_commas($rest);
- return $self->{c_brackets} . $re . ')';
+
+ $self->{c_brackets} . $re . ')';
}
sub _bracketed {
my ($self, $rest) = @_;
+
my ($re, $bracket, $prefix) = ('');
while (do { ($bracket, $rest, $prefix) = _extract $rest; $bracket }) {
$re .= $prefix . $self->_brackets($bracket);
}
$re .= $rest;
+
$re =~ s/(?<!\\)((?:\\\\)*[\{\},])/\\$1/g;
- return $re;
+
+ $re;
}
1; # End of Regexp::Wildcards
projects / perl / modules / Regexp-Wildcards.git / blobdiff