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