PageRenderTime 79ms CodeModel.GetById 27ms app.highlight 48ms RepoModel.GetById 1ms app.codeStats 0ms

/IronPython_Main/Runtime/Tests/LinqDlrTests/testenv/perl/lib/File/DosGlob.pm

#
Perl | 254 lines | 165 code | 54 blank | 35 comment | 40 complexity | dd69935bcc3dfe420bb8e4e8436e5a2f MD5 | raw file
  1#!perl -w
  2
  3#
  4# Documentation at the __END__
  5#
  6
  7package File::DosGlob;
  8
  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 (/^"(.*)"\z/s) {
 23	    $_ = $1;
 24	    if ($cond eq 'd') { push(@retval, $_) if -d $_ }
 25	    else              { push(@retval, $_) if -e $_ }
 26	    next OUTER;
 27	}
 28	# wildcards with a drive prefix such as h:*.pm must be changed
 29	# to h:./*.pm to expand correctly
 30	if (m|^([A-Za-z]:)[^/\\]|s) {
 31	    substr($_,0,2) = $1 . "./";
 32	}
 33	if (m|^(.*)([\\/])([^\\/]*)\z|s) {
 34	    my $tail;
 35	    ($head, $sepchr, $tail) = ($1,$2,$3);
 36	    #print "div: |$head|$sepchr|$tail|\n";
 37	    push (@retval, $_), next OUTER if $tail eq '';
 38	    if ($head =~ /[*?]/) {
 39		@globdirs = doglob('d', $head);
 40		push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
 41		    next OUTER if @globdirs;
 42	    }
 43	    $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s;
 44	    $_ = $tail;
 45	}
 46	#
 47	# If file component has no wildcards, we can avoid opendir
 48	unless (/[*?]/) {
 49	    $head = '' if $head eq '.';
 50	    $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
 51	    $head .= $_;
 52	    if ($cond eq 'd') { push(@retval,$head) if -d $head }
 53	    else              { push(@retval,$head) if -e $head }
 54	    next OUTER;
 55	}
 56	opendir(D, $head) or next OUTER;
 57	my @leaves = readdir D;
 58	closedir D;
 59	$head = '' if $head eq '.';
 60	$head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
 61
 62	# escape regex metachars but not glob chars
 63	s:([].+^\-\${}[|]):\\$1:g;
 64	# and convert DOS-style wildcards to regex
 65	s/\*/.*/g;
 66	s/\?/.?/g;
 67
 68	#print "regex: '$_', head: '$head'\n";
 69	my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }';
 70	warn($@), next OUTER if $@;
 71      INNER:
 72	for my $e (@leaves) {
 73	    next INNER if $e eq '.' or $e eq '..';
 74	    next INNER if $cond eq 'd' and ! -d "$head$e";
 75	    push(@matched, "$head$e"), next INNER if &$matchsub($e);
 76	    #
 77	    # [DOS compatibility special case]
 78	    # Failed, add a trailing dot and try again, but only
 79	    # if name does not have a dot in it *and* pattern
 80	    # has a dot *and* name is shorter than 9 chars.
 81	    #
 82	    if (index($e,'.') == -1 and length($e) < 9
 83	        and index($_,'\\.') != -1) {
 84		push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
 85	    }
 86	}
 87	push @retval, @matched if @matched;
 88    }
 89    return @retval;
 90}
 91
 92#
 93# this can be used to override CORE::glob in a specific
 94# package by saying C<use File::DosGlob 'glob';> in that
 95# namespace.
 96#
 97
 98# context (keyed by second cxix arg provided by core)
 99my %iter;
100my %entries;
101
102sub glob {
103    my $pat = shift;
104    my $cxix = shift;
105    my @pat;
106
107    # glob without args defaults to $_
108    $pat = $_ unless defined $pat;
109
110    # extract patterns
111    if ($pat =~ /\s/) {
112	require Text::ParseWords;
113	@pat = Text::ParseWords::parse_line('\s+',0,$pat);
114    }
115    else {
116	push @pat, $pat;
117    }
118
119    # assume global context if not provided one
120    $cxix = '_G_' unless defined $cxix;
121    $iter{$cxix} = 0 unless exists $iter{$cxix};
122
123    # if we're just beginning, do it all first
124    if ($iter{$cxix} == 0) {
125	$entries{$cxix} = [doglob(1,@pat)];
126    }
127
128    # chuck it all out, quick or slow
129    if (wantarray) {
130	delete $iter{$cxix};
131	return @{delete $entries{$cxix}};
132    }
133    else {
134	if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
135	    return shift @{$entries{$cxix}};
136	}
137	else {
138	    # return undef for EOL
139	    delete $iter{$cxix};
140	    delete $entries{$cxix};
141	    return undef;
142	}
143    }
144}
145
146sub import {
147    my $pkg = shift;
148    return unless @_;
149    my $sym = shift;
150    my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
151    *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
152}
153
1541;
155
156__END__
157
158=head1 NAME
159
160File::DosGlob - DOS like globbing and then some
161
162=head1 SYNOPSIS
163
164    require 5.004;
165
166    # override CORE::glob in current package
167    use File::DosGlob 'glob';
168
169    # override CORE::glob in ALL packages (use with extreme caution!)
170    use File::DosGlob 'GLOBAL_glob';
171
172    @perlfiles = glob  "..\\pe?l/*.p?";
173    print <..\\pe?l/*.p?>;
174
175    # from the command line (overrides only in main::)
176    > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
177
178=head1 DESCRIPTION
179
180A module that implements DOS-like globbing with a few enhancements.
181It is largely compatible with perlglob.exe (the M$ setargv.obj
182version) in all but one respect--it understands wildcards in
183directory components.
184
185For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
186that it will find something like '..\lib\File/DosGlob.pm' alright).
187Note that all path components are case-insensitive, and that
188backslashes and forward slashes are both accepted, and preserved.
189You may have to double the backslashes if you are putting them in
190literally, due to double-quotish parsing of the pattern by perl.
191
192Spaces in the argument delimit distinct patterns, so
193C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
194or C<.dll>.  If you want to put in literal spaces in the glob
195pattern, you can escape them with either double quotes, or backslashes.
196e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
197C<glob('c:/Program\ Files/*/*.dll')>.  The argument is tokenized using
198C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
199of the quoting rules used.
200
201Extending it to csh patterns is left as an exercise to the reader.
202
203=head1 EXPORTS (by request only)
204
205glob()
206
207=head1 BUGS
208
209Should probably be built into the core, and needs to stop
210pandering to DOS habits.  Needs a dose of optimizium too.
211
212=head1 AUTHOR
213
214Gurusamy Sarathy <gsar@activestate.com>
215
216=head1 HISTORY
217
218=over 4
219
220=item *
221
222Support for globally overriding glob() (GSAR 3-JUN-98)
223
224=item *
225
226Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
227
228=item *
229
230A few dir-vs-file optimizations result in glob importation being
23110 times faster than using perlglob.exe, and using perlglob.bat is
232only twice as slow as perlglob.exe (GSAR 28-MAY-97)
233
234=item *
235
236Several cleanups prompted by lack of compatible perlglob.exe
237under Borland (GSAR 27-MAY-97)
238
239=item *
240
241Initial version (GSAR 20-FEB-97)
242
243=back
244
245=head1 SEE ALSO
246
247perl
248
249perlglob.bat
250
251Text::ParseWords
252
253=cut
254