lib/File/DosGlob.pm

   1 #!perl -w
   2
   3 # use strict fails
   4 #Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191.
   5
   6 #
   7 # Documentation at the __END__
   8 #
   9
  10 package File::DosGlob;
  11
  12 our $VERSION = '1.00';
  13 use strict;
  14 use warnings;
  15
  16 sub doglob {
  17     my $cond = shift;
  18     my @retval = ();
  19     #print "doglob: ", join('|', @_), "\n";
  20   OUTER:
  21     for my $pat (@_) {
  22         my @matched = ();
  23         my @globdirs = ();
  24         my $head = '.';
  25         my $sepchr = '/';
  26         my $tail;
  27         next OUTER unless defined $pat and $pat ne '';
  28         # if arg is within quotes strip em and do no globbing
  29         if ($pat =~ /^"(.*)"\z/s) {
  30             $pat = $1;
  31             if ($cond eq 'd') { push(@retval, $pat) if -d $pat }
  32             else              { push(@retval, $pat) if -e $pat }
  33             next OUTER;
  34         }
  35         # wildcards with a drive prefix such as h:*.pm must be changed
  36         # to h:./*.pm to expand correctly
  37         if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) {
  38             substr($_,0,2) = $1 . "./";
  39         }
  40         if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) {
  41             ($head, $sepchr, $tail) = ($1,$2,$3);
  42             #print "div: |$head|$sepchr|$tail|\n";
  43             push (@retval, $pat), next OUTER if $tail eq '';
  44             if ($head =~ /[*?]/) {
  45                 @globdirs = doglob('d', $head);
  46                 push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
  47                     next OUTER if @globdirs;
  48             }
  49             $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s;
  50             $pat = $tail;
  51         }
  52         #
  53         # If file component has no wildcards, we can avoid opendir
  54         unless ($pat =~ /[*?]/) {
  55             $head = '' if $head eq '.';
  56             $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
  57             $head .= $pat;
  58             if ($cond eq 'd') { push(@retval,$head) if -d $head }
  59             else              { push(@retval,$head) if -e $head }
  60             next OUTER;
  61         }
  62         opendir(D, $head) or next OUTER;
  63         my @leaves = readdir D;
  64         closedir D;
  65         $head = '' if $head eq '.';
  66         $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
  67
  68         # escape regex metachars but not glob chars
  69         $pat =~ s:([].+^\-\${}[|]):\\$1:g;
  70         # and convert DOS-style wildcards to regex
  71         $pat =~ s/\*/.*/g;
  72         $pat =~ s/\?/.?/g;
  73
  74         #print "regex: '$pat', head: '$head'\n";
  75         my $matchsub = sub { $_[0] =~ m|^$pat\z|is };
  76       INNER:
  77         for my $e (@leaves) {
  78             next INNER if $e eq '.' or $e eq '..';
  79             next INNER if $cond eq 'd' and ! -d "$head$e";
  80             push(@matched, "$head$e"), next INNER if &$matchsub($e);
  81             #
  82             # [DOS compatibility special case]
  83             # Failed, add a trailing dot and try again, but only
  84             # if name does not have a dot in it *and* pattern
  85             # has a dot *and* name is shorter than 9 chars.
  86             #
  87             if (index($e,'.') == -1 and length($e) < 9
  88                 and index($pat,'\\.') != -1) {
  89                 push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
  90             }
  91         }
  92         push @retval, @matched if @matched;
  93     }
  94     return @retval;
  95 }
  96
  97 #
  98 # this can be used to override CORE::glob in a specific
  99 # package by saying C<use File::DosGlob 'glob';> in that
 100 # namespace.
 101 #
 102
 103 # context (keyed by second cxix arg provided by core)
 104 my %iter;
 105 my %entries;
 106
 107 sub glob {
 108     my($pat,$cxix) = @_;
 109     my @pat;
 110
 111     # glob without args defaults to $_
 112     $pat = $_ unless defined $pat;
 113
 114     # extract patterns
 115     if ($pat =~ /\s/) {
 116         require Text::ParseWords;
 117         @pat = Text::ParseWords::parse_line('\s+',0,$pat);
 118     }
 119     else {
 120         push @pat, $pat;
 121     }
 122
 123     # Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3.
 124     #   abc3 will be the original {3} (and drop the {}).
 125     #   abc1 abc2 will be put in @appendpat.
 126     # This was just the esiest way, not nearly the best.
 127     REHASH: {
 128         my @appendpat = ();
 129         for (@pat) {
 130             # There must be a "," I.E. abc{efg} is not what we want.
 131             while ( /^(.*)(?<!\\)\{(.*?)(?<!\\)\,.*?(?<!\\)\}(.*)$/ ) {
 132                 my ($start, $match, $end) = ($1, $2, $3);
 133                 #print "Got: \n\t$start\n\t$match\n\t$end\n";
 134                 my $tmp = "$start$match$end";
 135                 while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) {
 136                     #print "Striped: $tmp\n";
 137                     #  these expanshions will be preformed by the original,
 138                     #  when we call REHASH.
 139                 }
 140                 push @appendpat, ("$tmp");
 141                 s/^\Q$start\E(?<!\\)\{\Q$match\E(?<!\\)\,/$start\{/;
 142                 if ( /^\Q$start\E(?<!\\)\{(?!.*?(?<!\\)\,.*?\Q$end\E$)(.*)(?<!\\)\}\Q$end\E$/ ) {
 143                     $match = $1;
 144                     #print "GOT: \n\t$start\n\t$match\n\t$end\n\n";
 145                     $_ = "$start$match$end";
 146                 }
 147             }
 148             #print "Sould have "GOT" vs "Got"!\n";
 149                 #FIXME: There should be checking for this.
 150                 #  How or what should be done about failure is beond me.
 151         }
 152         if ( $#appendpat != -1
 153                 ) {
 154             #print "LOOP\n";
 155             #FIXME: Max loop, no way! :")
 156             for ( @appendpat ) {
 157                 push @pat, $_;
 158             }
 159             goto REHASH;
 160         }
 161     }
 162     for ( @pat ) {
 163         s/\\{/{/g;
 164         s/\\}/}/g;
 165         s/\\,/,/g;
 166     }
 167     #print join ("\n", @pat). "\n";
 168
 169     # assume global context if not provided one
 170     $cxix = '_G_' unless defined $cxix;
 171     $iter{$cxix} = 0 unless exists $iter{$cxix};
 172
 173     # if we're just beginning, do it all first
 174     if ($iter{$cxix} == 0) {
 175         $entries{$cxix} = [doglob(1,@pat)];
 176     }
 177
 178     # chuck it all out, quick or slow
 179     if (wantarray) {
 180         delete $iter{$cxix};
 181         return @{delete $entries{$cxix}};
 182     }
 183     else {
 184         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
 185             return shift @{$entries{$cxix}};
 186         }
 187         else {
 188             # return undef for EOL
 189             delete $iter{$cxix};
 190             delete $entries{$cxix};
 191             return undef;
 192         }
 193     }
 194 }
 195
 196 {
 197     no strict 'refs';
 198
 199     sub import {
 200     my $pkg = shift;
 201     return unless @_;
 202     my $sym = shift;
 203     my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
 204     *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
 205     }
 206 }
 207 1;
 208
 209 __END__
 210
 211 =head1 NAME
 212
 213 File::DosGlob - DOS like globbing and then some
 214
 215 =head1 SYNOPSIS
 216
 217     require 5.004;
 218
 219     # override CORE::glob in current package
 220     use File::DosGlob 'glob';
 221
 222     # override CORE::glob in ALL packages (use with extreme caution!)
 223     use File::DosGlob 'GLOBAL_glob';
 224
 225     @perlfiles = glob  "..\\pe?l/*.p?";
 226     print <..\\pe?l/*.p?>;
 227
 228     # from the command line (overrides only in main::)
 229     > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
 230
 231 =head1 DESCRIPTION
 232
 233 A module that implements DOS-like globbing with a few enhancements.
 234 It is largely compatible with perlglob.exe (the M$ setargv.obj
 235 version) in all but one respect--it understands wildcards in
 236 directory components.
 237
 238 For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
 239 that it will find something like '..\lib\File/DosGlob.pm' alright).
 240 Note that all path components are case-insensitive, and that
 241 backslashes and forward slashes are both accepted, and preserved.
 242 You may have to double the backslashes if you are putting them in
 243 literally, due to double-quotish parsing of the pattern by perl.
 244
 245 Spaces in the argument delimit distinct patterns, so
 246 C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
 247 or C<.dll>.  If you want to put in literal spaces in the glob
 248 pattern, you can escape them with either double quotes, or backslashes.
 249 e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
 250 C<glob('c:/Program\ Files/*/*.dll')>.  The argument is tokenized using
 251 C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
 252 of the quoting rules used.
 253
 254 Extending it to csh patterns is left as an exercise to the reader.
 255
 256 =head1 EXPORTS (by request only)
 257
 258 glob()
 259
 260 =head1 BUGS
 261
 262 Should probably be built into the core, and needs to stop
 263 pandering to DOS habits.  Needs a dose of optimizium too.
 264
 265 =head1 AUTHOR
 266
 267 Gurusamy Sarathy <gsar@activestate.com>
 268
 269 =head1 HISTORY
 270
 271 =over 4
 272
 273 =item *
 274
 275 Support for globally overriding glob() (GSAR 3-JUN-98)
 276
 277 =item *
 278
 279 Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
 280
 281 =item *
 282
 283 A few dir-vs-file optimizations result in glob importation being
 284 10 times faster than using perlglob.exe, and using perlglob.bat is
 285 only twice as slow as perlglob.exe (GSAR 28-MAY-97)
 286
 287 =item *
 288
 289 Several cleanups prompted by lack of compatible perlglob.exe
 290 under Borland (GSAR 27-MAY-97)
 291
 292 =item *
 293
 294 Initial version (GSAR 20-FEB-97)
 295
 296 =back
 297
 298 =head1 SEE ALSO
 299
 300 perl
 301
 302 perlglob.bat
 303
 304 Text::ParseWords
 305
 306 =cut
 307