lib/File/DosGlob.pm

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