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