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     my $callpkg = caller(0);
 134     my $sym = shift;
 135     *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym}
 136         if defined($sym) and $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     @perlfiles = glob  "..\\pe?l/*.p?";
 155     print <..\\pe?l/*.p?>;
 156
 157     # from the command line (overrides only in main::)
 158     > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
 159
 160 =head1 DESCRIPTION
 161
 162 A module that implements DOS-like globbing with a few enhancements.
 163 It is largely compatible with perlglob.exe (the M$ setargv.obj
 164 version) in all but one respect--it understands wildcards in
 165 directory components.
 166
 167 For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
 168 that it will find something like '..\lib\File/DosGlob.pm' alright).
 169 Note that all path components are case-insensitive, and that
 170 backslashes and forward slashes are both accepted, and preserved.
 171 You may have to double the backslashes if you are putting them in
 172 literally, due to double-quotish parsing of the pattern by perl.
 173
 174 Extending it to csh patterns is left as an exercise to the reader.
 175
 176 =head1 EXPORTS (by request only)
 177
 178 glob()
 179
 180 =head1 BUGS
 181
 182 Should probably be built into the core, and needs to stop
 183 pandering to DOS habits.  Needs a dose of optimizium too.
 184
 185 =head1 AUTHOR
 186
 187 Gurusamy Sarathy <gsar@umich.edu>
 188
 189 =head1 HISTORY
 190
 191 =over 4
 192
 193 =item *
 194
 195 Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
 196
 197 =item *
 198
 199 A few dir-vs-file optimizations result in glob importation being
 200 10 times faster than using perlglob.exe, and using perlglob.bat is
 201 only twice as slow as perlglob.exe (GSAR 28-MAY-97)
 202
 203 =item *
 204
 205 Several cleanups prompted by lack of compatible perlglob.exe
 206 under Borland (GSAR 27-MAY-97)
 207
 208 =item *
 209
 210 Initial version (GSAR 20-FEB-97)
 211
 212 =back
 213
 214 =head1 SEE ALSO
 215
 216 perl
 217
 218 perlglob.bat
 219
 220 =cut
 221