File Coverage

blib/lib/Regexp/Shellish.pm

Criterion	Covered	Total	%
statement	42	42	100.0
branch	31	34	91.1
condition	35	39	89.7
subroutine	6	6	100.0
pod	2	2	100.0
total	116	123	94.3

package Regexp::Shellish ;

#
# Copyright 1999, Barrie Slaymaker
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the README file.
#

=head1 NAME

Regexp::Shellish - Shell-like regular expressions

=head1 SYNOPSIS

   use Regexp::Shellish qw( :all ) ;

   $re = compile_shellish( 'a/c*d' ) ;

   ## This next one's like 'a*d' except that it'll
   ## match 'a/d'.
   $re = compile_shellish( 'a**d' ) ;

   ## And here '**' won't match 'a/d', but behaves
   ## like 'a*d', except for the possibility of high
   ## cpu time consumption.
   $re = compile_shellish( 'a**d', { star_star => 0 } ) ;

   ## The next two result in identical $re1 and $re2.
   ## The second is a noop so that Regexp references can
   ## be easily accomodated.
   $re1 = compile_shellish( 'a{b,c}d' ) ;
   $re2 = compile_shellish( qr/\A(?:a(?:b|c)d)\Z/ ) ;

   @matches = shellish_glob( $re, @possibilities ) ;


=head1 DESCRIPTION

Provides shell-like regular expressions.  The wildcards provided
are C, C<*> and C<**>, where C<**> is like C<*> but matches C.  See
L for details.

Case sensitivity and constructs like <**>, C<(a*b)>, and C<{a,b,c}>
can be disabled.

=over

=cut

use strict ;

use Carp ;
use Exporter ;

use vars qw( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS ) ;

$VERSION = '0.93' ;

@ISA = qw( Exporter ) ;

@EXPORT_OK = qw(
   compile_shellish
   shellish_glob
) ;

%EXPORT_TAGS = ( 'all' => \@EXPORT_OK ) ;

=item compile_shellish

Compiles a string containing a 'shellish' regular expression, returning a
Regexp reference.  Regexp references passed in are passed through
unmolested.

Here are the transformation rules from shellish expression terms to
perl regular expression terms:

   Shellish  Perl RE
   ========  =======
   *         [^/]*
   ?         .
   **        .*               ## unless { star_star   => 0 }
   ...       .*               ## unless { dot_dot_dot => 0 }

   (         (                ## unless { parens => 0 }
   )         )                ## unless { parens => 0 }

   {a,b,c}   (?:a|b|c)        ## unless { braces => 0 }

   \a        a                ## These are de-escaped and
   \*        \*               ## passed to quotemeta()

The wildcards treat newlines as normal characters.

Parens group in to $1..$n, since they are passed through unmolested
(unless option parens => 0 is passed).  This is useless when using
glob_shellish(), though.

The final parameter can be a hash reference containing options:

   compile_shellish(
      '**',
      {
         anchors        => 0,   ## Doesn't put ^ and $ around the
	                        ## resulting regexp
         case_sensitive => 0,   ## Make case insensitive
         dot_dot_dot    => 0,   ## '...' is now just three '.' chars
         star_star      => 0,   ## '**' is now two '*' wildcards
	 parens         => 0,   ## '(', ')' are now regular chars
	 braces         => 0,   ## '{', '}' are now regular chars
      }
   ) ;

No option affects Regexps passed through.

=cut

sub compile_shellish {
   my $o = @_ && ref $_[-1] eq 'HASH' ? pop : {} ;
   my $re = shift ;

   return $re if ref $re eq 'Regexp' ;

   my $star_star = ( ! exists $o->{star_star} || $o->{star_star} )
      ? '.*'
      : '[^/]*[^/]*' ;

   my $dot_dot_dot = ( ! exists $o->{dot_dot_dot} || $o->{dot_dot_dot} )
      ? '.*'
      : '\.\.\.' ;

   my $case = ( ! exists $o->{case_sensitive} || $o->{case_sensitive} )
      ? ''
      : 'i' ;

   my $anchors     = ( ! exists $o->{anchors} || $o->{anchors} ) ;
   my $pass_parens = ( ! exists $o->{parens}  || $o->{parens} ) ;
   my $pass_braces = ( ! exists $o->{braces}  || $o->{braces} ) ;

   my $brace_depth = 0 ;

   my $orig = $re ;

   $re =~ s@
      (  \\.
      |  \*\*
      |  \.\.\.
      |  .
      )
   @
      if ( $1 eq '?' ) {
	 '[^/]' ;
      }
      elsif ( $1 eq '*' ) {
	 '[^/]*' ;
      }
      elsif ( $1 eq '**' ) {
	 $star_star ;
      }
      elsif ( $1 eq '...' ) {
	 $dot_dot_dot;
      }
      elsif ( $pass_braces && $1 eq '{' ) {
	 ++$brace_depth ;
         '(?:' ;
      }
      elsif ( $pass_braces && $1 eq '}' ) {
	 croak "Unmatched '}' in '$orig'" unless $brace_depth-- ;
         ')' ;
      }
      elsif ( $pass_braces && $brace_depth && $1 eq ',' ) {
         '|' ;
      }
      elsif ( $pass_parens && index( '()', $1 ) >= 0 ) {
         $1 ;
      }
      else {
	 quotemeta(substr( $1, -1 ) );
      }
   @gexs ;

   croak "Unmatched '{' in '$orig'" if $brace_depth ;

   return $anchors ? qr/\A(?$case:$re)\Z/s : qr/(?$case:$re)/s ;
}


=item shellish_glob

Pass a regular expression and a list of possible values, get back a list of
matching values.

   my @matches = shellish_glob( '*/*', @possibilities ) ;
   my @matches = shellish_glob( '*/*', @possibilities, \%options ) ;

=cut

sub shellish_glob {
   my $o = @_ > 1 && ref $_[-1] eq 'HASH' ? pop : {} ;
   my $re = compile_shellish( shift, $o ) ;
   return grep { m/$re/ } @_ ;
}

=back

=head1 AUTHOR

Barrie Slaymaker

=cut


1 ;