use warnings;
use Carp qw<croak>;
+use Scalar::Util qw<blessed>;
use Text::Balanced qw<extract_bracketed>;
=head1 NAME
=head1 VERSION
-Version 1.03
+Version 1.04
=cut
use vars qw<$VERSION>;
BEGIN {
- $VERSION = '1.03';
+ $VERSION = '1.04';
}
=head1 SYNOPSIS
my $re;
$re = $rw->convert('a{b?,c}*'); # Do it Unix shell style.
$re = $rw->convert('a?,b*', 'win32'); # Do it Windows shell style.
- $re = $rw->convert('*{x,y}?', 'jokers'); # Process the jokers and escape the rest.
- $re = $rw->convert('%a_c%', 'sql'); # Turn SQL wildcards into regexps.
+ $re = $rw->convert('*{x,y}?', 'jokers'); # Process the jokers and
+ # escape the rest.
+ $re = $rw->convert('%a_c%', 'sql'); # Turn SQL wildcards into
+ # regexps.
$rw = Regexp::Wildcards->new(
do => [ qw<jokers brackets> ], # Do jokers and brackets.
);
$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 = (
: '(.*?)')
: '.*' },
brackets => sub { $_[1] ? '(' : '(?:'; },
- greedy => undef
+ greedy => undef,
);
sub _validate {
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]} } },
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 :
$rw->do(set => 'jokers'); # Only translate jokers.
$rw->do('jokers'); # Same.
$rw->do(add => [ qw<sql commas> ]); # Translate also SQL and commas.
- $rw->do(rem => 'jokers'); # Specifying both 'sql' and 'jokers' is useless.
+ $rw->do(rem => 'jokers'); # Specifying both 'sql' and
+ # 'jokers' is useless.
$rw->do(); # Translate nothing.
The C<do> method returns the L<Regexp::Wildcards> object.
-=head2 C<type $type>
+=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 :
=back
- $rw->capture(set => 'single'); # Only capture "exactly one" metacharacters.
+ $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.
The C<capture> method returns the L<Regexp::Wildcards> object.
-=head2 C<convert $wc [ , $type ]>
+=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'>, 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>.
sub convert {
my ($self, $wc, $type) = @_;
_check_self $self;
+
my $config = (defined $type) ? $self->_type($type) : $self;
return unless defined $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 BUGS
-Please report any bugs or feature requests to C<bug-regexp-wildcards at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Regexp-Wildcards>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
+Please report any bugs or feature requests to C<bug-regexp-wildcards at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Regexp-Wildcards>.
+I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
sub _jokers {
my $self = shift;
local $_ = $_[0];
+
# 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];
+
# 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