lib/File/DosGlob.pm

   1 #!perl -w
   2
   3 #
   4 # Documentation at the __END__
   5 #
   6
   7 package File::DosGlob;
   8
   9 unless (caller) {
  10     $| = 1;
  11     while (@ARGV) {
  12         #
  13         # We have to do this one by one for compatibility reasons.
  14         # If an arg doesn't match anything, we are supposed to return
  15         # the original arg.  I know, it stinks, eh?
  16         #
  17         my $arg = shift;
  18         my @m = doglob(1,$arg);
  19         print (@m ? join("\0", sort @m) : $arg);
  20         print "\0" if @ARGV;
  21     }
  22 }
  23
  24 sub doglob {
  25     my $cond = shift;
  26     my @retval = ();
  27     #print "doglob: ", join('|', @_), "\n";
  28   OUTER:
  29     for my $arg (@_) {
  30         local $_ = $arg;
  31         my @matched = ();
  32         my @globdirs = ();
  33         my $head = '.';
  34         my $sepchr = '/';
  35         next OUTER unless defined $_ and $_ ne '';
  36         # if arg is within quotes strip em and do no globbing
  37         if (/^"(.*)"$/) {
  38             $_ = $1;
  39             if ($cond eq 'd') { push(@retval, $_) if -d $_ }
  40             else              { push(@retval, $_) if -e $_ }
  41             next OUTER;
  42         }
  43         if (m|^(.*)([\\/])([^\\/]*)$|) {
  44             my $tail;
  45             ($head, $sepchr, $tail) = ($1,$2,$3);
  46             #print "div: |$head|$sepchr|$tail|\n";
  47             push (@retval, $_), next OUTER if $tail eq '';
  48             if ($head =~ /[*?]/) {
  49                 @globdirs = doglob('d', $head);
  50                 push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
  51                     next OUTER if @globdirs;
  52             }
  53             $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:$/;
  54             $_ = $tail;
  55         }
  56         #
  57         # If file component has no wildcards, we can avoid opendir
  58         unless (/[*?]/) {
  59             $head = '' if $head eq '.';
  60             $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
  61             $head .= $_;
  62             if ($cond eq 'd') { push(@retval,$head) if -d $head }
  63             else              { push(@retval,$head) if -e $head }
  64             next OUTER;
  65         }
  66         opendir(D, $head) or next OUTER;
  67         my @leaves = readdir D;
  68         closedir D;
  69         $head = '' if $head eq '.';
  70         $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
  71
  72         # escape regex metachars but not glob chars
  73         s:([].+^\-\${}[|]):\\$1:g;
  74         # and convert DOS-style wildcards to regex
  75         s/\*/.*/g;
  76         s/\?/.?/g;
  77
  78         #print "regex: '$_', head: '$head'\n";
  79         my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '$|io }';
  80         warn($@), next OUTER if $@;
  81       INNER:
  82         for my $e (@leaves) {
  83             next INNER if $e eq '.' or $e eq '..';
  84             next INNER if $cond eq 'd' and ! -d "$head$e";
  85             push(@matched, "$head$e"), next INNER if &$matchsub($e);
  86             #
  87             # [DOS compatibility special case]
  88             # Failed, add a trailing dot and try again, but only
  89             # if name does not have a dot in it *and* pattern
  90             # has a dot *and* name is shorter than 9 chars.
  91             #
  92             if (index($e,'.') == -1 and length($e) < 9
  93                 and index($_,'\\.') != -1) {
  94                 push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
  95             }
  96         }
  97         push @retval, @matched if @matched;
  98     }
  99     return @retval;
 100 }
 101
 102 #
 103 # this can be used to override CORE::glob in a specific
 104 # package by saying C<use File::DosGlob 'glob';> in that
 105 # namespace.
 106 #
 107
 108 # context (keyed by second cxix arg provided by core)
 109 my %iter;
 110 my %entries;
 111
 112 sub glob {
 113     my $pat = shift;
 114     my $cxix = shift;
 115
 116     # glob without args defaults to $_
 117     $pat = $_ unless defined $pat;
 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     my $callpkg = caller(0);
 149     my $sym = shift;
 150     *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym}
 151         if defined($sym) and $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 perlglob.bat - a more capable perlglob.exe replacement
 163
 164 =head1 SYNOPSIS
 165
 166     require 5.004;
 167
 168     # override CORE::glob in current package
 169     use File::DosGlob 'glob';
 170
 171     @perlfiles = glob  "..\\pe?l/*.p?";
 172     print <..\\pe?l/*.p?>;
 173
 174     # from the command line (overrides only in main::)
 175     > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
 176
 177     > perlglob ../pe*/*p?
 178
 179 =head1 DESCRIPTION
 180
 181 A module that implements DOS-like globbing with a few enhancements.
 182 This file is also a portable replacement for perlglob.exe.  It
 183 is largely compatible with perlglob.exe (the M$ setargv.obj
 184 version) in all but one respect--it understands wildcards in
 185 directory components.
 186
 187 For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
 188 that it will find something like '..\lib\File/DosGlob.pm' alright).
 189 Note that all path components are case-insensitive, and that
 190 backslashes and forward slashes are both accepted, and preserved.
 191 You may have to double the backslashes if you are putting them in
 192 literally, due to double-quotish parsing of the pattern by perl.
 193
 194 When invoked as a program, it will print null-separated filenames
 195 to standard output.
 196
 197 While one may replace perlglob.exe with this, usage by overriding
 198 CORE::glob via importation should be much more efficient, because
 199 it avoids launching a separate process, and is therefore strongly
 200 recommended.  Note that it is currently possible to override
 201 builtins like glob() only on a per-package basis, not "globally".
 202 Thus, every namespace that wants to override glob() must explicitly
 203 request the override.  See L<perlsub>.
 204
 205 Extending it to csh patterns is left as an exercise to the reader.
 206
 207 =head1 EXPORTS (by request only)
 208
 209 glob()
 210
 211 =head1 BUGS
 212
 213 Should probably be built into the core, and needs to stop
 214 pandering to DOS habits.  Needs a dose of optimizium too.
 215
 216 =head1 AUTHOR
 217
 218 Gurusamy Sarathy <gsar@umich.edu>
 219
 220 =head1 HISTORY
 221
 222 =over 4
 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 =cut
 250