1 # Copyright (C) 2002 Richard Clamp.  All Rights Reserved.

     2 #

     3 # This module is free software; you can redistribute it and/or modify it

     4 # under the same terms as Perl itself.

     5 

     6 package Text::Glob;

     7 use strict;

     8 use Exporter;

     9 use vars qw/$VERSION @ISA @EXPORT_OK

    10             $strict_leading_dot $strict_wildcard_slash/;

    11 $VERSION = '0.06';

    12 @ISA = 'Exporter';

    13 @EXPORT_OK = qw( glob_to_regex match_glob );

    14 

    15 $strict_leading_dot    = 1;

    16 $strict_wildcard_slash = 1;

    17 

    18 use constant debug => 0;

    19 

    20 sub glob_to_regex {

    21     my $glob = shift;

    22     my ($regex, $in_curlies, $escaping);

    23     local $_;

    24     my $first_byte = 1;

    25     for ($glob =~ m/(.)/gs) {

    26         if ($first_byte) {

    27             if ($strict_leading_dot) {

    28                 $regex .= '(?=[^\.])' unless $_ eq '.';

    29             }

    30             $first_byte = 0;

    31         }

    32         if ($_ eq '/') {

    33             $first_byte = 1;

    34         }

    35         if ($_ eq '.' || $_ eq '(' || $_ eq ')' || $_ eq '|' ||

    36             $_ eq '+' || $_ eq '^' || $_ eq '$' ) {

    37             $regex .= "\\$_";

    38         }

    39         elsif ($_ eq '*') {

    40             $regex .= $escaping ? "\\*" :

    41               $strict_wildcard_slash ? "[^/]*" : ".*";

    42         }

    43         elsif ($_ eq '?') {

    44             $regex .= $escaping ? "\\?" :

    45               $strict_wildcard_slash ? "[^/]" : ".";

    46         }

    47         elsif ($_ eq '{') {

    48             $regex .= $escaping ? "\\{" : "(";

    49             ++$in_curlies unless $escaping;

    50         }

    51         elsif ($_ eq '}' && $in_curlies) {

    52             $regex .= $escaping ? "}" : ")";

    53             --$in_curlies unless $escaping;

    54         }

    55         elsif ($_ eq ',' && $in_curlies) {

    56             $regex .= $escaping ? "," : "|";

    57         }

    58         elsif ($_ eq "\\") {

    59             if ($escaping) {

    60                 $regex .= "\\\\";

    61                 $escaping = 0;

    62             }

    63             else {

    64                 $escaping = 1;

    65             }

    66             next;

    67         }

    68         else {

    69             $regex .= $_;

    70             $escaping = 0;

    71         }

    72         $escaping = 0;

    73     }

    74     print "# $glob $regex\n" if debug;

    75     qr/^$regex$/;

    76 }

    77 

    78 sub match_glob {

    79     print "# ", join(', ', map { "'$_'" } @_), "\n" if debug;

    80     my $glob = shift;

    81     my $regex = glob_to_regex $glob;

    82     local $_;

    83     grep { $_ =~ $regex } @_;

    84 }

    85 

    86 1;

    87 __END__

    88 

    89 =head1 NAME

    90 

    91 Text::Glob - match globbing patterns against text

    92 

    93 =head1 SYNOPSIS

    94 

    95  use Text::Glob qw( match_glob glob_to_regex );

    96 

    97  print "matched\n" if match_glob( "foo.*", "foo.bar" );

    98 

    99  # prints foo.bar and foo.baz

   100  my $regex = glob_to_regex( "foo.*" );

   101  for ( qw( foo.bar foo.baz foo bar ) ) {

   102      print "matched: $_\n" if /$regex/;

   103  }

   104 

   105 =head1 DESCRIPTION

   106 

   107 Text::Glob implements glob(3) style matching that can be used to match

   108 against text, rather than fetching names from a filesystem.  If you

   109 want to do full file globbing use the File::Glob module instead.

   110 

   111 =head2 Routines

   112 

   113 =over

   114 

   115 =item match_glob( $glob, @things_to_test )

   116 

   117 Returns the list of things which match the glob from the source list.

   118 

   119 =item glob_to_regex( $glob )

   120 

   121 Returns a compiled regex which is the equiavlent of the globbing

   122 pattern.

   123 

   124 =back

   125 

   126 =head1 SYNTAX

   127 

   128 The following metacharacters and rules are respected.

   129 

   130 =over

   131 

   132 =item C<*> - match zero or more characters

   133 

   134 C<a*> matches C<a>, C<aa>, C<aaaa> and many many more.

   135 

   136 =item C<?> - match exactly one character

   137 

   138 C<a?> matches C<aa>, but not C<a>, or C<aa>

   139 

   140 =item Character sets/ranges

   141 

   142 C<example.[ch]> matches C<example.c> and C<example.h>

   143 

   144 C<demo.[a-c]> matches C<demo.a>, C<demo.b>, and C<demo.c>

   145 

   146 =item alternation

   147 

   148 C<example.{foo,bar,baz}> matches C<example.foo>, C<example.bar>, and

   149 C<example.baz>

   150 

   151 =item leading . must be explictly matched

   152 

   153 C<*.foo> does not match C<.bar.foo>.  For this you must either specify

   154 the leading . in the glob pattern (C<.*.foo>), or set

   155 C<$Text::Glob::strict_leading_dot> to a false value while compiling

   156 the regex.

   157 

   158 =item C<*> and C<?> do not match /

   159 

   160 C<*.foo> does not match C<bar/baz.foo>.  For this you must either

   161 explicitly match the / in the glob (C<*/*.foo>), or set

   162 C<$Text::Glob::strict_wildcard_slash> to a false value with compiling

   163 the regex.

   164 

   165 =back

   166 

   167 =head1 BUGS

   168 

   169 The code uses qr// to produce compiled regexes, therefore this module

   170 requires perl version 5.005_03 or newer.

   171 

   172 =head1 AUTHOR

   173 

   174 Richard Clamp <richardc@unixbeard.net>

   175 

   176 =head1 COPYRIGHT

   177 

   178 Copyright (C) 2002 Richard Clamp.  All Rights Reserved.

   179 

   180 This module is free software; you can redistribute it and/or modify it

   181 under the same terms as Perl itself.

   182 

   183 =head1 SEE ALSO

   184 

   185 L<File::Glob>, glob(3)

   186 

   187 =cut