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