lib/Regexp/Wildcards.pm

   1 package Regexp::Wildcards;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp qw/croak/;
   7 use Text::Balanced qw/extract_bracketed/;
   8
   9 =head1 NAME
  10
  11 Regexp::Wildcards - Converts wildcard expressions to Perl regular expressions.
  12
  13 =head1 VERSION
  14
  15 Version 1.02
  16
  17 =cut
  18
  19 use vars qw/$VERSION/;
  20 BEGIN {
  21  $VERSION = '1.02';
  22 }
  23
  24 =head1 SYNOPSIS
  25
  26     use Regexp::Wildcards;
  27
  28     my $rw = Regexp::Wildcards->new(type => 'unix');
  29
  30     my $re;
  31     $re = $rw->convert('a{b?,c}*');          # Do it Unix shell style.
  32     $re = $rw->convert('a?,b*',   'win32');  # Do it Windows shell style.
  33     $re = $rw->convert('*{x,y}?', 'jokers'); # Process the jokers and escape the rest.
  34     $re = $rw->convert('%a_c%',   'sql');    # Turn SQL wildcards into regexps.
  35
  36     $rw = Regexp::Wildcards->new(
  37      do      => [ qw/jokers brackets/ ], # Do jokers and brackets.
  38      capture => [ qw/any greedy/ ],      # Capture *'s greedily.
  39     );
  40
  41     $rw->do(add => 'groups');            # Don't escape groups.
  42     $rw->capture(rem => [ qw/greedy/ ]); # Actually we want non-greedy matches.
  43     $re = $rw->convert('*a{,(b)?}?c*');  # '(.*?)a(?:|(b).).c(.*?)'
  44     $rw->capture();                      # No more captures.
  45
  46 =head1 DESCRIPTION
  47
  48 In many situations, users may want to specify patterns to match but don't need the full power of regexps. Wildcards make one of those sets of simplified rules. This module converts wildcard expressions to Perl regular expressions, so that you can use them for matching.
  49
  50 It handles the C<*> and C<?> jokers, as well as Unix bracketed alternatives C<{,}>, but also C<%> and C<_> SQL wildcards. If required, it can also keep original C<(...)> groups or C<^> and C<$> anchors. Backspace (C<\>) is used as an escape character.
  51
  52 Typesets that mimic the behaviour of Windows and Unix shells are also provided.
  53
  54 =head1 METHODS
  55
  56 =cut
  57
  58 sub _check_self {
  59  croak 'First argument isn\'t a valid ' . __PACKAGE__ . ' object'
  60   unless ref $_[0] and $_[0]->isa(__PACKAGE__);
  61 }
  62
  63 my %types = (
  64  jokers   => [ qw/jokers/ ],
  65  sql      => [ qw/sql/ ],
  66  commas   => [ qw/commas/ ],
  67  brackets => [ qw/brackets/ ],
  68  unix     => [ qw/jokers brackets/ ],
  69  win32    => [ qw/jokers commas/ ],
  70 );
  71 $types{$_} = $types{win32} for qw/dos os2 MSWin32 cygwin/;
  72
  73 my %escapes = (
  74  jokers   => '?*',
  75  sql      => '_%',
  76  commas   => ',',
  77  brackets => '{},',
  78  groups   => '()',
  79  anchors  => '^$',
  80 );
  81
  82 my %captures = (
  83  single   => sub { $_[1] ? '(.)' : '.' },
  84  any      => sub { $_[1] ? ($_[0]->{greedy} ? '(.*)'
  85                                             : '(.*?)')
  86                          : '.*' },
  87  brackets => sub { $_[1] ? '(' : '(?:'; },
  88  greedy   => undef
  89 );
  90
  91 sub _validate {
  92  my $self  = shift;
  93  _check_self $self;
  94  my $valid = shift;
  95  my $old   = shift;
  96  $old = { } unless defined $old;
  97  my $c;
  98  if (@_ <= 1) {
  99   $c = { set => $_[0] };
 100  } elsif (@_ % 2) {
 101   croak 'Arguments must be passed as an unique scalar or as key => value pairs';
 102  } else {
 103   my %args = @_;
 104   $c = { map { (exists $args{$_}) ? ($_ => $args{$_}) : () } qw/set add rem/ };
 105  }
 106  for (qw/set add rem/) {
 107   my $v = $c->{$_};
 108   next unless defined $v;
 109   my $cb = {
 110    ''      => sub { +{ ($_[0] => 1) x (exists $valid->{$_[0]}) } },
 111    'ARRAY' => sub { +{ map { ($_ => 1) x (exists $valid->{$_}) } @{$_[0]} } },
 112    'HASH'  => sub { +{ map { ($_ => $_[0]->{$_}) x (exists $valid->{$_}) }
 113                         keys %{$_[0]} } }
 114   }->{ ref $v };
 115   croak 'Wrong option set' unless $cb;
 116   $c->{$_} = $cb->($v);
 117  }
 118  my $config = (exists $c->{set}) ? $c->{set} : $old;
 119  $config->{$_} = $c->{add}->{$_} for grep $c->{add}->{$_},
 120                                                 keys %{$c->{add} || {}};
 121  delete $config->{$_} for grep $c->{rem}->{$_}, keys %{$c->{rem} || {}};
 122  $config;
 123 }
 124
 125 sub _do {
 126  my $self = shift;
 127  my $config;
 128  $config->{do} = $self->_validate(\%escapes, $self->{do}, @_);
 129  $config->{escape} = '';
 130  $config->{escape} .= $escapes{$_} for keys %{$config->{do}};
 131  $config->{escape} = quotemeta $config->{escape};
 132  $config;
 133 }
 134
 135 sub do {
 136  my $self = shift;
 137  _check_self $self;
 138  my $config = $self->_do(@_);
 139  $self->{$_} = $config->{$_} for keys %$config;
 140  $self;
 141 }
 142
 143 sub _capture {
 144  my $self = shift;
 145  my $config;
 146  $config->{capture} = $self->_validate(\%captures, $self->{capture}, @_);
 147  $config->{greedy}  = delete $config->{capture}->{greedy};
 148  for (keys %captures) {
 149   $config->{'c_' . $_} = $captures{$_}->($config, $config->{capture}->{$_})
 150                                                if $captures{$_}; # Skip 'greedy'
 151  }
 152  $config;
 153 }
 154
 155 sub capture {
 156  my $self = shift;
 157  _check_self $self;
 158  my $config = $self->_capture(@_);
 159  $self->{$_} = $config->{$_} for keys %$config;
 160  $self;
 161 }
 162
 163 sub _type {
 164  my ($self, $type) = @_;
 165  $type = 'unix'      unless defined $type;
 166  croak 'Wrong type'  unless exists $types{$type};
 167  my $config = $self->_do($types{$type});
 168  $config->{type} = $type;
 169  $config;
 170 }
 171
 172 sub type {
 173  my $self = shift;
 174  _check_self $self;
 175  my $config = $self->_type(@_);
 176  $self->{$_} = $config->{$_} for keys %$config;
 177  $self;
 178 }
 179
 180 sub new {
 181  my $class = shift;
 182  $class = ref($class) || $class || __PACKAGE__;
 183  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
 184  my %args = @_;
 185  my $self = { };
 186  bless $self, $class;
 187  if (defined $args{do}) {
 188   $self->do($args{do});
 189  } else {
 190   $self->type($args{type});
 191  }
 192  $self->capture($args{capture});
 193 }
 194
 195 =head2 C<< new [ do => $what E<verbar> type => $type ], capture => $captures >>
 196
 197 Constructs a new L<Regexp::Wildcard> object.
 198
 199 C<do> lists all features that should be enabled when converting wildcards to regexps. Refer to L</do> for details on what can be passed in C<$what>.
 200
 201 The C<type> specifies a predefined set of C<do> features to use. See L</type> for details on which types are valid. The C<do> option overrides C<type>.
 202
 203 C<capture> lists which atoms should be capturing. Refer to L</capture> for more details.
 204
 205 =head2 C<< do [ $what E<verbar> set => $c1, add => $c2, rem => $c3 ] >>
 206
 207 Specifies the list of metacharacters to convert or to prevent for escaping.
 208 They fit into six classes :
 209
 210 =over 4
 211
 212 =item *
 213
 214 C<'jokers'> converts C<?> to C<.> and C<*> to C<.*> ;
 215
 216     'a**\\*b??\\?c' ==> 'a.*\\*b..\\?c'
 217
 218 =item *
 219
 220 C<'sql'> converts C<_> to C<.> and C<%> to C<.*> ;
 221
 222     'a%%\\%b__\\_c' ==> 'a.*\\%b..\\_c'
 223
 224 =item *
 225
 226 C<'commas'> converts all C<,> to C<|> and puts the complete resulting regular expression inside C<(?: ... )> ;
 227
 228     'a,b{c,d},e' ==> '(?:a|b\\{c|d\\}|e)'
 229
 230 =item *
 231
 232 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 ;
 233
 234     'a,b{c,d},e'    ==> 'a\\,b(?:c|d)\\,e'
 235     '{a\\{b,c}d,e}' ==> '(?:a\\{b|c)d\\,e\\}'
 236     '{a{b,c\\}d,e}' ==> '\\{a\\{b\\,c\\}d\\,e\\}'
 237
 238 =item *
 239
 240 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.
 241
 242     'a(b(c))d\\(\\)' ==> (no change)
 243
 244 =item *
 245
 246 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>.
 247
 248     'a^b$c' ==> (no change)
 249
 250 =back
 251
 252 Each C<$c> can be any of :
 253
 254 =over 4
 255
 256 =item *
 257
 258 A hash reference, with wanted metacharacter group names (described above) as keys and booleans as values ;
 259
 260 =item *
 261
 262 An array reference containing the list of wanted metacharacter classes ;
 263
 264 =item *
 265
 266 A plain scalar, when only one group is required.
 267
 268 =back
 269
 270 When C<set> is present, the classes given as its value replace the current object options. Then the C<add> classes are added, and the C<rem> classes removed.
 271
 272 Passing a sole scalar C<$what> is equivalent as passing C<< set => $what >>.
 273 No argument means C<< set => [ ] >>.
 274
 275     $rw->do(set => 'jokers');           # Only translate jokers.
 276     $rw->do('jokers');                  # Same.
 277     $rw->do(add => [ qw/sql commas/ ]); # Translate also SQL and commas.
 278     $rw->do(rem => 'jokers');           # Specifying both 'sql' and 'jokers' is useless.
 279     $rw->do();                          # Translate nothing.
 280
 281 =head2 C<type $type>
 282
 283 Notifies to convert the metacharacters that corresponds to the predefined type C<$type>. C<$type> can be any of C<'jokers'>, C<'sql'>, C<'commas'>, C<'brackets'>, C<'win32'> or C<'unix'>. An unknown or undefined value defaults to C<'unix'>, except for C<'dos'>, C<'os2'>, C<'MSWin32'> and C<'cygwin'> that default to C<'win32'>. This means that you can pass C<$^O> as the C<$type> and get the corresponding shell behaviour. Returns the object.
 284
 285     $rw->type('win32'); # Set type to win32.
 286     $rw->type();        # Set type to unix.
 287
 288 =head2 C<< capture [ $captures E<verbar> set => $c1, add => $c2, rem => $c3 ] >>
 289
 290 Specifies the list of atoms to capture.
 291 This method works like L</do>, except that the classes are different :
 292
 293 =over 4
 294
 295 =item *
 296
 297 C<'single'> will capture all unescaped I<"exactly one"> metacharacters, i.e. C<?> for wildcards or C<_> for SQL ;
 298
 299     'a???b\\??' ==> 'a(.)(.)(.)b\\?(.)'
 300     'a___b\\__' ==> 'a(.)(.)(.)b\\_(.)'
 301
 302 =item *
 303
 304 C<'any'> will capture all unescaped I<"any"> metacharacters, i.e. C<*> for wildcards or C<%> for SQL ;
 305
 306     'a***b\\**' ==> 'a(.*)b\\*(.*)'
 307     'a%%%b\\%%' ==> 'a(.*)b\\%(.*)'
 308
 309 =item *
 310
 311 C<'greedy'>, when used in conjunction with C<'any'>, will make the C<'any'> captures greedy (by default they are not) ;
 312
 313     'a***b\\**' ==> 'a(.*?)b\\*(.*?)'
 314     'a%%%b\\%%' ==> 'a(.*?)b\\%(.*?)'
 315
 316 =item *
 317
 318 C<'brackets'> will capture matching C<{ ... , ... }> alternations.
 319
 320     'a{b\\},\\{c}' ==> 'a(b\\}|\\{c)'
 321
 322 =back
 323
 324     $rw->capture(set => 'single');           # Only capture "exactly one" metacharacters.
 325     $rw->capture('single');                  # Same.
 326     $rw->capture(add => [ qw/any greedy/ ]); # Also greedily capture "any" metacharacters.
 327     $rw->capture(rem => 'greedy');           # No more greed please.
 328     $rw->capture();                          # Capture nothing.
 329
 330 =head2 C<convert $wc [ , $type ]>
 331
 332 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>.
 333
 334 =cut
 335
 336 sub convert {
 337  my ($self, $wc, $type) = @_;
 338  _check_self $self;
 339  my $config;
 340  if (defined $type) {
 341   $config = $self->_type($type);
 342  } else {
 343   $config = $self;
 344  }
 345  return unless defined $wc;
 346  my $do = $config->{do};
 347  my $e  = $config->{escape};
 348  $wc =~ s/(?<!\\)((?:\\\\)*[^\w\s\\$e])/\\$1/g;
 349  if ($do->{jokers}) {
 350   $wc = $self->_jokers($wc);
 351  } elsif ($do->{sql}) {
 352   $wc = $self->_sql($wc);
 353  }
 354  if ($do->{brackets}) {
 355   $wc = $self->_bracketed($wc);
 356  } elsif ($do->{commas}) {
 357   if ($wc =~ /(?<!\\)(?:\\\\)*,/) { # win32 allows comma-separated lists
 358    $wc = $self->{'c_brackets'} . $self->_commas($wc) . ')';
 359   }
 360  }
 361  return $wc;
 362 }
 363
 364 =head1 EXPORT
 365
 366 An object module shouldn't export any function, and so does this one.
 367
 368 =head1 DEPENDENCIES
 369
 370 L<Carp> (core module since perl 5), L<Text::Balanced> (since 5.7.3).
 371
 372 =head1 CAVEATS
 373
 374 This module does not implement the strange behaviours of Windows shell that result from the special handling of the three last characters (for the file extension). For example, Windows XP shell matches C<*a> like C<.*a>, C<*a?> like C<.*a.?>, C<*a??> like C<.*a.{0,2}> and so on.
 375
 376 =head1 AUTHOR
 377
 378 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 379
 380 You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
 381
 382 =head1 BUGS
 383
 384 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.
 385
 386 =head1 SUPPORT
 387
 388 You can find documentation for this module with the perldoc command.
 389
 390     perldoc Regexp::Wildcards
 391
 392 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Regexp-Wildcards>.
 393
 394 =head1 COPYRIGHT & LICENSE
 395
 396 Copyright 2007-2008 Vincent Pit, all rights reserved.
 397
 398 This program is free software; you can redistribute it and/or modify it
 399 under the same terms as Perl itself.
 400
 401 =cut
 402
 403 sub _extract ($) { extract_bracketed $_[0], '{',  qr/.*?(?<!\\)(?:\\\\)*(?={)/ }
 404
 405 sub _jokers {
 406  my $self = shift;
 407  local $_ = $_[0];
 408  # escape an odd number of \ that doesn't protect a regexp/wildcard special char
 409  s/(?<!\\)((?:\\\\)*\\(?:[\w\s]|$))/\\$1/g;
 410  # substitute ? preceded by an even number of \
 411  my $s = $self->{c_single};
 412  s/(?<!\\)((?:\\\\)*)\?/$1$s/g;
 413  # substitute * preceded by an even number of \
 414  $s = $self->{c_any};
 415  s/(?<!\\)((?:\\\\)*)\*+/$1$s/g;
 416  return $_;
 417 }
 418
 419 sub _sql {
 420  my $self = shift;
 421  local $_ = $_[0];
 422  # escape an odd number of \ that doesn't protect a regexp/wildcard special char
 423  s/(?<!\\)((?:\\\\)*\\(?:[^\W_]|\s|$))/\\$1/g;
 424  # substitute _ preceded by an even number of \
 425  my $s = $self->{c_single};
 426  s/(?<!\\)((?:\\\\)*)_/$1$s/g;
 427  # substitute % preceded by an even number of \
 428  $s = $self->{c_any};
 429  s/(?<!\\)((?:\\\\)*)%+/$1$s/g;
 430  return $_;
 431 }
 432
 433 sub _commas {
 434  local $_ = $_[1];
 435  # substitute , preceded by an even number of \
 436  s/(?<!\\)((?:\\\\)*),/$1|/g;
 437  return $_;
 438 }
 439
 440 sub _brackets {
 441  my ($self, $rest) = @_;
 442  substr $rest, 0, 1, '';
 443  chop $rest;
 444  my ($re, $bracket, $prefix) = ('');
 445  while (do { ($bracket, $rest, $prefix) = _extract $rest; $bracket }) {
 446   $re .= $self->_commas($prefix) . $self->_brackets($bracket);
 447  }
 448  $re .= $self->_commas($rest);
 449  return $self->{c_brackets} . $re . ')';
 450 }
 451
 452 sub _bracketed {
 453  my ($self, $rest) = @_;
 454  my ($re, $bracket, $prefix) = ('');
 455  while (do { ($bracket, $rest, $prefix) = _extract $rest; $bracket }) {
 456   $re .= $prefix . $self->_brackets($bracket);
 457  }
 458  $re .= $rest;
 459  $re =~ s/(?<!\\)((?:\\\\)*[\{\},])/\\$1/g;
 460  return $re;
 461 }
 462
 463 1; # End of Regexp::Wildcards