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.04
  17
  18 =cut
  19
  20 use vars qw<$VERSION>;
  21 BEGIN {
  22  $VERSION = '1.04';
  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
 123   my $cb = {
 124    ''      => sub { +{ ($_[0] => 1) x (exists $valid->{$_[0]}) } },
 125    'ARRAY' => sub { +{ map { ($_ => 1) x (exists $valid->{$_}) } @{$_[0]} } },
 126    'HASH'  => sub { +{ map { ($_ => $_[0]->{$_}) x (exists $valid->{$_}) }
 127                         keys %{$_[0]} } }
 128   }->{ ref $opt };
 129   croak 'Wrong option set' unless $cb;
 130   $checked{$_} = $cb->($opt);
 131  }
 132
 133  my $config = (exists $checked{set}) ? $checked{set} : $old;
 134  $config->{$_} = $checked{add}->{$_} for grep $checked{add}->{$_},
 135                                           keys %{$checked{add} || {}};
 136  delete $config->{$_}                for grep $checked{rem}->{$_},
 137                                           keys %{$checked{rem} || {}};
 138
 139  $config;
 140 }
 141
 142 sub _do {
 143  my $self = shift;
 144
 145  my $config;
 146  $config->{do}      = $self->_validate(\%escapes, $self->{do}, @_);
 147  $config->{escape}  = '';
 148  $config->{escape} .= $escapes{$_} for keys %{$config->{do}};
 149  $config->{escape}  = quotemeta $config->{escape};
 150
 151  $config;
 152 }
 153
 154 sub do {
 155  my $self = shift;
 156  _check_self $self;
 157
 158  my $config  = $self->_do(@_);
 159  $self->{$_} = $config->{$_} for keys %$config;
 160
 161  $self;
 162 }
 163
 164 sub _capture {
 165  my $self = shift;
 166
 167  my $config;
 168  $config->{capture} = $self->_validate(\%captures, $self->{capture}, @_);
 169  $config->{greedy}  = delete $config->{capture}->{greedy};
 170  for (keys %captures) {
 171   $config->{'c_' . $_} = $captures{$_}->($config, $config->{capture}->{$_})
 172                                                if $captures{$_}; # Skip 'greedy'
 173  }
 174
 175  $config;
 176 }
 177
 178 sub capture {
 179  my $self = shift;
 180  _check_self $self;
 181
 182  my $config  = $self->_capture(@_);
 183  $self->{$_} = $config->{$_} for keys %$config;
 184
 185  $self;
 186 }
 187
 188 sub _type {
 189  my ($self, $type) = @_;
 190  $type = 'unix'     unless defined $type;
 191  croak 'Wrong type' unless exists $types{$type};
 192
 193  my $config      = $self->_do($types{$type});
 194  $config->{type} = $type;
 195
 196  $config;
 197 }
 198
 199 sub type {
 200  my $self = shift;
 201  _check_self $self;
 202
 203  my $config  = $self->_type(@_);
 204  $self->{$_} = $config->{$_} for keys %$config;
 205
 206  $self;
 207 }
 208
 209 sub new {
 210  my $class = shift;
 211  $class    = blessed($class) || $class || __PACKAGE__;
 212
 213  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
 214  my %args = @_;
 215
 216  my $self = bless { }, $class;
 217
 218  if (defined $args{do}) {
 219   $self->do($args{do});
 220  } else {
 221   $self->type($args{type});
 222  }
 223
 224  $self->capture($args{capture});
 225 }
 226
 227 =head2 C<new>
 228
 229     my $rw = Regexp::Wildcards->new(do => $what, capture => $capture);
 230     my $rw = Regexp::Wildcards->new(type => $type, capture => $capture);
 231
 232 Constructs a new L<Regexp::Wildcard> object.
 233
 234 C<do> lists all features that should be enabled when converting wildcards to regexps.
 235 Refer to L</do> for details on what can be passed in C<$what>.
 236
 237 The C<type> specifies a predefined set of C<do> features to use.
 238 See L</type> for details on which types are valid.
 239 The C<do> option overrides C<type>.
 240
 241 C<capture> lists which atoms should be capturing.
 242 Refer to L</capture> for more details.
 243
 244 =head2 C<do>
 245
 246     $rw->do($what);
 247     $rw->do(set => $c1);
 248     $rw->do(add => $c2);
 249     $rw->do(rem => $c3);
 250
 251 Specifies the list of metacharacters to convert or to prevent for escaping.
 252 They fit into six classes :
 253
 254 =over 4
 255
 256 =item *
 257
 258 C<'jokers'>
 259
 260 Converts C<?> to C<.> and C<*> to C<.*>.
 261
 262     'a**\\*b??\\?c' ==> 'a.*\\*b..\\?c'
 263
 264 =item *
 265
 266 C<'sql'>
 267
 268 Converts C<_> to C<.> and C<%> to C<.*>.
 269
 270     'a%%\\%b__\\_c' ==> 'a.*\\%b..\\_c'
 271
 272 =item *
 273
 274 C<'commas'>
 275
 276 Converts all C<,> to C<|> and puts the complete resulting regular expression inside C<(?: ... )>.
 277
 278     'a,b{c,d},e' ==> '(?:a|b\\{c|d\\}|e)'
 279
 280 =item *
 281
 282 C<'brackets'>
 283
 284 Converts all matching C<{ ... ,  ... }> brackets to C<(?: ... | ... )> alternations.
 285 If some brackets are unbalanced, it tries to substitute as many of them as possible, and then escape the remaining unmatched C<{> and C<}>.
 286 Commas outside of any bracket-delimited block are also escaped.
 287
 288     'a,b{c,d},e'    ==> 'a\\,b(?:c|d)\\,e'
 289     '{a\\{b,c}d,e}' ==> '(?:a\\{b|c)d\\,e\\}'
 290     '{a{b,c\\}d,e}' ==> '\\{a\\{b\\,c\\}d\\,e\\}'
 291
 292 =item *
 293
 294 C<'groups'>
 295
 296 Keeps the parenthesis C<( ... )> of the original string without escaping them.
 297 Currently, no check is done to ensure that the parenthesis are matching.
 298
 299     'a(b(c))d\\(\\)' ==> (no change)
 300
 301 =item *
 302
 303 C<'anchors'>
 304
 305 Prevents the I<beginning-of-line> C<^> and I<end-of-line> C<$> anchors to be escaped.
 306 Since C<[...]> character class are currently escaped, a C<^> will always be interpreted as I<beginning-of-line>.
 307
 308     'a^b$c' ==> (no change)
 309
 310 =back
 311
 312 Each C<$c> can be any of :
 313
 314 =over 4
 315
 316 =item *
 317
 318 A hash reference, with wanted metacharacter group names (described above) as keys and booleans as values ;
 319
 320 =item *
 321
 322 An array reference containing the list of wanted metacharacter classes ;
 323
 324 =item *
 325
 326 A plain scalar, when only one group is required.
 327
 328 =back
 329
 330 When C<set> is present, the classes given as its value replace the current object options.
 331 Then the C<add> classes are added, and the C<rem> classes removed.
 332
 333 Passing a sole scalar C<$what> is equivalent as passing C<< set => $what >>.
 334 No argument means C<< set => [ ] >>.
 335
 336     $rw->do(set => 'jokers');           # Only translate jokers.
 337     $rw->do('jokers');                  # Same.
 338     $rw->do(add => [ qw<sql commas> ]); # Translate also SQL and commas.
 339     $rw->do(rem => 'jokers');           # Specifying both 'sql' and 'jokers' is useless.
 340     $rw->do();                          # Translate nothing.
 341
 342 The C<do> method returns the L<Regexp::Wildcards> object.
 343
 344 =head2 C<type>
 345
 346     $rw->type($type);
 347
 348 Notifies to convert the metacharacters that corresponds to the predefined type C<$type>.
 349 C<$type> can be any of :
 350
 351 =over 4
 352
 353 =item *
 354
 355 C<'jokers'>, C<'sql'>, C<'commas'>, C<'brackets'>
 356
 357 Singleton types that enable the corresponding C<do> classes.
 358
 359 =item *
 360
 361 C<'unix'>
 362
 363 Covers typical Unix shell globbing features (effectively C<'jokers'> and C<'brackets'>).
 364
 365 =item *
 366
 367 C<$^O> values for common Unix systems
 368
 369 Wrap to C<'unix'> (see L<perlport> for the list).
 370
 371 =item *
 372
 373 C<undef>
 374
 375 Defaults to C<'unix'>.
 376
 377 =item *
 378
 379 C<'win32'>
 380
 381 Covers typical Windows shell globbing features (effectively C<'jokers'> and C<'commas'>).
 382
 383 =item *
 384
 385 C<'dos'>, C<'os2'>, C<'MSWin32'>, C<'cygwin'>
 386
 387 Wrap to C<'win32'>.
 388
 389 =back
 390
 391 In particular, you can usually pass C<$^O> as the C<$type> and get the corresponding shell behaviour.
 392
 393     $rw->type('win32'); # Set type to win32.
 394     $rw->type($^O);     # Set type to unix on Unices and win32 on Windows
 395     $rw->type();        # Set type to unix.
 396
 397 The C<type> method returns the L<Regexp::Wildcards> object.
 398
 399 =head2 C<capture>
 400
 401     $rw->capture($captures);
 402     $rw->capture(set => $c1);
 403     $rw->capture(add => $c2);
 404     $rw->capture(rem => $c3);
 405
 406 Specifies the list of atoms to capture.
 407 This method works like L</do>, except that the classes are different :
 408
 409 =over 4
 410
 411 =item *
 412
 413 C<'single'>
 414
 415 Captures all unescaped I<"exactly one"> metacharacters, i.e. C<?> for wildcards or C<_> for SQL.
 416
 417     'a???b\\??' ==> 'a(.)(.)(.)b\\?(.)'
 418     'a___b\\__' ==> 'a(.)(.)(.)b\\_(.)'
 419
 420 =item *
 421
 422 C<'any'>
 423
 424 Captures all unescaped I<"any"> metacharacters, i.e. C<*> for wildcards or C<%> for SQL.
 425
 426     'a***b\\**' ==> 'a(.*)b\\*(.*)'
 427     'a%%%b\\%%' ==> 'a(.*)b\\%(.*)'
 428
 429 =item *
 430
 431 C<'greedy'>
 432
 433 When used in conjunction with C<'any'>, it makes the C<'any'> captures greedy (by default they are not).
 434
 435     'a***b\\**' ==> 'a(.*?)b\\*(.*?)'
 436     'a%%%b\\%%' ==> 'a(.*?)b\\%(.*?)'
 437
 438 =item *
 439
 440 C<'brackets'>
 441
 442 Capture matching C<{ ... , ... }> alternations.
 443
 444     'a{b\\},\\{c}' ==> 'a(b\\}|\\{c)'
 445
 446 =back
 447
 448     $rw->capture(set => 'single');           # Only capture "exactly one" metacharacters.
 449     $rw->capture('single');                  # Same.
 450     $rw->capture(add => [ qw<any greedy> ]); # Also greedily capture "any" metacharacters.
 451     $rw->capture(rem => 'greedy');           # No more greed please.
 452     $rw->capture();                          # Capture nothing.
 453
 454 The C<capture> method returns the L<Regexp::Wildcards> object.
 455
 456 =head2 C<convert>
 457
 458     my $rx = $rw->convert($wc);
 459     my $rx = $rw->convert($wc, $type);
 460
 461 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.
 462 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>.
 463
 464 =cut
 465
 466 sub convert {
 467  my ($self, $wc, $type) = @_;
 468  _check_self $self;
 469
 470  my $config = (defined $type) ? $self->_type($type) : $self;
 471  return unless defined $wc;
 472
 473  my $e = $config->{escape};
 474  # Escape :
 475  # - an even number of \ that doesn't protect a regexp/wildcard metachar
 476  # - an odd number of \ that doesn't protect a wildcard metachar
 477  $wc =~ s/
 478   (?<!\\)(
 479    (?:\\\\)*
 480    (?:
 481      [^\w\s\\$e]
 482     |
 483      \\
 484      (?: [^\W$e] | \s | $ )
 485    )
 486   )
 487  /\\$1/gx;
 488
 489  my $do = $config->{do};
 490  $wc = $self->_jokers($wc) if $do->{jokers};
 491  $wc = $self->_sql($wc)    if $do->{sql};
 492  if ($do->{brackets}) {
 493   $wc = $self->_bracketed($wc);
 494  } elsif ($do->{commas} and $wc =~ /(?<!\\)(?:\\\\)*,/) {
 495   $wc = $self->{'c_brackets'} . $self->_commas($wc) . ')';
 496  }
 497
 498  $wc
 499 }
 500
 501 =head1 EXPORT
 502
 503 An object module shouldn't export any function, and so does this one.
 504
 505 =head1 DEPENDENCIES
 506
 507 L<Carp> (core module since perl 5), L<Scalar::Util>, L<Text::Balanced> (since 5.7.3).
 508
 509 =head1 CAVEATS
 510
 511 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).
 512 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.
 513
 514 =head1 SEE ALSO
 515
 516 L<Text::Glob>.
 517
 518 =head1 AUTHOR
 519
 520 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 521
 522 You can contact me by mail or on C<irc.perl.org> (vincent).
 523
 524 =head1 BUGS
 525
 526 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.
 527
 528 =head1 SUPPORT
 529
 530 You can find documentation for this module with the perldoc command.
 531
 532     perldoc Regexp::Wildcards
 533
 534 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Regexp-Wildcards>.
 535
 536 =head1 COPYRIGHT & LICENSE
 537
 538 Copyright 2007-2009 Vincent Pit, all rights reserved.
 539
 540 This program is free software; you can redistribute it and/or modify it
 541 under the same terms as Perl itself.
 542
 543 =cut
 544
 545 sub _extract ($) { extract_bracketed $_[0], '{',  qr/.*?(?<!\\)(?:\\\\)*(?={)/ }
 546
 547 sub _jokers {
 548  my $self = shift;
 549  local $_ = $_[0];
 550
 551  # substitute ? preceded by an even number of \
 552  my $s = $self->{c_single};
 553  s/(?<!\\)((?:\\\\)*)\?/$1$s/g;
 554  # substitute * preceded by an even number of \
 555  $s = $self->{c_any};
 556  s/(?<!\\)((?:\\\\)*)\*+/$1$s/g;
 557
 558  $_
 559 }
 560
 561 sub _sql {
 562  my $self = shift;
 563  local $_ = $_[0];
 564
 565  # substitute _ preceded by an even number of \
 566  my $s = $self->{c_single};
 567  s/(?<!\\)((?:\\\\)*)_/$1$s/g;
 568  # substitute % preceded by an even number of \
 569  $s = $self->{c_any};
 570  s/(?<!\\)((?:\\\\)*)%+/$1$s/g;
 571
 572  $_
 573 }
 574
 575 sub _commas {
 576  local $_ = $_[1];
 577
 578  # substitute , preceded by an even number of \
 579  s/(?<!\\)((?:\\\\)*),/$1|/g;
 580
 581  $_
 582 }
 583
 584 sub _brackets {
 585  my ($self, $rest) = @_;
 586
 587  substr $rest, 0, 1, '';
 588  chop $rest;
 589
 590  my ($re, $bracket, $prefix) = ('');
 591  while (do { ($bracket, $rest, $prefix) = _extract $rest; $bracket }) {
 592   $re .= $self->_commas($prefix) . $self->_brackets($bracket);
 593  }
 594  $re .= $self->_commas($rest);
 595
 596  $self->{c_brackets} . $re . ')';
 597 }
 598
 599 sub _bracketed {
 600  my ($self, $rest) = @_;
 601
 602  my ($re, $bracket, $prefix) = ('');
 603  while (do { ($bracket, $rest, $prefix) = _extract $rest; $bracket }) {
 604   $re .= $prefix . $self->_brackets($bracket);
 605  }
 606  $re .= $rest;
 607
 608  $re =~ s/(?<!\\)((?:\\\\)*[\{\},])/\\$1/g;
 609
 610  $re;
 611 }
 612
 613 1; # End of Regexp::Wildcards