fix diagnostics to report "our" vs "my" correctly
[p5sagit/p5-mst-13.2.git] / 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@activestate.com>
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