lib/File/DosGlob.pm

   1 #!perl -w
   2
   3 #
   4 # Documentation at the __END__
   5 #
   6
   7 package File::DosGlob;
   8
   9 our $VERSION = '1.00';
  10 use strict;
  11
  12 sub doglob {
  13     my $cond = shift;
  14     my @retval = ();
  15     #print "doglob: ", join('|', @_), "\n";
  16   OUTER:
  17     for my $pat (@_) {
  18         my @matched = ();
  19         my @globdirs = ();
  20         my $head = '.';
  21         my $sepchr = '/';
  22         my $tail;
  23         next OUTER unless defined $pat and $pat ne '';
  24         # if arg is within quotes strip em and do no globbing
  25         if ($pat =~ /^"(.*)"\z/s) {
  26             $pat = $1;
  27             if ($cond eq 'd') { push(@retval, $pat) if -d $pat }
  28             else              { push(@retval, $pat) if -e $pat }
  29             next OUTER;
  30         }
  31         # wildcards with a drive prefix such as h:*.pm must be changed
  32         # to h:./*.pm to expand correctly
  33         if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) {
  34             substr($_,0,2) = $1 . "./";
  35         }
  36         if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) {
  37             ($head, $sepchr, $tail) = ($1,$2,$3);
  38             #print "div: |$head|$sepchr|$tail|\n";
  39             push (@retval, $pat), next OUTER if $tail eq '';
  40             if ($head =~ /[*?]/) {
  41                 @globdirs = doglob('d', $head);
  42                 push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
  43                     next OUTER if @globdirs;
  44             }
  45             $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s;
  46             $pat = $tail;
  47         }
  48         #
  49         # If file component has no wildcards, we can avoid opendir
  50         unless ($pat =~ /[*?]/) {
  51             $head = '' if $head eq '.';
  52             $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
  53             $head .= $pat;
  54             if ($cond eq 'd') { push(@retval,$head) if -d $head }
  55             else              { push(@retval,$head) if -e $head }
  56             next OUTER;
  57         }
  58         opendir(D, $head) or next OUTER;
  59         my @leaves = readdir D;
  60         closedir D;
  61         $head = '' if $head eq '.';
  62         $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
  63
  64         # escape regex metachars but not glob chars
  65         $pat =~ s:([].+^\-\${}[|]):\\$1:g;
  66         # and convert DOS-style wildcards to regex
  67         $pat =~ s/\*/.*/g;
  68         $pat =~ s/\?/.?/g;
  69
  70         #print "regex: '$pat', head: '$head'\n";
  71         my $matchsub = sub { $_[0] =~ m|^$pat\z|is };
  72       INNER:
  73         for my $e (@leaves) {
  74             next INNER if $e eq '.' or $e eq '..';
  75             next INNER if $cond eq 'd' and ! -d "$head$e";
  76             push(@matched, "$head$e"), next INNER if &$matchsub($e);
  77             #
  78             # [DOS compatibility special case]
  79             # Failed, add a trailing dot and try again, but only
  80             # if name does not have a dot in it *and* pattern
  81             # has a dot *and* name is shorter than 9 chars.
  82             #
  83             if (index($e,'.') == -1 and length($e) < 9
  84                 and index($pat,'\\.') != -1) {
  85                 push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
  86             }
  87         }
  88         push @retval, @matched if @matched;
  89     }
  90     return @retval;
  91 }
  92
  93 #
  94 # this can be used to override CORE::glob in a specific
  95 # package by saying C<use File::DosGlob 'glob';> in that
  96 # namespace.
  97 #
  98
  99 # context (keyed by second cxix arg provided by core)
 100 my %iter;
 101 my %entries;
 102
 103 sub glob {
 104     my($pat,$cxix) = @_;
 105     my @pat;
 106
 107     # glob without args defaults to $_
 108     $pat = $_ unless defined $pat;
 109
 110     # extract patterns
 111     if ($pat =~ /\s/) {
 112         require Text::ParseWords;
 113         @pat = Text::ParseWords::parse_line('\s+',0,$pat);
 114     }
 115     else {
 116         push @pat, $pat;
 117     }
 118
 119     # assume global context if not provided one
 120     $cxix = '_G_' unless defined $cxix;
 121     $iter{$cxix} = 0 unless exists $iter{$cxix};
 122
 123     # if we're just beginning, do it all first
 124     if ($iter{$cxix} == 0) {
 125         $entries{$cxix} = [doglob(1,@pat)];
 126     }
 127
 128     # chuck it all out, quick or slow
 129     if (wantarray) {
 130         delete $iter{$cxix};
 131         return @{delete $entries{$cxix}};
 132     }
 133     else {
 134         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
 135             return shift @{$entries{$cxix}};
 136         }
 137         else {
 138             # return undef for EOL
 139             delete $iter{$cxix};
 140             delete $entries{$cxix};
 141             return undef;
 142         }
 143     }
 144 }
 145
 146 {
 147     no strict 'refs';
 148
 149     sub import {
 150     my $pkg = shift;
 151     return unless @_;
 152     my $sym = shift;
 153     my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
 154     *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
 155     }
 156 }
 157 1;
 158
 159 __END__
 160
 161 =head1 NAME
 162
 163 File::DosGlob - DOS like globbing and then some
 164
 165 =head1 SYNOPSIS
 166
 167     require 5.004;
 168
 169     # override CORE::glob in current package
 170     use File::DosGlob 'glob';
 171
 172     # override CORE::glob in ALL packages (use with extreme caution!)
 173     use File::DosGlob 'GLOBAL_glob';
 174
 175     @perlfiles = glob  "..\\pe?l/*.p?";
 176     print <..\\pe?l/*.p?>;
 177
 178     # from the command line (overrides only in main::)
 179     > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
 180
 181 =head1 DESCRIPTION
 182
 183 A module that implements DOS-like globbing with a few enhancements.
 184 It is largely compatible with perlglob.exe (the M$ setargv.obj
 185 version) in all but one respect--it understands wildcards in
 186 directory components.
 187
 188 For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
 189 that it will find something like '..\lib\File/DosGlob.pm' alright).
 190 Note that all path components are case-insensitive, and that
 191 backslashes and forward slashes are both accepted, and preserved.
 192 You may have to double the backslashes if you are putting them in
 193 literally, due to double-quotish parsing of the pattern by perl.
 194
 195 Spaces in the argument delimit distinct patterns, so
 196 C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
 197 or C<.dll>.  If you want to put in literal spaces in the glob
 198 pattern, you can escape them with either double quotes, or backslashes.
 199 e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
 200 C<glob('c:/Program\ Files/*/*.dll')>.  The argument is tokenized using
 201 C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
 202 of the quoting rules used.
 203
 204 Extending it to csh patterns is left as an exercise to the reader.
 205
 206 =head1 EXPORTS (by request only)
 207
 208 glob()
 209
 210 =head1 BUGS
 211
 212 Should probably be built into the core, and needs to stop
 213 pandering to DOS habits.  Needs a dose of optimizium too.
 214
 215 =head1 AUTHOR
 216
 217 Gurusamy Sarathy <gsar@activestate.com>
 218
 219 =head1 HISTORY
 220
 221 =over 4
 222
 223 =item *
 224
 225 Support for globally overriding glob() (GSAR 3-JUN-98)
 226
 227 =item *
 228
 229 Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
 230
 231 =item *
 232
 233 A few dir-vs-file optimizations result in glob importation being
 234 10 times faster than using perlglob.exe, and using perlglob.bat is
 235 only twice as slow as perlglob.exe (GSAR 28-MAY-97)
 236
 237 =item *
 238
 239 Several cleanups prompted by lack of compatible perlglob.exe
 240 under Borland (GSAR 27-MAY-97)
 241
 242 =item *
 243
 244 Initial version (GSAR 20-FEB-97)
 245
 246 =back
 247
 248 =head1 SEE ALSO
 249
 250 perl
 251
 252 perlglob.bat
 253
 254 Text::ParseWords
 255
 256 =cut
 257