lib/File/DosGlob.pm

   1 #!perl -w
   2
   3 #
   4 # Documentation at the __END__
   5 #
   6
   7 package File::DosGlob;
   8
   9 unless (caller) {
  10     $| = 1;
  11     while (@ARGV) {
  12         #
  13         # We have to do this one by one for compatibility reasons.
  14         # If an arg doesn't match anything, we are supposed to return
  15         # the original arg.  I know, it stinks, eh?
  16         #
  17         my $arg = shift;
  18         my @m = doglob(1,$arg);
  19         print (@m ? join("\0", sort @m) : $arg);
  20         print "\0" if @ARGV;
  21     }
  22 }
  23
  24 sub doglob {
  25     my $cond = shift;
  26     my @retval = ();
  27     #print "doglob: ", join('|', @_), "\n";
  28   OUTER:
  29     for my $arg (@_) {
  30         local $_ = $arg;
  31         my @matched = ();
  32         my @globdirs = ();
  33         my $head = '.';
  34         my $sepchr = '/';
  35         next OUTER unless defined $_ and $_ ne '';
  36         # if arg is within quotes strip em and do no globbing
  37         if (/^"(.*)"$/) {
  38             $_ = $1;
  39             if ($cond eq 'd') { push(@retval, $_) if -d $_ }
  40             else              { push(@retval, $_) if -e $_ }
  41             next OUTER;
  42         }
  43         if (m|^(.*)([\\/])([^\\/]*)$|) {
  44             my $tail;
  45             ($head, $sepchr, $tail) = ($1,$2,$3);
  46             #print "div: |$head|$sepchr|$tail|\n";
  47             push (@retval, $_), next OUTER if $tail eq '';
  48             if ($head =~ /[*?]/) {
  49                 @globdirs = doglob('d', $head);
  50                 push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
  51                     next OUTER if @globdirs;
  52             }
  53             $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:$/;
  54             $_ = $tail;
  55         }
  56         #
  57         # If file component has no wildcards, we can avoid opendir
  58         unless (/[*?]/) {
  59             $head = '' if $head eq '.';
  60             $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
  61             $head .= $_;
  62             if ($cond eq 'd') { push(@retval,$head) if -d $head }
  63             else              { push(@retval,$head) if -e $head }
  64             next OUTER;
  65         }
  66         opendir(D, $head) or next OUTER;
  67         my @leaves = readdir D;
  68         closedir D;
  69         $head = '' if $head eq '.';
  70         $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
  71
  72         # escape regex metachars but not glob chars
  73         s:([].+^\-\${}[|]):\\$1:g;
  74         # and convert DOS-style wildcards to regex
  75         s/\*/.*/g;
  76         s/\?/.?/g;
  77
  78         #print "regex: '$_', head: '$head'\n";
  79         my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '$|io }';
  80         warn($@), next OUTER if $@;
  81       INNER:
  82         for my $e (@leaves) {
  83             next INNER if $e eq '.' or $e eq '..';
  84             next INNER if $cond eq 'd' and ! -d "$head$e";
  85             push(@matched, "$head$e"), next INNER if &$matchsub($e);
  86             #
  87             # [DOS compatibility special case]
  88             # Failed, add a trailing dot and try again, but only
  89             # if name does not have a dot in it *and* pattern
  90             # has a dot *and* name is shorter than 9 chars.
  91             #
  92             if (index($e,'.') == -1 and length($e) < 9
  93                 and index($_,'\\.') != -1) {
  94                 push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
  95             }
  96         }
  97         push @retval, @matched if @matched;
  98     }
  99     return @retval;
 100 }
 101
 102 #
 103 # this can be used to override CORE::glob
 104 # by saying C<use File::DosGlob 'glob';>.
 105 #
 106 sub glob { doglob(1,@_) }
 107
 108 sub import {
 109     my $pkg = shift;
 110     my $callpkg = caller(0);
 111     my $sym = shift;
 112     *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
 113 }
 114
 115 1;
 116
 117 __END__
 118
 119 =head1 NAME
 120
 121 File::DosGlob - DOS like globbing and then some
 122
 123 perlglob.bat - a more capable perlglob.exe replacement
 124
 125 =head1 SYNOPSIS
 126
 127     require 5.004;
 128     use File::DosGlob 'glob';  # override CORE::glob
 129     @perlfiles = glob  "..\\pe?l/*.p?";
 130     print <..\\pe?l/*.p?>;
 131
 132     # from the command line
 133     > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
 134
 135     > perlglob ../pe*/*p?
 136
 137 =head1 DESCRIPTION
 138
 139 A module that implements DOS-like globbing with a few enhancements.
 140 This file is also a portable replacement for perlglob.exe.  It
 141 is largely compatible with perlglob.exe (the M$ setargv.obj
 142 version) in all but one respect--it understands wildcards in
 143 directory components.
 144
 145 For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
 146 that it will find something like '..\lib\File/DosGlob.pm' alright).
 147 Note that all path components are case-insensitive, and that
 148 backslashes and forward slashes are both accepted, and preserved.
 149 You may have to double the backslashes if you are putting them in
 150 literally, due to double-quotish parsing of the pattern by perl.
 151
 152 When invoked as a program, it will print null-separated filenames
 153 to standard output.
 154
 155 While one may replace perlglob.exe with this, usage by overriding
 156 CORE::glob via importation should be much more efficient, because
 157 it avoids launching a separate process, and is therefore strongly
 158 recommended.
 159
 160 Extending it to csh patterns is left as an exercise to the reader.
 161
 162 =head1 EXPORTS (by request only)
 163
 164 glob()
 165
 166 =head1 BUGS
 167
 168 Should probably be built into the core, and needs to stop
 169 pandering to DOS habits.  Needs a dose of optimizium too.
 170
 171 =head1 AUTHOR
 172
 173 Gurusamy Sarathy <gsar@umich.edu>
 174
 175 =head1 HISTORY
 176
 177 =over 4
 178
 179 =item *
 180
 181 A few dir-vs-file optimizations result in glob importation being
 182 10 times faster than using perlglob.exe, and using perlglob.bat is
 183 only twice as slow as perlglob.exe (GSAR 28-MAY-97)
 184
 185 =item *
 186
 187 Several cleanups prompted by lack of compatible perlglob.exe
 188 under Borland (GSAR 27-MAY-97)
 189
 190 =item *
 191
 192 Initial version (GSAR 20-FEB-97)
 193
 194 =back
 195
 196 =head1 SEE ALSO
 197
 198 perl
 199
 200 =cut
 201