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