lib/Regexp/Wildcards.pm

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