1#!perl -w 2 3# 4# Documentation at the __END__ 5# 6 7package File::DosGlob; 8 9our $VERSION = '1.12'; 10use strict; 11use warnings; 12 13require XSLoader; 14XSLoader::load(); 15 16sub doglob { 17 my $cond = shift; 18 my @retval = (); 19 my $fix_drive_relative_paths; 20 OUTER: 21 for my $pat (@_) { 22 my @matched = (); 23 my @globdirs = (); 24 my $head = '.'; 25 my $sepchr = '/'; 26 my $tail; 27 next OUTER unless defined $pat and $pat ne ''; 28 # if arg is within quotes strip em and do no globbing 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 } 33 next OUTER; 34 } 35 # wildcards with a drive prefix such as h:*.pm must be changed 36 # to h:./*.pm to expand correctly 37 if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) { 38 substr($pat,0,2) = $1 . "./"; 39 $fix_drive_relative_paths = 1; 40 } 41 if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) { 42 ($head, $sepchr, $tail) = ($1,$2,$3); 43 push (@retval, $pat), next OUTER if $tail eq ''; 44 if ($head =~ /[*?]/) { 45 @globdirs = doglob('d', $head); 46 push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)), 47 next OUTER if @globdirs; 48 } 49 $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s; 50 $pat = $tail; 51 } 52 # 53 # If file component has no wildcards, we can avoid opendir 54 unless ($pat =~ /[*?]/) { 55 $head = '' if $head eq '.'; 56 $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; 57 $head .= $pat; 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; 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 } 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 76 $pat =~ s:([].+^\-\${}()[|]):\\$1:g; 77 # and convert DOS-style wildcards to regex 78 $pat =~ s/\*/.*/g; 79 $pat =~ s/\?/.?/g; 80 81 my $matchsub = sub { $_[0] =~ m|^$pat\z|is }; 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 94 and index($pat,'\\.') != -1) { 95 push(@matched, "$head$e"), next INNER if &$matchsub("$e."); 96 } 97 } 98 push @retval, @matched if @matched; 99 } 100 if ($fix_drive_relative_paths) { 101 s|^([A-Za-z]:)\./|$1| for @retval; 102 } 103 return @retval; 104} 105 106# 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. 110# 111 112# context (keyed by second cxix arg provided by core) 113our %entries; 114 115sub glob { 116 my($pat,$cxix) = ($_[0], _callsite()); 117 my @pat; 118 119 # glob without args defaults to $_ 120 $pat = $_ unless defined $pat; 121 122 # if we're just beginning, do it all first 123 if (!$entries{$cxix}) { 124 # extract patterns 125 if ($pat =~ /\s/) { 126 require Text::ParseWords; 127 @pat = Text::ParseWords::parse_line('\s+',0,$pat); 128 } 129 else { 130 push @pat, $pat; 131 } 132 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. 136 # This was just the easiest way, not nearly the best. 137 REHASH: { 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/ ) { 146 # these expansions will be performed by the original, 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. 159 # How or what should be done about failure is beyond me. 160 } 161 if ( $#appendpat != -1 162 ) { 163 #FIXME: Max loop, no way! :") 164 for ( @appendpat ) { 165 push @pat, $_; 166 } 167 goto REHASH; 168 } 169 } 170 for ( @pat ) { 171 s/\\([{},])/$1/g; 172 } 173 174 $entries{$cxix} = [doglob(1,@pat)]; 175 } 176 177 # chuck it all out, quick or slow 178 if (wantarray) { 179 return @{delete $entries{$cxix}}; 180 } 181 else { 182 if (scalar @{$entries{$cxix}}) { 183 return shift @{$entries{$cxix}}; 184 } 185 else { 186 # return undef for EOL 187 delete $entries{$cxix}; 188 return undef; 189 } 190 } 191} 192 193{ 194 no strict 'refs'; 195 196 sub import { 197 my $pkg = shift; 198 return unless @_; 199 my $sym = shift; 200 my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0)); 201 *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob'; 202 } 203} 2041; 205 206__END__ 207 208=head1 NAME 209 210File::DosGlob - DOS like globbing and then some 211 212=head1 SYNOPSIS 213 214 require 5.004; 215 216 # override CORE::glob in current package 217 use File::DosGlob 'glob'; 218 219 # override CORE::glob in ALL packages (use with extreme caution!) 220 use File::DosGlob 'GLOBAL_glob'; 221 222 @perlfiles = glob "..\\pe?l/*.p?"; 223 print <..\\pe?l/*.p?>; 224 225 # from the command line (overrides only in main::) 226 > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>" 227 228=head1 DESCRIPTION 229 230A module that implements DOS-like globbing with a few enhancements. 231It is largely compatible with perlglob.exe (the M$ setargv.obj 232version) in all but one respect--it understands wildcards in 233directory components. 234 235For example, C<< <..\\l*b\\file/*glob.p?> >> will work as expected (in 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 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 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 260pandering to DOS habits. Needs a dose of optimization too. 261 262=head1 AUTHOR 263 264Gurusamy Sarathy <gsar@activestate.com> 265 266=head1 HISTORY 267 268=over 4 269 270=item * 271 272Support for globally overriding glob() (GSAR 3-JUN-98) 273 274=item * 275 276Scalar context, independent iterator context fixes (GSAR 15-SEP-97) 277 278=item * 279 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 286Several cleanups prompted by lack of compatible perlglob.exe 287under Borland (GSAR 27-MAY-97) 288 289=item * 290 291Initial version (GSAR 20-FEB-97) 292 293=back 294 295=head1 SEE ALSO 296 297perl 298 299perlglob.bat 300 301Text::ParseWords 302 303=cut 304 305