This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Increase $File::DosGlob::VERSION to 1.07
[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)
109my %iter;
110my %entries;
111
112sub glob {
b75c8c73 113 my($pat,$cxix) = @_;
163d180b 114 my @pat;
fb73857a
PP
115
116 # glob without args defaults to $_
117 $pat = $_ unless defined $pat;
118
163d180b
GS
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
37248846
MM
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";
81de5c05 142 # these expansions will be performed by the original,
37248846
MM
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
fb73857a
PP
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) {
862f843b 180 $entries{$cxix} = [doglob(1,@pat)];
be708cc0 181 }
fb73857a
PP
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}
08aa1457 200
b75c8c73
MS
201{
202 no strict 'refs';
203
204 sub import {
08aa1457 205 my $pkg = shift;
95d94a4f 206 return unless @_;
08aa1457 207 my $sym = shift;
4dd406c2 208 my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
95d94a4f 209 *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
b75c8c73 210 }
08aa1457 211}
08aa1457
PP
2121;
213
214__END__
215
216=head1 NAME
217
218File::DosGlob - DOS like globbing and then some
219
08aa1457
PP
220=head1 SYNOPSIS
221
222 require 5.004;
3cb6de81 223
fb73857a
PP
224 # override CORE::glob in current package
225 use File::DosGlob 'glob';
3cb6de81 226
95d94a4f
GS
227 # override CORE::glob in ALL packages (use with extreme caution!)
228 use File::DosGlob 'GLOBAL_glob';
229
08aa1457
PP
230 @perlfiles = glob "..\\pe?l/*.p?";
231 print <..\\pe?l/*.p?>;
3cb6de81 232
fb73857a 233 # from the command line (overrides only in main::)
08aa1457 234 > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
08aa1457
PP
235
236=head1 DESCRIPTION
237
238A module that implements DOS-like globbing with a few enhancements.
dfb634a9 239It is largely compatible with perlglob.exe (the M$ setargv.obj
08aa1457
PP
240version) in all but one respect--it understands wildcards in
241directory components.
242
243For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
244that it will find something like '..\lib\File/DosGlob.pm' alright).
245Note that all path components are case-insensitive, and that
246backslashes and forward slashes are both accepted, and preserved.
247You may have to double the backslashes if you are putting them in
248literally, due to double-quotish parsing of the pattern by perl.
249
163d180b
GS
250Spaces in the argument delimit distinct patterns, so
251C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
252or C<.dll>. If you want to put in literal spaces in the glob
253pattern, you can escape them with either double quotes, or backslashes.
254e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
255C<glob('c:/Program\ Files/*/*.dll')>. The argument is tokenized using
256C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
257of the quoting rules used.
258
08aa1457
PP
259Extending it to csh patterns is left as an exercise to the reader.
260
261=head1 EXPORTS (by request only)
262
263glob()
264
265=head1 BUGS
266
267Should probably be built into the core, and needs to stop
268pandering to DOS habits. Needs a dose of optimizium too.
269
270=head1 AUTHOR
271
6e238990 272Gurusamy Sarathy <gsar@activestate.com>
08aa1457
PP
273
274=head1 HISTORY
275
276=over 4
277
278=item *
279
95d94a4f
GS
280Support for globally overriding glob() (GSAR 3-JUN-98)
281
282=item *
283
fb73857a
PP
284Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
285
286=item *
287
08aa1457
PP
288A few dir-vs-file optimizations result in glob importation being
28910 times faster than using perlglob.exe, and using perlglob.bat is
290only twice as slow as perlglob.exe (GSAR 28-MAY-97)
291
292=item *
293
63d661c5
FC
294Several cleanups prompted by lack of compatible perlglob.exe
295under Borland (GSAR 27-MAY-97)
296
297=item *
298
08aa1457
PP
299Initial version (GSAR 20-FEB-97)
300
301=back
302
303=head1 SEE ALSO
304
305perl
306
dfb634a9
GS
307perlglob.bat
308
163d180b
GS
309Text::ParseWords
310
08aa1457
PP
311=cut
312