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