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 $types{$_} = $types{unix}  for qw/linux
  73                                   darwin machten next
  74                                   aix irix hpux dgux dynixptx
  75                                   bsdos freebsd openbsd
  76                                   svr4 solaris sunos dec_osf
  77                                   sco_sv unicos unicosmk/;
  78
  79 my %escapes = (
  80  jokers   => '?*',
  81  sql      => '_%',
  82  commas   => ',',
  83  brackets => '{},',
  84  groups   => '()',
  85  anchors  => '^$',
  86 );
  87
  88 my %captures = (
  89  single   => sub { $_[1] ? '(.)' : '.' },
  90  any      => sub { $_[1] ? ($_[0]->{greedy} ? '(.*)'
  91                                             : '(.*?)')
  92                          : '.*' },
  93  brackets => sub { $_[1] ? '(' : '(?:'; },
  94  greedy   => undef
  95 );
  96
  97 sub _validate {
  98  my $self  = shift;
  99  _check_self $self;
 100  my $valid = shift;
 101  my $old   = shift;
 102  $old = { } unless defined $old;
 103  my $c;
 104  if (@_ <= 1) {
 105   $c = { set => $_[0] };
 106  } elsif (@_ % 2) {
 107   croak 'Arguments must be passed as an unique scalar or as key => value pairs';
 108  } else {
 109   my %args = @_;
 110   $c = { map { (exists $args{$_}) ? ($_ => $args{$_}) : () } qw/set add rem/ };
 111  }
 112  for (qw/set add rem/) {
 113   my $v = $c->{$_};
 114   next unless defined $v;
 115   my $cb = {
 116    ''      => sub { +{ ($_[0] => 1) x (exists $valid->{$_[0]}) } },
 117    'ARRAY' => sub { +{ map { ($_ => 1) x (exists $valid->{$_}) } @{$_[0]} } },
 118    'HASH'  => sub { +{ map { ($_ => $_[0]->{$_}) x (exists $valid->{$_}) }
 119                         keys %{$_[0]} } }
 120   }->{ ref $v };
 121   croak 'Wrong option set' unless $cb;
 122   $c->{$_} = $cb->($v);
 123  }
 124  my $config = (exists $c->{set}) ? $c->{set} : $old;
 125  $config->{$_} = $c->{add}->{$_} for grep $c->{add}->{$_},
 126                                                 keys %{$c->{add} || {}};
 127  delete $config->{$_} for grep $c->{rem}->{$_}, keys %{$c->{rem} || {}};
 128  $config;
 129 }
 130
 131 sub _do {
 132  my $self = shift;
 133  my $config;
 134  $config->{do} = $self->_validate(\%escapes, $self->{do}, @_);
 135  $config->{escape} = '';
 136  $config->{escape} .= $escapes{$_} for keys %{$config->{do}};
 137  $config->{escape} = quotemeta $config->{escape};
 138  $config;
 139 }
 140
 141 sub do {
 142  my $self = shift;
 143  _check_self $self;
 144  my $config = $self->_do(@_);
 145  $self->{$_} = $config->{$_} for keys %$config;
 146  $self;
 147 }
 148
 149 sub _capture {
 150  my $self = shift;
 151  my $config;
 152  $config->{capture} = $self->_validate(\%captures, $self->{capture}, @_);
 153  $config->{greedy}  = delete $config->{capture}->{greedy};
 154  for (keys %captures) {
 155   $config->{'c_' . $_} = $captures{$_}->($config, $config->{capture}->{$_})
 156                                                if $captures{$_}; # Skip 'greedy'
 157  }
 158  $config;
 159 }
 160
 161 sub capture {
 162  my $self = shift;
 163  _check_self $self;
 164  my $config = $self->_capture(@_);
 165  $self->{$_} = $config->{$_} for keys %$config;
 166  $self;
 167 }
 168
 169 sub _type {
 170  my ($self, $type) = @_;
 171  $type = 'unix'      unless defined $type;
 172  croak 'Wrong type'  unless exists $types{$type};
 173  my $config = $self->_do($types{$type});
 174  $config->{type} = $type;
 175  $config;
 176 }
 177
 178 sub type {
 179  my $self = shift;
 180  _check_self $self;
 181  my $config = $self->_type(@_);
 182  $self->{$_} = $config->{$_} for keys %$config;
 183  $self;
 184 }
 185
 186 sub new {
 187  my $class = shift;
 188  $class = ref($class) || $class || __PACKAGE__;
 189  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
 190  my %args = @_;
 191  my $self = { };
 192  bless $self, $class;
 193  if (defined $args{do}) {
 194   $self->do($args{do});
 195  } else {
 196   $self->type($args{type});
 197  }
 198  $self->capture($args{capture});
 199 }
 200
 201 =head2 C<< new [ do => $what E<verbar> type => $type ], capture => $captures >>
 202
 203 Constructs a new L<Regexp::Wildcard> object.
 204
 205 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>.
 206
 207 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>.
 208
 209 C<capture> lists which atoms should be capturing. Refer to L</capture> for more details.
 210
 211 =head2 C<< do [ $what E<verbar> set => $c1, add => $c2, rem => $c3 ] >>
 212
 213 Specifies the list of metacharacters to convert or to prevent for escaping.
 214 They fit into six classes :
 215
 216 =over 4
 217
 218 =item *
 219
 220 C<'jokers'> converts C<?> to C<.> and C<*> to C<.*> ;
 221
 222     'a**\\*b??\\?c' ==> 'a.*\\*b..\\?c'
 223
 224 =item *
 225
 226 C<'sql'> converts C<_> to C<.> and C<%> to C<.*> ;
 227
 228     'a%%\\%b__\\_c' ==> 'a.*\\%b..\\_c'
 229
 230 =item *
 231
 232 C<'commas'> converts all C<,> to C<|> and puts the complete resulting regular expression inside C<(?: ... )> ;
 233
 234     'a,b{c,d},e' ==> '(?:a|b\\{c|d\\}|e)'
 235
 236 =item *
 237
 238 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 ;
 239
 240     'a,b{c,d},e'    ==> 'a\\,b(?:c|d)\\,e'
 241     '{a\\{b,c}d,e}' ==> '(?:a\\{b|c)d\\,e\\}'
 242     '{a{b,c\\}d,e}' ==> '\\{a\\{b\\,c\\}d\\,e\\}'
 243
 244 =item *
 245
 246 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.
 247
 248     'a(b(c))d\\(\\)' ==> (no change)
 249
 250 =item *
 251
 252 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>.
 253
 254     'a^b$c' ==> (no change)
 255
 256 =back
 257
 258 Each C<$c> can be any of :
 259
 260 =over 4
 261
 262 =item *
 263
 264 A hash reference, with wanted metacharacter group names (described above) as keys and booleans as values ;
 265
 266 =item *
 267
 268 An array reference containing the list of wanted metacharacter classes ;
 269
 270 =item *
 271
 272 A plain scalar, when only one group is required.
 273
 274 =back
 275
 276 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.
 277
 278 Passing a sole scalar C<$what> is equivalent as passing C<< set => $what >>.
 279 No argument means C<< set => [ ] >>.
 280
 281     $rw->do(set => 'jokers');           # Only translate jokers.
 282     $rw->do('jokers');                  # Same.
 283     $rw->do(add => [ qw/sql commas/ ]); # Translate also SQL and commas.
 284     $rw->do(rem => 'jokers');           # Specifying both 'sql' and 'jokers' is useless.
 285     $rw->do();                          # Translate nothing.
 286
 287 =head2 C<type $type>
 288
 289 Notifies to convert the metacharacters that corresponds to the predefined type C<$type>.
 290 C<$type> can be any of :
 291
 292 =over 4
 293
 294 =item *
 295
 296 C<'jokers'>, C<'sql'>, C<'commas'>, C<'brackets'>
 297
 298 Singleton types that enable the corresponding C<do> classes.
 299
 300 =item *
 301
 302 C<'unix'>
 303
 304 Covers typical Unix shell globbing features (effectively C<'jokers'> and C<'brackets'>).
 305
 306 =item *
 307
 308 C<$^O> values for common Unix systems
 309
 310 Wrap to C<'unix'> (see L<perlport> for the list).
 311
 312 =item *
 313
 314 C<undef>
 315
 316 Defaults to C<'unix'>.
 317
 318 =item *
 319
 320 C<'win32'>
 321
 322 Covers typical Windows shell globbing features (effectively C<'jokers'> and C<'commas'>).
 323
 324 =item *
 325
 326 C<'dos'>, C<'os2'>, C<'MSWin32'>, C<'cygwin'>
 327
 328 Wrap to C<'win32'>.
 329
 330 =back
 331
 332 In particular, you can usually pass C<$^O> as the C<$type> and get the corresponding shell behaviour.
 333
 334     $rw->type('win32'); # Set type to win32.
 335     $rw->type($^O);     # Set type to unix on Unices and win32 on Windows
 336     $rw->type();        # Set type to unix.
 337
 338 The C<type> method returns the L<Regexp::Wildcards> object.
 339
 340 =head2 C<< capture [ $captures E<verbar> set => $c1, add => $c2, rem => $c3 ] >>
 341
 342 Specifies the list of atoms to capture.
 343 This method works like L</do>, except that the classes are different :
 344
 345 =over 4
 346
 347 =item *
 348
 349 C<'single'> will capture all unescaped I<"exactly one"> metacharacters, i.e. C<?> for wildcards or C<_> for SQL ;
 350
 351     'a???b\\??' ==> 'a(.)(.)(.)b\\?(.)'
 352     'a___b\\__' ==> 'a(.)(.)(.)b\\_(.)'
 353
 354 =item *
 355
 356 C<'any'> will capture all unescaped I<"any"> metacharacters, i.e. C<*> for wildcards or C<%> for SQL ;
 357
 358     'a***b\\**' ==> 'a(.*)b\\*(.*)'
 359     'a%%%b\\%%' ==> 'a(.*)b\\%(.*)'
 360
 361 =item *
 362
 363 C<'greedy'>, when used in conjunction with C<'any'>, will make the C<'any'> captures greedy (by default they are not) ;
 364
 365     'a***b\\**' ==> 'a(.*?)b\\*(.*?)'
 366     'a%%%b\\%%' ==> 'a(.*?)b\\%(.*?)'
 367
 368 =item *
 369
 370 C<'brackets'> will capture matching C<{ ... , ... }> alternations.
 371
 372     'a{b\\},\\{c}' ==> 'a(b\\}|\\{c)'
 373
 374 =back
 375
 376     $rw->capture(set => 'single');           # Only capture "exactly one" metacharacters.
 377     $rw->capture('single');                  # Same.
 378     $rw->capture(add => [ qw/any greedy/ ]); # Also greedily capture "any" metacharacters.
 379     $rw->capture(rem => 'greedy');           # No more greed please.
 380     $rw->capture();                          # Capture nothing.
 381
 382 =head2 C<convert $wc [ , $type ]>
 383
 384 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>.
 385
 386 =cut
 387
 388 sub convert {
 389  my ($self, $wc, $type) = @_;
 390  _check_self $self;
 391  my $config;
 392  if (defined $type) {
 393   $config = $self->_type($type);
 394  } else {
 395   $config = $self;
 396  }
 397  return unless defined $wc;
 398  my $do = $config->{do};
 399  my $e  = $config->{escape};
 400  $wc =~ s/(?<!\\)((?:\\\\)*[^\w\s\\$e])/\\$1/g;
 401  if ($do->{jokers}) {
 402   $wc = $self->_jokers($wc);
 403  } elsif ($do->{sql}) {
 404   $wc = $self->_sql($wc);
 405  }
 406  if ($do->{brackets}) {
 407   $wc = $self->_bracketed($wc);
 408  } elsif ($do->{commas}) {
 409   if ($wc =~ /(?<!\\)(?:\\\\)*,/) { # win32 allows comma-separated lists
 410    $wc = $self->{'c_brackets'} . $self->_commas($wc) . ')';
 411   }
 412  }
 413  return $wc;
 414 }
 415
 416 =head1 EXPORT
 417
 418 An object module shouldn't export any function, and so does this one.
 419
 420 =head1 DEPENDENCIES
 421
 422 L<Carp> (core module since perl 5), L<Text::Balanced> (since 5.7.3).
 423
 424 =head1 CAVEATS
 425
 426 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.
 427
 428 =head1 SEE ALSO
 429
 430 L<Text::Glob>.
 431
 432 =head1 AUTHOR
 433
 434 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 435
 436 You can contact me by mail or on C<irc.perl.org> (vincent).
 437
 438 =head1 BUGS
 439
 440 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.
 441
 442 =head1 SUPPORT
 443
 444 You can find documentation for this module with the perldoc command.
 445
 446     perldoc Regexp::Wildcards
 447
 448 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Regexp-Wildcards>.
 449
 450 =head1 COPYRIGHT & LICENSE
 451
 452 Copyright 2007-2008 Vincent Pit, all rights reserved.
 453
 454 This program is free software; you can redistribute it and/or modify it
 455 under the same terms as Perl itself.
 456
 457 =cut
 458
 459 sub _extract ($) { extract_bracketed $_[0], '{',  qr/.*?(?<!\\)(?:\\\\)*(?={)/ }
 460
 461 sub _jokers {
 462  my $self = shift;
 463  local $_ = $_[0];
 464  # escape an odd number of \ that doesn't protect a regexp/wildcard special char
 465  s/(?<!\\)((?:\\\\)*\\(?:[\w\s]|$))/\\$1/g;
 466  # substitute ? preceded by an even number of \
 467  my $s = $self->{c_single};
 468  s/(?<!\\)((?:\\\\)*)\?/$1$s/g;
 469  # substitute * preceded by an even number of \
 470  $s = $self->{c_any};
 471  s/(?<!\\)((?:\\\\)*)\*+/$1$s/g;
 472  return $_;
 473 }
 474
 475 sub _sql {
 476  my $self = shift;
 477  local $_ = $_[0];
 478  # escape an odd number of \ that doesn't protect a regexp/wildcard special char
 479  s/(?<!\\)((?:\\\\)*\\(?:[^\W_]|\s|$))/\\$1/g;
 480  # substitute _ preceded by an even number of \
 481  my $s = $self->{c_single};
 482  s/(?<!\\)((?:\\\\)*)_/$1$s/g;
 483  # substitute % preceded by an even number of \
 484  $s = $self->{c_any};
 485  s/(?<!\\)((?:\\\\)*)%+/$1$s/g;
 486  return $_;
 487 }
 488
 489 sub _commas {
 490  local $_ = $_[1];
 491  # substitute , preceded by an even number of \
 492  s/(?<!\\)((?:\\\\)*),/$1|/g;
 493  return $_;
 494 }
 495
 496 sub _brackets {
 497  my ($self, $rest) = @_;
 498  substr $rest, 0, 1, '';
 499  chop $rest;
 500  my ($re, $bracket, $prefix) = ('');
 501  while (do { ($bracket, $rest, $prefix) = _extract $rest; $bracket }) {
 502   $re .= $self->_commas($prefix) . $self->_brackets($bracket);
 503  }
 504  $re .= $self->_commas($rest);
 505  return $self->{c_brackets} . $re . ')';
 506 }
 507
 508 sub _bracketed {
 509  my ($self, $rest) = @_;
 510  my ($re, $bracket, $prefix) = ('');
 511  while (do { ($bracket, $rest, $prefix) = _extract $rest; $bracket }) {
 512   $re .= $prefix . $self->_brackets($bracket);
 513  }
 514  $re .= $rest;
 515  $re =~ s/(?<!\\)((?:\\\\)*[\{\},])/\\$1/g;
 516  return $re;
 517 }
 518
 519 1; # End of Regexp::Wildcards