This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[inseparable changes from changes to perl-5.004_01-mt2]
[perl5.git] / lib / File / DosGlob.pm
CommitLineData
08aa1457 1#!perl -w
2
3#
4# Documentation at the __END__
5#
6
7package File::DosGlob;
8
9unless (caller) {
10 $| = 1;
11 while (@ARGV) {
12 #
13 # We have to do this one by one for compatibility reasons.
14 # If an arg doesn't match anything, we are supposed to return
15 # the original arg. I know, it stinks, eh?
16 #
17 my $arg = shift;
18 my @m = doglob(1,$arg);
19 print (@m ? join("\0", sort @m) : $arg);
20 print "\0" if @ARGV;
21 }
22}
23
24sub doglob {
25 my $cond = shift;
26 my @retval = ();
27 #print "doglob: ", join('|', @_), "\n";
28 OUTER:
29 for my $arg (@_) {
30 local $_ = $arg;
31 my @matched = ();
32 my @globdirs = ();
33 my $head = '.';
34 my $sepchr = '/';
35 next OUTER unless defined $_ and $_ ne '';
36 # if arg is within quotes strip em and do no globbing
37 if (/^"(.*)"$/) {
38 $_ = $1;
39 if ($cond eq 'd') { push(@retval, $_) if -d $_ }
40 else { push(@retval, $_) if -e $_ }
41 next OUTER;
42 }
43 if (m|^(.*)([\\/])([^\\/]*)$|) {
44 my $tail;
45 ($head, $sepchr, $tail) = ($1,$2,$3);
46 #print "div: |$head|$sepchr|$tail|\n";
47 push (@retval, $_), next OUTER if $tail eq '';
48 if ($head =~ /[*?]/) {
49 @globdirs = doglob('d', $head);
50 push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
51 next OUTER if @globdirs;
52 }
53 $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:$/;
54 $_ = $tail;
55 }
56 #
57 # If file component has no wildcards, we can avoid opendir
58 unless (/[*?]/) {
59 $head = '' if $head eq '.';
60 $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
61 $head .= $_;
62 if ($cond eq 'd') { push(@retval,$head) if -d $head }
63 else { push(@retval,$head) if -e $head }
64 next OUTER;
65 }
66 opendir(D, $head) or next OUTER;
67 my @leaves = readdir D;
68 closedir D;
69 $head = '' if $head eq '.';
70 $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
71
72 # escape regex metachars but not glob chars
73 s:([].+^\-\${}[|]):\\$1:g;
74 # and convert DOS-style wildcards to regex
75 s/\*/.*/g;
76 s/\?/.?/g;
77
78 #print "regex: '$_', head: '$head'\n";
79 my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '$|io }';
80 warn($@), next OUTER if $@;
81 INNER:
82 for my $e (@leaves) {
83 next INNER if $e eq '.' or $e eq '..';
84 next INNER if $cond eq 'd' and ! -d "$head$e";
85 push(@matched, "$head$e"), next INNER if &$matchsub($e);
86 #
87 # [DOS compatibility special case]
88 # Failed, add a trailing dot and try again, but only
89 # if name does not have a dot in it *and* pattern
90 # has a dot *and* name is shorter than 9 chars.
91 #
92 if (index($e,'.') == -1 and length($e) < 9
93 and index($_,'\\.') != -1) {
94 push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
95 }
96 }
97 push @retval, @matched if @matched;
98 }
99 return @retval;
100}
101
102#
103# this can be used to override CORE::glob
104# by saying C<use File::DosGlob 'glob';>.
105#
106sub glob { doglob(1,@_) }
107
108sub import {
109 my $pkg = shift;
110 my $callpkg = caller(0);
111 my $sym = shift;
112 *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
113}
114
1151;
116
117__END__
118
119=head1 NAME
120
121File::DosGlob - DOS like globbing and then some
122
123perlglob.bat - a more capable perlglob.exe replacement
124
125=head1 SYNOPSIS
126
127 require 5.004;
128 use File::DosGlob 'glob'; # override CORE::glob
129 @perlfiles = glob "..\\pe?l/*.p?";
130 print <..\\pe?l/*.p?>;
131
132 # from the command line
133 > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
134
135 > perlglob ../pe*/*p?
136
137=head1 DESCRIPTION
138
139A module that implements DOS-like globbing with a few enhancements.
140This file is also a portable replacement for perlglob.exe. It
141is largely compatible with perlglob.exe (the M$ setargv.obj
142version) in all but one respect--it understands wildcards in
143directory components.
144
145For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
146that it will find something like '..\lib\File/DosGlob.pm' alright).
147Note that all path components are case-insensitive, and that
148backslashes and forward slashes are both accepted, and preserved.
149You may have to double the backslashes if you are putting them in
150literally, due to double-quotish parsing of the pattern by perl.
151
152When invoked as a program, it will print null-separated filenames
153to standard output.
154
155While one may replace perlglob.exe with this, usage by overriding
156CORE::glob via importation should be much more efficient, because
157it avoids launching a separate process, and is therefore strongly
158recommended.
159
160Extending it to csh patterns is left as an exercise to the reader.
161
162=head1 EXPORTS (by request only)
163
164glob()
165
166=head1 BUGS
167
168Should probably be built into the core, and needs to stop
169pandering to DOS habits. Needs a dose of optimizium too.
170
171=head1 AUTHOR
172
173Gurusamy Sarathy <gsar@umich.edu>
174
175=head1 HISTORY
176
177=over 4
178
179=item *
180
181A few dir-vs-file optimizations result in glob importation being
18210 times faster than using perlglob.exe, and using perlglob.bat is
183only twice as slow as perlglob.exe (GSAR 28-MAY-97)
184
185=item *
186
187Several cleanups prompted by lack of compatible perlglob.exe
188under Borland (GSAR 27-MAY-97)
189
190=item *
191
192Initial version (GSAR 20-FEB-97)
193
194=back
195
196=head1 SEE ALSO
197
198perl
199
200=cut
201