X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FFile%2FDosGlob.pm;h=d7dea7b46cf3af82c2dbc4b48de70daafc4cfe55;hb=f41820981f84708ef067a8bea41c79da755543c1;hp=e0887d122cacc5019f0f0813d6adafa6f9d9cbc8;hpb=08aa1457cd52a368c210ab76a3da91cfadabea1a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/File/DosGlob.pm b/lib/File/DosGlob.pm index e0887d1..d7dea7b 100644 --- a/lib/File/DosGlob.pm +++ b/lib/File/DosGlob.pm @@ -6,21 +6,6 @@ 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 = (); @@ -34,13 +19,18 @@ sub doglob { my $sepchr = '/'; next OUTER unless defined $_ and $_ ne ''; # if arg is within quotes strip em and do no globbing - if (/^"(.*)"$/) { + if (/^"(.*)"\z/s) { $_ = $1; if ($cond eq 'd') { push(@retval, $_) if -d $_ } else { push(@retval, $_) if -e $_ } next OUTER; } - if (m|^(.*)([\\/])([^\\/]*)$|) { + # wildcards with a drive prefix such as h:*.pm must be changed + # to h:./*.pm to expand correctly + if (m|^([A-Za-z]:)[^/\\]|s) { + substr($_,0,2) = $1 . "./"; + } + if (m|^(.*)([\\/])([^\\/]*)\z|s) { my $tail; ($head, $sepchr, $tail) = ($1,$2,$3); #print "div: |$head|$sepchr|$tail|\n"; @@ -50,7 +40,7 @@ sub doglob { push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)), next OUTER if @globdirs; } - $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:$/; + $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s; $_ = $tail; } # @@ -76,7 +66,7 @@ sub doglob { s/\?/.?/g; #print "regex: '$_', head: '$head'\n"; - my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '$|io }'; + my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }'; warn($@), next OUTER if $@; INNER: for my $e (@leaves) { @@ -100,15 +90,64 @@ sub doglob { } # -# this can be used to override CORE::glob -# by saying C. +# this can be used to override CORE::glob in a specific +# package by saying C in that +# namespace. # -sub glob { doglob(1,@_) } + +# context (keyed by second cxix arg provided by core) +my %iter; +my %entries; + +sub glob { + my $pat = shift; + my $cxix = shift; + my @pat; + + # glob without args defaults to $_ + $pat = $_ unless defined $pat; + + # extract patterns + if ($pat =~ /\s/) { + require Text::ParseWords; + @pat = Text::ParseWords::parse_line('\s+',0,$pat); + } + else { + push @pat, $pat; + } + + # assume global context if not provided one + $cxix = '_G_' unless defined $cxix; + $iter{$cxix} = 0 unless exists $iter{$cxix}; + + # if we're just beginning, do it all first + if ($iter{$cxix} == 0) { + $entries{$cxix} = [doglob(1,@pat)]; + } + + # chuck it all out, quick or slow + if (wantarray) { + delete $iter{$cxix}; + return @{delete $entries{$cxix}}; + } + else { + if ($iter{$cxix} = scalar @{$entries{$cxix}}) { + return shift @{$entries{$cxix}}; + } + else { + # return undef for EOL + delete $iter{$cxix}; + delete $entries{$cxix}; + return undef; + } + } +} sub import { my $pkg = shift; - my $callpkg = caller(0); + return unless @_; my $sym = shift; + my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0)); *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob'; } @@ -120,25 +159,26 @@ __END__ 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 + + # override CORE::glob in current package + use File::DosGlob 'glob'; + + # override CORE::glob in ALL packages (use with extreme caution!) + use File::DosGlob 'GLOBAL_glob'; + @perlfiles = glob "..\\pe?l/*.p?"; print <..\\pe?l/*.p?>; - - # from the command line + + # from the command line (overrides only in main::) > 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 +It is largely compatible with perlglob.exe (the M$ setargv.obj version) in all but one respect--it understands wildcards in directory components. @@ -149,13 +189,14 @@ 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. +Spaces in the argument delimit distinct patterns, so +C globs all filenames that end in C<.exe> +or C<.dll>. If you want to put in literal spaces in the glob +pattern, you can escape them with either double quotes, or backslashes. +e.g. C, or +C. The argument is tokenized using +C, so see L for details +of the quoting rules used. Extending it to csh patterns is left as an exercise to the reader. @@ -170,7 +211,7 @@ pandering to DOS habits. Needs a dose of optimizium too. =head1 AUTHOR -Gurusamy Sarathy +Gurusamy Sarathy =head1 HISTORY @@ -178,6 +219,14 @@ Gurusamy Sarathy =item * +Support for globally overriding glob() (GSAR 3-JUN-98) + +=item * + +Scalar context, independent iterator context fixes (GSAR 15-SEP-97) + +=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) @@ -197,5 +246,9 @@ Initial version (GSAR 20-FEB-97) perl +perlglob.bat + +Text::ParseWords + =cut