Commit | Line | Data |
---|---|---|
08aa1457 | 1 | #!perl -w |
2 | ||
3 | # | |
4 | # Documentation at the __END__ | |
5 | # | |
6 | ||
7 | package File::DosGlob; | |
8 | ||
08aa1457 | 9 | sub 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) | |
94 | my %iter; | |
95 | my %entries; | |
96 | ||
97 | sub 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 GS |
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 | |
141 | sub import { | |
142 | my $pkg = shift; | |
95d94a4f | 143 | return unless @_; |
08aa1457 | 144 | my $sym = shift; |
95d94a4f GS |
145 | my $callpkg = ($sym =~ s/^GLOBAL_// ? 'CORE::GLOBAL' : caller(0)); |
146 | *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob'; | |
08aa1457 | 147 | } |
148 | ||
149 | 1; | |
150 | ||
151 | __END__ | |
152 | ||
153 | =head1 NAME | |
154 | ||
155 | File::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 GS |
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 | ||
175 | A module that implements DOS-like globbing with a few enhancements. | |
dfb634a9 | 176 | It is largely compatible with perlglob.exe (the M$ setargv.obj |
08aa1457 | 177 | version) in all but one respect--it understands wildcards in |
178 | directory components. | |
179 | ||
180 | For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in | |
181 | that it will find something like '..\lib\File/DosGlob.pm' alright). | |
182 | Note that all path components are case-insensitive, and that | |
183 | backslashes and forward slashes are both accepted, and preserved. | |
184 | You may have to double the backslashes if you are putting them in | |
185 | literally, due to double-quotish parsing of the pattern by perl. | |
186 | ||
163d180b GS |
187 | Spaces in the argument delimit distinct patterns, so |
188 | C<glob('*.exe *.dll')> globs all filenames that end in C<.exe> | |
189 | or C<.dll>. If you want to put in literal spaces in the glob | |
190 | pattern, you can escape them with either double quotes, or backslashes. | |
191 | e.g. C<glob('c:/"Program Files"/*/*.dll')>, or | |
192 | C<glob('c:/Program\ Files/*/*.dll')>. The argument is tokenized using | |
193 | C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details | |
194 | of the quoting rules used. | |
195 | ||
08aa1457 | 196 | Extending it to csh patterns is left as an exercise to the reader. |
197 | ||
198 | =head1 EXPORTS (by request only) | |
199 | ||
200 | glob() | |
201 | ||
202 | =head1 BUGS | |
203 | ||
204 | Should probably be built into the core, and needs to stop | |
205 | pandering to DOS habits. Needs a dose of optimizium too. | |
206 | ||
207 | =head1 AUTHOR | |
208 | ||
209 | Gurusamy Sarathy <gsar@umich.edu> | |
210 | ||
211 | =head1 HISTORY | |
212 | ||
213 | =over 4 | |
214 | ||
215 | =item * | |
216 | ||
95d94a4f GS |
217 | Support for globally overriding glob() (GSAR 3-JUN-98) |
218 | ||
219 | =item * | |
220 | ||
fb73857a | 221 | Scalar context, independent iterator context fixes (GSAR 15-SEP-97) |
222 | ||
223 | =item * | |
224 | ||
08aa1457 | 225 | A few dir-vs-file optimizations result in glob importation being |
226 | 10 times faster than using perlglob.exe, and using perlglob.bat is | |
227 | only twice as slow as perlglob.exe (GSAR 28-MAY-97) | |
228 | ||
229 | =item * | |
230 | ||
231 | Several cleanups prompted by lack of compatible perlglob.exe | |
232 | under Borland (GSAR 27-MAY-97) | |
233 | ||
234 | =item * | |
235 | ||
236 | Initial version (GSAR 20-FEB-97) | |
237 | ||
238 | =back | |
239 | ||
240 | =head1 SEE ALSO | |
241 | ||
242 | perl | |
243 | ||
dfb634a9 GS |
244 | perlglob.bat |
245 | ||
163d180b GS |
246 | Text::ParseWords |
247 | ||
08aa1457 | 248 | =cut |
249 |