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