This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
DosGlob: eliminate %iter
[perl5.git] / lib / File / DosGlob.pm
CommitLineData
08aa1457
PP
1#!perl -w
2
37248846
MM
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
08aa1457
PP
6#
7# Documentation at the __END__
8#
9
10package File::DosGlob;
11
598c6284 12our $VERSION = '1.06';
b75c8c73 13use strict;
b395063c 14use warnings;
b75c8c73 15
08aa1457
PP
16sub doglob {
17 my $cond = shift;
18 my @retval = ();
2f3c8ce9 19 my $fix_drive_relative_paths;
08aa1457
PP
20 #print "doglob: ", join('|', @_), "\n";
21 OUTER:
b75c8c73 22 for my $pat (@_) {
08aa1457
PP
23 my @matched = ();
24 my @globdirs = ();
25 my $head = '.';
26 my $sepchr = '/';
b75c8c73
MS
27 my $tail;
28 next OUTER unless defined $pat and $pat ne '';
08aa1457 29 # if arg is within quotes strip em and do no globbing
b75c8c73
MS
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 }
08aa1457
PP
34 next OUTER;
35 }
4dd406c2
GS
36 # wildcards with a drive prefix such as h:*.pm must be changed
37 # to h:./*.pm to expand correctly
b75c8c73 38 if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) {
a371bcf3 39 substr($pat,0,2) = $1 . "./";
2f3c8ce9 40 $fix_drive_relative_paths = 1;
4dd406c2 41 }
b75c8c73 42 if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) {
08aa1457
PP
43 ($head, $sepchr, $tail) = ($1,$2,$3);
44 #print "div: |$head|$sepchr|$tail|\n";
b75c8c73 45 push (@retval, $pat), next OUTER if $tail eq '';
08aa1457
PP
46 if ($head =~ /[*?]/) {
47 @globdirs = doglob('d', $head);
48 push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
49 next OUTER if @globdirs;
50 }
4dd406c2 51 $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s;
b75c8c73 52 $pat = $tail;
08aa1457
PP
53 }
54 #
55 # If file component has no wildcards, we can avoid opendir
b75c8c73 56 unless ($pat =~ /[*?]/) {
08aa1457
PP
57 $head = '' if $head eq '.';
58 $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
b75c8c73 59 $head .= $pat;
08aa1457
PP
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
2f3c8ce9 71 $pat =~ s:([].+^\-\${}()[|]):\\$1:g;
08aa1457 72 # and convert DOS-style wildcards to regex
b75c8c73
MS
73 $pat =~ s/\*/.*/g;
74 $pat =~ s/\?/.?/g;
08aa1457 75
b75c8c73
MS
76 #print "regex: '$pat', head: '$head'\n";
77 my $matchsub = sub { $_[0] =~ m|^$pat\z|is };
08aa1457
PP
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
b75c8c73 90 and index($pat,'\\.') != -1) {
08aa1457
PP
91 push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
92 }
93 }
94 push @retval, @matched if @matched;
95 }
2f3c8ce9
AD
96 if ($fix_drive_relative_paths) {
97 s|^([A-Za-z]:)\./|$1| for @retval;
98 }
08aa1457
PP
99 return @retval;
100}
101
102#
fb73857a
PP
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.
08aa1457 106#
fb73857a
PP
107
108# context (keyed by second cxix arg provided by core)
fb73857a
PP
109my %entries;
110
111sub glob {
b75c8c73 112 my($pat,$cxix) = @_;
163d180b 113 my @pat;
fb73857a
PP
114
115 # glob without args defaults to $_
116 $pat = $_ unless defined $pat;
117
163d180b
GS
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
37248846
MM
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";
81de5c05 141 # these expansions will be performed by the original,
37248846
MM
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
fb73857a
PP
173 # assume global context if not provided one
174 $cxix = '_G_' unless defined $cxix;
fb73857a
PP
175
176 # if we're just beginning, do it all first
3a29130a 177 $entries{$cxix} ||= [doglob(1,@pat)];
fb73857a
PP
178
179 # chuck it all out, quick or slow
180 if (wantarray) {
fb73857a
PP
181 return @{delete $entries{$cxix}};
182 }
183 else {
3a29130a 184 if (scalar @{$entries{$cxix}}) {
fb73857a
PP
185 return shift @{$entries{$cxix}};
186 }
187 else {
188 # return undef for EOL
fb73857a
PP
189 delete $entries{$cxix};
190 return undef;
191 }
192 }
193}
08aa1457 194
b75c8c73
MS
195{
196 no strict 'refs';
197
198 sub import {
08aa1457 199 my $pkg = shift;
95d94a4f 200 return unless @_;
08aa1457 201 my $sym = shift;
4dd406c2 202 my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
95d94a4f 203 *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
b75c8c73 204 }
08aa1457 205}
08aa1457
PP
2061;
207
208__END__
209
210=head1 NAME
211
212File::DosGlob - DOS like globbing and then some
213
08aa1457
PP
214=head1 SYNOPSIS
215
216 require 5.004;
3cb6de81 217
fb73857a
PP
218 # override CORE::glob in current package
219 use File::DosGlob 'glob';
3cb6de81 220
95d94a4f
GS
221 # override CORE::glob in ALL packages (use with extreme caution!)
222 use File::DosGlob 'GLOBAL_glob';
223
08aa1457
PP
224 @perlfiles = glob "..\\pe?l/*.p?";
225 print <..\\pe?l/*.p?>;
3cb6de81 226
fb73857a 227 # from the command line (overrides only in main::)
08aa1457 228 > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
08aa1457
PP
229
230=head1 DESCRIPTION
231
232A module that implements DOS-like globbing with a few enhancements.
dfb634a9 233It is largely compatible with perlglob.exe (the M$ setargv.obj
08aa1457
PP
234version) in all but one respect--it understands wildcards in
235directory components.
236
237For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
238that it will find something like '..\lib\File/DosGlob.pm' alright).
239Note that all path components are case-insensitive, and that
240backslashes and forward slashes are both accepted, and preserved.
241You may have to double the backslashes if you are putting them in
242literally, due to double-quotish parsing of the pattern by perl.
243
163d180b
GS
244Spaces in the argument delimit distinct patterns, so
245C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
246or C<.dll>. If you want to put in literal spaces in the glob
247pattern, you can escape them with either double quotes, or backslashes.
248e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
249C<glob('c:/Program\ Files/*/*.dll')>. The argument is tokenized using
250C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
251of the quoting rules used.
252
08aa1457
PP
253Extending it to csh patterns is left as an exercise to the reader.
254
255=head1 EXPORTS (by request only)
256
257glob()
258
259=head1 BUGS
260
261Should probably be built into the core, and needs to stop
262pandering to DOS habits. Needs a dose of optimizium too.
263
264=head1 AUTHOR
265
6e238990 266Gurusamy Sarathy <gsar@activestate.com>
08aa1457
PP
267
268=head1 HISTORY
269
270=over 4
271
272=item *
273
95d94a4f
GS
274Support for globally overriding glob() (GSAR 3-JUN-98)
275
276=item *
277
fb73857a
PP
278Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
279
280=item *
281
08aa1457
PP
282A few dir-vs-file optimizations result in glob importation being
28310 times faster than using perlglob.exe, and using perlglob.bat is
284only twice as slow as perlglob.exe (GSAR 28-MAY-97)
285
286=item *
287
63d661c5
FC
288Several cleanups prompted by lack of compatible perlglob.exe
289under Borland (GSAR 27-MAY-97)
290
291=item *
292
08aa1457
PP
293Initial version (GSAR 20-FEB-97)
294
295=back
296
297=head1 SEE ALSO
298
299perl
300
dfb634a9
GS
301perlglob.bat
302
163d180b
GS
303Text::ParseWords
304
08aa1457
PP
305=cut
306