contrib/perl5/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     my @pat;
 101
 102     # glob without args defaults to $_
 103     $pat = $_ unless defined $pat;
 104
 105     # extract patterns
 106     if ($pat =~ /\s/) {
 107         require Text::ParseWords;
 108         @pat = Text::ParseWords::parse_line('\s+',0,$pat);
 109     }
 110     else {
 111         push @pat, $pat;
 112     }
 113
 114     # assume global context if not provided one
 115     $cxix = '_G_' unless defined $cxix;
 116     $iter{$cxix} = 0 unless exists $iter{$cxix};
 117
 118     # if we're just beginning, do it all first
 119     if ($iter{$cxix} == 0) {
 120         $entries{$cxix} = [doglob(1,@pat)];
 121     }
 122
 123     # chuck it all out, quick or slow
 124     if (wantarray) {
 125         delete $iter{$cxix};
 126         return @{delete $entries{$cxix}};
 127     }
 128     else {
 129         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
 130             return shift @{$entries{$cxix}};
 131         }
 132         else {
 133             # return undef for EOL
 134             delete $iter{$cxix};
 135             delete $entries{$cxix};
 136             return undef;
 137         }
 138     }
 139 }
 140
 141 sub import {
 142     my $pkg = shift;
 143     return unless @_;
 144     my $sym = shift;
 145     my $callpkg = ($sym =~ s/^GLOBAL_// ? 'CORE::GLOBAL' : caller(0));
 146     *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
 147 }
 148
 149 1;
 150
 151 __END__
 152
 153 =head1 NAME
 154
 155 File::DosGlob - DOS like globbing and then some
 156
 157 =head1 SYNOPSIS
 158
 159     require 5.004;
 160
 161     # override CORE::glob in current package
 162     use File::DosGlob 'glob';
 163
 164     # override CORE::glob in ALL packages (use with extreme caution!)
 165     use File::DosGlob 'GLOBAL_glob';
 166
 167     @perlfiles = glob  "..\\pe?l/*.p?";
 168     print <..\\pe?l/*.p?>;
 169
 170     # from the command line (overrides only in main::)
 171     > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
 172
 173 =head1 DESCRIPTION
 174
 175 A module that implements DOS-like globbing with a few enhancements.
 176 It is largely compatible with perlglob.exe (the M$ setargv.obj
 177 version) in all but one respect--it understands wildcards in
 178 directory components.
 179
 180 For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
 181 that it will find something like '..\lib\File/DosGlob.pm' alright).
 182 Note that all path components are case-insensitive, and that
 183 backslashes and forward slashes are both accepted, and preserved.
 184 You may have to double the backslashes if you are putting them in
 185 literally, due to double-quotish parsing of the pattern by perl.
 186
 187 Spaces in the argument delimit distinct patterns, so
 188 C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
 189 or C<.dll>.  If you want to put in literal spaces in the glob
 190 pattern, you can escape them with either double quotes, or backslashes.
 191 e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
 192 C<glob('c:/Program\ Files/*/*.dll')>.  The argument is tokenized using
 193 C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
 194 of the quoting rules used.
 195
 196 Extending it to csh patterns is left as an exercise to the reader.
 197
 198 =head1 EXPORTS (by request only)
 199
 200 glob()
 201
 202 =head1 BUGS
 203
 204 Should probably be built into the core, and needs to stop
 205 pandering to DOS habits.  Needs a dose of optimizium too.
 206
 207 =head1 AUTHOR
 208
 209 Gurusamy Sarathy <gsar@umich.edu>
 210
 211 =head1 HISTORY
 212
 213 =over 4
 214
 215 =item *
 216
 217 Support for globally overriding glob() (GSAR 3-JUN-98)
 218
 219 =item *
 220
 221 Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
 222
 223 =item *
 224
 225 A few dir-vs-file optimizations result in glob importation being
 226 10 times faster than using perlglob.exe, and using perlglob.bat is
 227 only twice as slow as perlglob.exe (GSAR 28-MAY-97)
 228
 229 =item *
 230
 231 Several cleanups prompted by lack of compatible perlglob.exe
 232 under Borland (GSAR 27-MAY-97)
 233
 234 =item *
 235
 236 Initial version (GSAR 20-FEB-97)
 237
 238 =back
 239
 240 =head1 SEE ALSO
 241
 242 perl
 243
 244 perlglob.bat
 245
 246 Text::ParseWords
 247
 248 =cut
 249