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