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 #
  99 # Do DOS-like globbing on Mac OS
 100 #
 101 sub doglob_Mac {
 102     my $cond = shift;
 103     my @retval = ();
 104
 105         #print "doglob_Mac: ", join('|', @_), "\n";
 106   OUTER:
 107     for my $arg (@_) {
 108         local $_ = $arg;
 109         my @matched = ();
 110         my @globdirs = ();
 111         my $head = ':';
 112         my $not_esc_head = $head;
 113         my $sepchr = ':';
 114         next OUTER unless defined $_ and $_ ne '';
 115         # if arg is within quotes strip em and do no globbing
 116         if (/^"(.*)"\z/s) {
 117             $_ = $1;
 118                 # $_ may contain escaped metachars '\*', '\?' and '\'
 119                 my $not_esc_arg = $_;
 120                 $not_esc_arg =~ s/\\([*?\\])/$1/g;
 121             if ($cond eq 'd') { push(@retval, $not_esc_arg) if -d $not_esc_arg }
 122             else              { push(@retval, $not_esc_arg) if -e $not_esc_arg }
 123             next OUTER;
 124         }
 125
 126         if (m|^(.*?)(:+)([^:]*)\z|s) { # note: $1 is not greedy
 127             my $tail;
 128             ($head, $sepchr, $tail) = ($1,$2,$3);
 129             #print "div: |$head|$sepchr|$tail|\n";
 130             push (@retval, $_), next OUTER if $tail eq '';
 131                 #
 132                 # $head may contain escaped metachars '\*' and '\?'
 133
 134                 my $tmp_head = $head;
 135                 # if a '*' or '?' is preceded by an odd count of '\', temporary delete
 136                 # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as
 137                 # wildcards
 138                 $tmp_head =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg;
 139
 140                 if ($tmp_head =~ /[*?]/) { # if there are wildcards ...
 141                 @globdirs = doglob_Mac('d', $head);
 142                 push(@retval, doglob_Mac($cond, map {"$_$sepchr$tail"} @globdirs)),
 143                     next OUTER if @globdirs;
 144             }
 145
 146                 $head .= $sepchr;
 147                 $not_esc_head = $head;
 148                 # unescape $head for file operations
 149                 $not_esc_head =~ s/\\([*?\\])/$1/g;
 150             $_ = $tail;
 151         }
 152         #
 153         # If file component has no wildcards, we can avoid opendir
 154
 155         my $tmp_tail = $_;
 156         # if a '*' or '?' is preceded by an odd count of '\', temporary delete
 157         # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as
 158         # wildcards
 159         $tmp_tail =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg;
 160
 161         unless ($tmp_tail =~ /[*?]/) { # if there are wildcards ...
 162             $not_esc_head = $head = '' if $head eq ':';
 163             my $not_esc_tail = $_;
 164             # unescape $head and $tail for file operations
 165             $not_esc_tail =~ s/\\([*?\\])/$1/g;
 166             $head .= $_;
 167                 $not_esc_head .= $not_esc_tail;
 168             if ($cond eq 'd') { push(@retval,$head) if -d $not_esc_head }
 169             else              { push(@retval,$head) if -e $not_esc_head }
 170             next OUTER;
 171         }
 172         #print "opendir($not_esc_head)\n";
 173         opendir(D, $not_esc_head) or next OUTER;
 174         my @leaves = readdir D;
 175         closedir D;
 176
 177         # escape regex metachars but not '\' and glob chars '*', '?'
 178         $_ =~ s:([].+^\-\${}[|]):\\$1:g;
 179         # and convert DOS-style wildcards to regex,
 180         # but only if they are not escaped
 181         $_ =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg;
 182
 183         #print "regex: '$_', head: '$head', unescaped head: '$not_esc_head'\n";
 184         my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }';
 185         warn($@), next OUTER if $@;
 186       INNER:
 187         for my $e (@leaves) {
 188             next INNER if $e eq '.' or $e eq '..';
 189             next INNER if $cond eq 'd' and ! -d "$not_esc_head$e";
 190
 191                 if (&$matchsub($e)) {
 192                         my $leave = (($not_esc_head eq ':') && (-f "$not_esc_head$e")) ?
 193                                 "$e" : "$not_esc_head$e";
 194                         #
 195                         # On Mac OS, the two glob metachars '*' and '?' and the escape
 196                         # char '\' are valid characters for file and directory names.
 197                         # We have to escape and treat them specially.
 198                         $leave =~ s|([*?\\])|\\$1|g;
 199                         push(@matched, $leave);
 200                         next INNER;
 201                 }
 202         }
 203         push @retval, @matched if @matched;
 204     }
 205     return @retval;
 206 }
 207
 208 #
 209 # _expand_volume() will only be used on Mac OS (Classic):
 210 # Takes an array of original patterns as argument and returns an array of
 211 # possibly modified patterns. Each original pattern is processed like
 212 # that:
 213 # + If there's a volume name in the pattern, we push a separate pattern
 214 #   for each mounted volume that matches (with '*', '?' and '\' escaped).
 215 # + If there's no volume name in the original pattern, it is pushed
 216 #   unchanged.
 217 # Note that the returned array of patterns may be empty.
 218 #
 219 sub _expand_volume {
 220
 221         require MacPerl; # to be verbose
 222
 223         my @pat = @_;
 224         my @new_pat = ();
 225         my @FSSpec_Vols = MacPerl::Volumes();
 226         my @mounted_volumes = ();
 227
 228         foreach my $spec_vol (@FSSpec_Vols) {
 229                 # push all mounted volumes into array
 230         push @mounted_volumes, MacPerl::MakePath($spec_vol);
 231         }
 232         #print "mounted volumes: |@mounted_volumes|\n";
 233
 234         while (@pat) {
 235                 my $pat = shift @pat;
 236                 if ($pat =~ /^([^:]+:)(.*)\z/) { # match a volume name?
 237                         my $vol_pat = $1;
 238                         my $tail = $2;
 239                         #
 240                         # escape regex metachars but not '\' and glob chars '*', '?'
 241                         $vol_pat =~ s:([].+^\-\${}[|]):\\$1:g;
 242                         # and convert DOS-style wildcards to regex,
 243                         # but only if they are not escaped
 244                         $vol_pat =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg;
 245                         #print "volume regex: '$vol_pat' \n";
 246
 247                         foreach my $volume (@mounted_volumes) {
 248                                 if ($volume =~ m|^$vol_pat\z|ios) {
 249                                         #
 250                                         # On Mac OS, the two glob metachars '*' and '?' and the
 251                                         # escape char '\' are valid characters for volume names.
 252                                         # We have to escape and treat them specially.
 253                                         $volume =~ s|([*?\\])|\\$1|g;
 254                                         push @new_pat, $volume . $tail;
 255                                 }
 256                         }
 257                 } else { # no volume name in pattern, push original pattern
 258                         push @new_pat, $pat;
 259                 }
 260         }
 261         return @new_pat;
 262 }
 263
 264
 265 #
 266 # _preprocess_pattern() will only be used on Mac OS (Classic):
 267 # Resolves any updirs in the pattern. Removes a single trailing colon
 268 # from the pattern, unless it's a volume name pattern like "*HD:"
 269 #
 270 sub _preprocess_pattern {
 271         my @pat = @_;
 272
 273         foreach my $p (@pat) {
 274                 my $proceed;
 275                 # resolve any updirs, e.g. "*HD:t?p::a*" -> "*HD:a*"
 276                 do {
 277                         $proceed = ($p =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/);
 278                 } while ($proceed);
 279                 # remove a single trailing colon, e.g. ":*:" -> ":*"
 280                 $p =~ s/:([^:]+):\z/:$1/;
 281         }
 282         return @pat;
 283 }
 284
 285
 286 #
 287 # _un_escape() will only be used on Mac OS (Classic):
 288 # Unescapes a list of arguments which may contain escaped
 289 # metachars '*', '?' and '\'.
 290 #
 291 sub _un_escape {
 292         foreach (@_) {
 293                 s/\\([*?\\])/$1/g;
 294         }
 295         return @_;
 296 }
 297
 298 #
 299 # this can be used to override CORE::glob in a specific
 300 # package by saying C<use File::DosGlob 'glob';> in that
 301 # namespace.
 302 #
 303
 304 # context (keyed by second cxix arg provided by core)
 305 my %iter;
 306 my %entries;
 307
 308 sub glob {
 309     my($pat,$cxix) = @_;
 310     my @pat;
 311
 312     # glob without args defaults to $_
 313     $pat = $_ unless defined $pat;
 314
 315     # extract patterns
 316     if ($pat =~ /\s/) {
 317         require Text::ParseWords;
 318         @pat = Text::ParseWords::parse_line('\s+',0,$pat);
 319     }
 320     else {
 321         push @pat, $pat;
 322     }
 323
 324     # Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3.
 325     #   abc3 will be the original {3} (and drop the {}).
 326     #   abc1 abc2 will be put in @appendpat.
 327     # This was just the esiest way, not nearly the best.
 328     REHASH: {
 329         my @appendpat = ();
 330         for (@pat) {
 331             # There must be a "," I.E. abc{efg} is not what we want.
 332             while ( /^(.*)(?<!\\)\{(.*?)(?<!\\)\,.*?(?<!\\)\}(.*)$/ ) {
 333                 my ($start, $match, $end) = ($1, $2, $3);
 334                 #print "Got: \n\t$start\n\t$match\n\t$end\n";
 335                 my $tmp = "$start$match$end";
 336                 while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) {
 337                     #print "Striped: $tmp\n";
 338                     #  these expanshions will be preformed by the original,
 339                     #  when we call REHASH.
 340                 }
 341                 push @appendpat, ("$tmp");
 342                 s/^\Q$start\E(?<!\\)\{\Q$match\E(?<!\\)\,/$start\{/;
 343                 if ( /^\Q$start\E(?<!\\)\{(?!.*?(?<!\\)\,.*?\Q$end\E$)(.*)(?<!\\)\}\Q$end\E$/ ) {
 344                     $match = $1;
 345                     #print "GOT: \n\t$start\n\t$match\n\t$end\n\n";
 346                     $_ = "$start$match$end";
 347                 }
 348             }
 349             #print "Sould have "GOT" vs "Got"!\n";
 350                 #FIXME: There should be checking for this.
 351                 #  How or what should be done about failure is beond me.
 352         }
 353         if ( $#appendpat != -1
 354                 ) {
 355             #print "LOOP\n";
 356             #FIXME: Max loop, no way! :")
 357             for ( @appendpat ) {
 358                 push @pat, $_;
 359             }
 360             goto REHASH;
 361         }
 362     }
 363     for ( @pat ) {
 364         s/\\{/{/g;
 365         s/\\}/}/g;
 366         s/\\,/,/g;
 367     }
 368     #print join ("\n", @pat). "\n";
 369
 370     # assume global context if not provided one
 371     $cxix = '_G_' unless defined $cxix;
 372     $iter{$cxix} = 0 unless exists $iter{$cxix};
 373
 374     # if we're just beginning, do it all first
 375     if ($iter{$cxix} == 0) {
 376         if ($^O eq 'MacOS') {
 377                 # first, take care of updirs and trailing colons
 378                 @pat = _preprocess_pattern(@pat);
 379                 # expand volume names
 380                 @pat = _expand_volume(@pat);
 381                 $entries{$cxix} = (@pat) ? [_un_escape( doglob_Mac(1,@pat) )] : [()];
 382         } else {
 383                 $entries{$cxix} = [doglob(1,@pat)];
 384     }
 385         }
 386
 387     # chuck it all out, quick or slow
 388     if (wantarray) {
 389         delete $iter{$cxix};
 390         return @{delete $entries{$cxix}};
 391     }
 392     else {
 393         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
 394             return shift @{$entries{$cxix}};
 395         }
 396         else {
 397             # return undef for EOL
 398             delete $iter{$cxix};
 399             delete $entries{$cxix};
 400             return undef;
 401         }
 402     }
 403 }
 404
 405 {
 406     no strict 'refs';
 407
 408     sub import {
 409     my $pkg = shift;
 410     return unless @_;
 411     my $sym = shift;
 412     my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
 413     *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
 414     }
 415 }
 416 1;
 417
 418 __END__
 419
 420 =head1 NAME
 421
 422 File::DosGlob - DOS like globbing and then some
 423
 424 =head1 SYNOPSIS
 425
 426     require 5.004;
 427
 428     # override CORE::glob in current package
 429     use File::DosGlob 'glob';
 430
 431     # override CORE::glob in ALL packages (use with extreme caution!)
 432     use File::DosGlob 'GLOBAL_glob';
 433
 434     @perlfiles = glob  "..\\pe?l/*.p?";
 435     print <..\\pe?l/*.p?>;
 436
 437     # from the command line (overrides only in main::)
 438     > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
 439
 440 =head1 DESCRIPTION
 441
 442 A module that implements DOS-like globbing with a few enhancements.
 443 It is largely compatible with perlglob.exe (the M$ setargv.obj
 444 version) in all but one respect--it understands wildcards in
 445 directory components.
 446
 447 For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
 448 that it will find something like '..\lib\File/DosGlob.pm' alright).
 449 Note that all path components are case-insensitive, and that
 450 backslashes and forward slashes are both accepted, and preserved.
 451 You may have to double the backslashes if you are putting them in
 452 literally, due to double-quotish parsing of the pattern by perl.
 453
 454 Spaces in the argument delimit distinct patterns, so
 455 C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
 456 or C<.dll>.  If you want to put in literal spaces in the glob
 457 pattern, you can escape them with either double quotes, or backslashes.
 458 e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
 459 C<glob('c:/Program\ Files/*/*.dll')>.  The argument is tokenized using
 460 C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
 461 of the quoting rules used.
 462
 463 Extending it to csh patterns is left as an exercise to the reader.
 464
 465 =head1 NOTES
 466
 467 =over 4
 468
 469 =item *
 470
 471 Mac OS (Classic) users should note a few differences. The specification
 472 of pathnames in glob patterns adheres to the usual Mac OS conventions:
 473 The path separator is a colon ':', not a slash '/' or backslash '\'. A
 474 full path always begins with a volume name. A relative pathname on Mac
 475 OS must always begin with a ':', except when specifying a file or
 476 directory name in the current working directory, where the leading colon
 477 is optional. If specifying a volume name only, a trailing ':' is
 478 required. Due to these rules, a glob like E<lt>*:E<gt> will find all
 479 mounted volumes, while a glob like E<lt>*E<gt> or E<lt>:*E<gt> will find
 480 all files and directories in the current directory.
 481
 482 Note that updirs in the glob pattern are resolved before the matching begins,
 483 i.e. a pattern like "*HD:t?p::a*" will be matched as "*HD:a*". Note also,
 484 that a single trailing ':' in the pattern is ignored (unless it's a volume
 485 name pattern like "*HD:"), i.e. a glob like <:*:> will find both directories
 486 I<and> files (and not, as one might expect, only directories).
 487
 488 The metachars '*', '?' and the escape char '\' are valid characters in
 489 volume, directory and file names on Mac OS. Hence, if you want to match
 490 a '*', '?' or '\' literally, you have to escape these characters. Due to
 491 perl's quoting rules, things may get a bit complicated, when you want to
 492 match a string like '\*' literally, or when you want to match '\' literally,
 493 but treat the immediately following character '*' as metachar. So, here's a
 494 rule of thumb (applies to both single- and double-quoted strings): escape
 495 each '*' or '?' or '\' with a backslash, if you want to treat them literally,
 496 and then double each backslash and your are done. E.g.
 497
 498 - Match '\*' literally
 499
 500    escape both '\' and '*'  : '\\\*'
 501    double the backslashes   : '\\\\\\*'
 502
 503 (Internally, the glob routine sees a '\\\*', which means that both '\' and
 504 '*' are escaped.)
 505
 506
 507 - Match '\' literally, treat '*' as metachar
 508
 509    escape '\' but not '*'   : '\\*'
 510    double the backslashes   : '\\\\*'
 511
 512 (Internally, the glob routine sees a '\\*', which means that '\' is escaped and
 513 '*' is not.)
 514
 515 Note that you also have to quote literal spaces in the glob pattern, as described
 516 above.
 517
 518 =back
 519
 520 =head1 EXPORTS (by request only)
 521
 522 glob()
 523
 524 =head1 BUGS
 525
 526 Should probably be built into the core, and needs to stop
 527 pandering to DOS habits.  Needs a dose of optimizium too.
 528
 529 =head1 AUTHOR
 530
 531 Gurusamy Sarathy <gsar@activestate.com>
 532
 533 =head1 HISTORY
 534
 535 =over 4
 536
 537 =item *
 538
 539 Support for globally overriding glob() (GSAR 3-JUN-98)
 540
 541 =item *
 542
 543 Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
 544
 545 =item *
 546
 547 A few dir-vs-file optimizations result in glob importation being
 548 10 times faster than using perlglob.exe, and using perlglob.bat is
 549 only twice as slow as perlglob.exe (GSAR 28-MAY-97)
 550
 551 =item *
 552
 553 Several cleanups prompted by lack of compatible perlglob.exe
 554 under Borland (GSAR 27-MAY-97)
 555
 556 =item *
 557
 558 Initial version (GSAR 20-FEB-97)
 559
 560 =back
 561
 562 =head1 SEE ALSO
 563
 564 perl
 565
 566 perlglob.bat
 567
 568 Text::ParseWords
 569
 570 =cut
 571