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