This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
don't use © in Test.pm (suggested by M.J.T. Guy)
[perl5.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;
100
101 # glob without args defaults to $_
102 $pat = $_ unless defined $pat;
103
104 # assume global context if not provided one
105 $cxix = '_G_' unless defined $cxix;
106 $iter{$cxix} = 0 unless exists $iter{$cxix};
107
108 # if we're just beginning, do it all first
109 if ($iter{$cxix} == 0) {
110 $entries{$cxix} = [doglob(1,$pat)];
111 }
112
113 # chuck it all out, quick or slow
114 if (wantarray) {
115 delete $iter{$cxix};
116 return @{delete $entries{$cxix}};
117 }
118 else {
119 if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
120 return shift @{$entries{$cxix}};
121 }
122 else {
123 # return undef for EOL
124 delete $iter{$cxix};
125 delete $entries{$cxix};
126 return undef;
127 }
128 }
129}
08aa1457 130
131sub import {
132 my $pkg = shift;
95d94a4f 133 return unless @_;
08aa1457 134 my $sym = shift;
95d94a4f
GS
135 my $callpkg = ($sym =~ s/^GLOBAL_// ? 'CORE::GLOBAL' : caller(0));
136 *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
08aa1457 137}
138
1391;
140
141__END__
142
143=head1 NAME
144
145File::DosGlob - DOS like globbing and then some
146
08aa1457 147=head1 SYNOPSIS
148
149 require 5.004;
fb73857a 150
151 # override CORE::glob in current package
152 use File::DosGlob 'glob';
153
95d94a4f
GS
154 # override CORE::glob in ALL packages (use with extreme caution!)
155 use File::DosGlob 'GLOBAL_glob';
156
08aa1457 157 @perlfiles = glob "..\\pe?l/*.p?";
158 print <..\\pe?l/*.p?>;
159
fb73857a 160 # from the command line (overrides only in main::)
08aa1457 161 > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
08aa1457 162
163=head1 DESCRIPTION
164
165A module that implements DOS-like globbing with a few enhancements.
dfb634a9 166It is largely compatible with perlglob.exe (the M$ setargv.obj
08aa1457 167version) in all but one respect--it understands wildcards in
168directory components.
169
170For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
171that it will find something like '..\lib\File/DosGlob.pm' alright).
172Note that all path components are case-insensitive, and that
173backslashes and forward slashes are both accepted, and preserved.
174You may have to double the backslashes if you are putting them in
175literally, due to double-quotish parsing of the pattern by perl.
176
08aa1457 177Extending it to csh patterns is left as an exercise to the reader.
178
179=head1 EXPORTS (by request only)
180
181glob()
182
183=head1 BUGS
184
185Should probably be built into the core, and needs to stop
186pandering to DOS habits. Needs a dose of optimizium too.
187
188=head1 AUTHOR
189
190Gurusamy Sarathy <gsar@umich.edu>
191
192=head1 HISTORY
193
194=over 4
195
196=item *
197
95d94a4f
GS
198Support for globally overriding glob() (GSAR 3-JUN-98)
199
200=item *
201
fb73857a 202Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
203
204=item *
205
08aa1457 206A few dir-vs-file optimizations result in glob importation being
20710 times faster than using perlglob.exe, and using perlglob.bat is
208only twice as slow as perlglob.exe (GSAR 28-MAY-97)
209
210=item *
211
212Several cleanups prompted by lack of compatible perlglob.exe
213under Borland (GSAR 27-MAY-97)
214
215=item *
216
217Initial version (GSAR 20-FEB-97)
218
219=back
220
221=head1 SEE ALSO
222
223perl
224
dfb634a9
GS
225perlglob.bat
226
08aa1457 227=cut
228