This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Increase $File::DosGlob::VERSION to 1.09
[perl5.git] / ext / File-DosGlob / lib / File / DosGlob.pm
1 #!perl -w
2
3 #
4 # Documentation at the __END__
5 #
6
7 package File::DosGlob;
8
9 our $VERSION = '1.09';
10 use strict;
11 use warnings;
12
13 sub doglob {
14     my $cond = shift;
15     my @retval = ();
16     my $fix_drive_relative_paths;
17   OUTER:
18     for my $pat (@_) {
19         my @matched = ();
20         my @globdirs = ();
21         my $head = '.';
22         my $sepchr = '/';
23         my $tail;
24         next OUTER unless defined $pat and $pat ne '';
25         # if arg is within quotes strip em and do no globbing
26         if ($pat =~ /^"(.*)"\z/s) {
27             $pat = $1;
28             if ($cond eq 'd') { push(@retval, $pat) if -d $pat }
29             else              { push(@retval, $pat) if -e $pat }
30             next OUTER;
31         }
32         # wildcards with a drive prefix such as h:*.pm must be changed
33         # to h:./*.pm to expand correctly
34         if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) {
35             substr($pat,0,2) = $1 . "./";
36             $fix_drive_relative_paths = 1;
37         }
38         if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) {
39             ($head, $sepchr, $tail) = ($1,$2,$3);
40             push (@retval, $pat), next OUTER if $tail eq '';
41             if ($head =~ /[*?]/) {
42                 @globdirs = doglob('d', $head);
43                 push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
44                     next OUTER if @globdirs;
45             }
46             $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s;
47             $pat = $tail;
48         }
49         #
50         # If file component has no wildcards, we can avoid opendir
51         unless ($pat =~ /[*?]/) {
52             $head = '' if $head eq '.';
53             $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
54             $head .= $pat;
55             if ($cond eq 'd') { push(@retval,$head) if -d $head }
56             else              { push(@retval,$head) if -e $head }
57             next OUTER;
58         }
59         opendir(D, $head) or next OUTER;
60         my @leaves = readdir D;
61         closedir D;
62         $head = '' if $head eq '.';
63         $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
64
65         # escape regex metachars but not glob chars
66         $pat =~ s:([].+^\-\${}()[|]):\\$1:g;
67         # and convert DOS-style wildcards to regex
68         $pat =~ s/\*/.*/g;
69         $pat =~ s/\?/.?/g;
70
71         my $matchsub = sub { $_[0] =~ m|^$pat\z|is };
72       INNER:
73         for my $e (@leaves) {
74             next INNER if $e eq '.' or $e eq '..';
75             next INNER if $cond eq 'd' and ! -d "$head$e";
76             push(@matched, "$head$e"), next INNER if &$matchsub($e);
77             #
78             # [DOS compatibility special case]
79             # Failed, add a trailing dot and try again, but only
80             # if name does not have a dot in it *and* pattern
81             # has a dot *and* name is shorter than 9 chars.
82             #
83             if (index($e,'.') == -1 and length($e) < 9
84                 and index($pat,'\\.') != -1) {
85                 push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
86             }
87         }
88         push @retval, @matched if @matched;
89     }
90     if ($fix_drive_relative_paths) {
91         s|^([A-Za-z]:)\./|$1| for @retval;
92     }
93     return @retval;
94 }
95
96 #
97 # this can be used to override CORE::glob in a specific
98 # package by saying C<use File::DosGlob 'glob';> in that
99 # namespace.
100 #
101
102 # context (keyed by second cxix arg provided by core)
103 my %entries;
104
105 sub glob {
106     my($pat,$cxix) = @_;
107     my @pat;
108
109     # glob without args defaults to $_
110     $pat = $_ unless defined $pat;
111
112     # assume global context if not provided one
113     $cxix = '_G_' unless defined $cxix;
114
115     # if we're just beginning, do it all first
116     if (!$entries{$cxix}) {
117       # extract patterns
118       if ($pat =~ /\s/) {
119         require Text::ParseWords;
120         @pat = Text::ParseWords::parse_line('\s+',0,$pat);
121       }
122       else {
123         push @pat, $pat;
124       }
125
126       # Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3.
127       #   abc3 will be the original {3} (and drop the {}).
128       #   abc1 abc2 will be put in @appendpat.
129       # This was just the easiest way, not nearly the best.
130       REHASH: {
131         my @appendpat = ();
132         for (@pat) {
133             # There must be a "," I.E. abc{efg} is not what we want.
134             while ( /^(.*)(?<!\\)\{(.*?)(?<!\\)\,.*?(?<!\\)\}(.*)$/ ) {
135                 my ($start, $match, $end) = ($1, $2, $3);
136                 #print "Got: \n\t$start\n\t$match\n\t$end\n";
137                 my $tmp = "$start$match$end";
138                 while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) {
139                     #  these expansions will be performed by the original,
140                     #  when we call REHASH.
141                 }
142                 push @appendpat, ("$tmp");
143                 s/^\Q$start\E(?<!\\)\{\Q$match\E(?<!\\)\,/$start\{/;
144                 if ( /^\Q$start\E(?<!\\)\{(?!.*?(?<!\\)\,.*?\Q$end\E$)(.*)(?<!\\)\}\Q$end\E$/ ) {
145                     $match = $1;
146                     #print "GOT: \n\t$start\n\t$match\n\t$end\n\n";
147                     $_ = "$start$match$end";
148                 }
149             }
150             #print "Sould have "GOT" vs "Got"!\n";
151                 #FIXME: There should be checking for this.
152                 #  How or what should be done about failure is beond me.
153         }
154         if ( $#appendpat != -1
155                 ) {
156             #FIXME: Max loop, no way! :")
157             for ( @appendpat ) {
158                 push @pat, $_;
159             }
160             goto REHASH;
161         }
162       }
163       for ( @pat ) {
164         s/\\([{},])/$1/g;
165       }
166  
167       $entries{$cxix} = [doglob(1,@pat)];
168     }
169
170     # chuck it all out, quick or slow
171     if (wantarray) {
172         return @{delete $entries{$cxix}};
173     }
174     else {
175         if (scalar @{$entries{$cxix}}) {
176             return shift @{$entries{$cxix}};
177         }
178         else {
179             # return undef for EOL
180             delete $entries{$cxix};
181             return undef;
182         }
183     }
184 }
185
186 {
187     no strict 'refs';
188
189     sub import {
190     my $pkg = shift;
191     return unless @_;
192     my $sym = shift;
193     my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
194     *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
195     }
196 }
197 1;
198
199 __END__
200
201 =head1 NAME
202
203 File::DosGlob - DOS like globbing and then some
204
205 =head1 SYNOPSIS
206
207     require 5.004;
208
209     # override CORE::glob in current package
210     use File::DosGlob 'glob';
211
212     # override CORE::glob in ALL packages (use with extreme caution!)
213     use File::DosGlob 'GLOBAL_glob';
214
215     @perlfiles = glob  "..\\pe?l/*.p?";
216     print <..\\pe?l/*.p?>;
217
218     # from the command line (overrides only in main::)
219     > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
220
221 =head1 DESCRIPTION
222
223 A module that implements DOS-like globbing with a few enhancements.
224 It is largely compatible with perlglob.exe (the M$ setargv.obj
225 version) in all but one respect--it understands wildcards in
226 directory components.
227
228 For example, C<< <..\\l*b\\file/*glob.p?> >> will work as expected (in
229 that it will find something like '..\lib\File/DosGlob.pm' alright).
230 Note that all path components are case-insensitive, and that
231 backslashes and forward slashes are both accepted, and preserved.
232 You may have to double the backslashes if you are putting them in
233 literally, due to double-quotish parsing of the pattern by perl.
234
235 Spaces in the argument delimit distinct patterns, so
236 C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
237 or C<.dll>.  If you want to put in literal spaces in the glob
238 pattern, you can escape them with either double quotes, or backslashes.
239 e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
240 C<glob('c:/Program\ Files/*/*.dll')>.  The argument is tokenized using
241 C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
242 of the quoting rules used.
243
244 Extending it to csh patterns is left as an exercise to the reader.
245
246 =head1 EXPORTS (by request only)
247
248 glob()
249
250 =head1 BUGS
251
252 Should probably be built into the core, and needs to stop
253 pandering to DOS habits.  Needs a dose of optimizium too.
254
255 =head1 AUTHOR
256
257 Gurusamy Sarathy <gsar@activestate.com>
258
259 =head1 HISTORY
260
261 =over 4
262
263 =item *
264
265 Support for globally overriding glob() (GSAR 3-JUN-98)
266
267 =item *
268
269 Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
270
271 =item *
272
273 A few dir-vs-file optimizations result in glob importation being
274 10 times faster than using perlglob.exe, and using perlglob.bat is
275 only twice as slow as perlglob.exe (GSAR 28-MAY-97)
276
277 =item *
278
279 Several cleanups prompted by lack of compatible perlglob.exe
280 under Borland (GSAR 27-MAY-97)
281
282 =item *
283
284 Initial version (GSAR 20-FEB-97)
285
286 =back
287
288 =head1 SEE ALSO
289
290 perl
291
292 perlglob.bat
293
294 Text::ParseWords
295
296 =cut
297