This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ae23dbd5ee41d6fa1d125f65814e65f17da778a9
[perl5.git] / 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.06';
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 # this can be used to override CORE::glob in a specific
104 # package by saying C<use File::DosGlob 'glob';> in that
105 # namespace.
106 #
107
108 # context (keyed by second cxix arg provided by core)
109 my %iter;
110 my %entries;
111
112 sub glob {
113     my($pat,$cxix) = @_;
114     my @pat;
115
116     # glob without args defaults to $_
117     $pat = $_ unless defined $pat;
118
119     # extract patterns
120     if ($pat =~ /\s/) {
121         require Text::ParseWords;
122         @pat = Text::ParseWords::parse_line('\s+',0,$pat);
123     }
124     else {
125         push @pat, $pat;
126     }
127
128     # Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3.
129     #   abc3 will be the original {3} (and drop the {}).
130     #   abc1 abc2 will be put in @appendpat.
131     # This was just the esiest way, not nearly the best.
132     REHASH: {
133         my @appendpat = ();
134         for (@pat) {
135             # There must be a "," I.E. abc{efg} is not what we want.
136             while ( /^(.*)(?<!\\)\{(.*?)(?<!\\)\,.*?(?<!\\)\}(.*)$/ ) {
137                 my ($start, $match, $end) = ($1, $2, $3);
138                 #print "Got: \n\t$start\n\t$match\n\t$end\n";
139                 my $tmp = "$start$match$end";
140                 while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) {
141                     #print "Striped: $tmp\n";
142                     #  these expansions will be performed by the original,
143                     #  when we call REHASH.
144                 }
145                 push @appendpat, ("$tmp");
146                 s/^\Q$start\E(?<!\\)\{\Q$match\E(?<!\\)\,/$start\{/;
147                 if ( /^\Q$start\E(?<!\\)\{(?!.*?(?<!\\)\,.*?\Q$end\E$)(.*)(?<!\\)\}\Q$end\E$/ ) {
148                     $match = $1;
149                     #print "GOT: \n\t$start\n\t$match\n\t$end\n\n";
150                     $_ = "$start$match$end";
151                 }
152             }
153             #print "Sould have "GOT" vs "Got"!\n";
154                 #FIXME: There should be checking for this.
155                 #  How or what should be done about failure is beond me.
156         }
157         if ( $#appendpat != -1
158                 ) {
159             #print "LOOP\n";
160             #FIXME: Max loop, no way! :")
161             for ( @appendpat ) {
162                 push @pat, $_;
163             }
164             goto REHASH;
165         }
166     }
167     for ( @pat ) {
168         s/\\{/{/g;
169         s/\\}/}/g;
170         s/\\,/,/g;
171     }
172     #print join ("\n", @pat). "\n";
173  
174     # assume global context if not provided one
175     $cxix = '_G_' unless defined $cxix;
176     $iter{$cxix} = 0 unless exists $iter{$cxix};
177
178     # if we're just beginning, do it all first
179     if ($iter{$cxix} == 0) {
180             $entries{$cxix} = [doglob(1,@pat)];
181         }
182
183     # chuck it all out, quick or slow
184     if (wantarray) {
185         delete $iter{$cxix};
186         return @{delete $entries{$cxix}};
187     }
188     else {
189         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
190             return shift @{$entries{$cxix}};
191         }
192         else {
193             # return undef for EOL
194             delete $iter{$cxix};
195             delete $entries{$cxix};
196             return undef;
197         }
198     }
199 }
200
201 {
202     no strict 'refs';
203
204     sub import {
205     my $pkg = shift;
206     return unless @_;
207     my $sym = shift;
208     my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
209     *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
210     }
211 }
212 1;
213
214 __END__
215
216 =head1 NAME
217
218 File::DosGlob - DOS like globbing and then some
219
220 =head1 SYNOPSIS
221
222     require 5.004;
223
224     # override CORE::glob in current package
225     use File::DosGlob 'glob';
226
227     # override CORE::glob in ALL packages (use with extreme caution!)
228     use File::DosGlob 'GLOBAL_glob';
229
230     @perlfiles = glob  "..\\pe?l/*.p?";
231     print <..\\pe?l/*.p?>;
232
233     # from the command line (overrides only in main::)
234     > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
235
236 =head1 DESCRIPTION
237
238 A module that implements DOS-like globbing with a few enhancements.
239 It is largely compatible with perlglob.exe (the M$ setargv.obj
240 version) in all but one respect--it understands wildcards in
241 directory components.
242
243 For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
244 that it will find something like '..\lib\File/DosGlob.pm' alright).
245 Note that all path components are case-insensitive, and that
246 backslashes and forward slashes are both accepted, and preserved.
247 You may have to double the backslashes if you are putting them in
248 literally, due to double-quotish parsing of the pattern by perl.
249
250 Spaces in the argument delimit distinct patterns, so
251 C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
252 or C<.dll>.  If you want to put in literal spaces in the glob
253 pattern, you can escape them with either double quotes, or backslashes.
254 e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
255 C<glob('c:/Program\ Files/*/*.dll')>.  The argument is tokenized using
256 C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
257 of the quoting rules used.
258
259 Extending it to csh patterns is left as an exercise to the reader.
260
261 =head1 EXPORTS (by request only)
262
263 glob()
264
265 =head1 BUGS
266
267 Should probably be built into the core, and needs to stop
268 pandering to DOS habits.  Needs a dose of optimizium too.
269
270 =head1 AUTHOR
271
272 Gurusamy Sarathy <gsar@activestate.com>
273
274 =head1 HISTORY
275
276 =over 4
277
278 =item *
279
280 Support for globally overriding glob() (GSAR 3-JUN-98)
281
282 =item *
283
284 Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
285
286 =item *
287
288 A few dir-vs-file optimizations result in glob importation being
289 10 times faster than using perlglob.exe, and using perlglob.bat is
290 only twice as slow as perlglob.exe (GSAR 28-MAY-97)
291
292 =item *
293
294 Several cleanups prompted by lack of compatible perlglob.exe
295 under Borland (GSAR 27-MAY-97)
296
297 =item *
298
299 Initial version (GSAR 20-FEB-97)
300
301 =back
302
303 =head1 SEE ALSO
304
305 perl
306
307 perlglob.bat
308
309 Text::ParseWords
310
311 =cut
312