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