| [ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 #!perl -w 2 3 # use strict fails 4 #Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191. 5 6 # 7 # Documentation at the __END__ 8 # 9 10 package File::DosGlob; 11 12 our $VERSION = '1.00'; 13 use strict; 14 use warnings; 15 16 sub doglob { 17 my $cond = shift; 18 my @retval = (); 19 #print "doglob: ", join('|', @_), "\n"; 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($_,0,2) = $1 . "./"; 39 } 40 if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) { 41 ($head, $sepchr, $tail) = ($1,$2,$3); 42 #print "div: |$head|$sepchr|$tail|\n"; 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 $head = '' if $head eq '.'; 66 $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; 67 68 # escape regex metachars but not glob chars 69 $pat =~ s:([].+^\-\${}[|]):\\$1:g; 70 # and convert DOS-style wildcards to regex 71 $pat =~ s/\*/.*/g; 72 $pat =~ s/\?/.?/g; 73 74 #print "regex: '$pat', head: '$head'\n"; 75 my $matchsub = sub { $_[0] =~ m|^$pat\z|is }; 76 INNER: 77 for my $e (@leaves) { 78 next INNER if $e eq '.' or $e eq '..'; 79 next INNER if $cond eq 'd' and ! -d "$head$e"; 80 push(@matched, "$head$e"), next INNER if &$matchsub($e); 81 # 82 # [DOS compatibility special case] 83 # Failed, add a trailing dot and try again, but only 84 # if name does not have a dot in it *and* pattern 85 # has a dot *and* name is shorter than 9 chars. 86 # 87 if (index($e,'.') == -1 and length($e) < 9 88 and index($pat,'\\.') != -1) { 89 push(@matched, "$head$e"), next INNER if &$matchsub("$e."); 90 } 91 } 92 push @retval, @matched if @matched; 93 } 94 return @retval; 95 } 96 97 98 # 99 # Do DOS-like globbing on Mac OS 100 # 101 sub doglob_Mac { 102 my $cond = shift; 103 my @retval = (); 104 105 #print "doglob_Mac: ", join('|', @_), "\n"; 106 OUTER: 107 for my $arg (@_) { 108 local $_ = $arg; 109 my @matched = (); 110 my @globdirs = (); 111 my $head = ':'; 112 my $not_esc_head = $head; 113 my $sepchr = ':'; 114 next OUTER unless defined $_ and $_ ne ''; 115 # if arg is within quotes strip em and do no globbing 116 if (/^"(.*)"\z/s) { 117 $_ = $1; 118 # $_ may contain escaped metachars '\*', '\?' and '\' 119 my $not_esc_arg = $_; 120 $not_esc_arg =~ s/\\([*?\\])/$1/g; 121 if ($cond eq 'd') { push(@retval, $not_esc_arg) if -d $not_esc_arg } 122 else { push(@retval, $not_esc_arg) if -e $not_esc_arg } 123 next OUTER; 124 } 125 126 if (m|^(.*?)(:+)([^:]*)\z|s) { # note: $1 is not greedy 127 my $tail; 128 ($head, $sepchr, $tail) = ($1,$2,$3); 129 #print "div: |$head|$sepchr|$tail|\n"; 130 push (@retval, $_), next OUTER if $tail eq ''; 131 # 132 # $head may contain escaped metachars '\*' and '\?' 133 134 my $tmp_head = $head; 135 # if a '*' or '?' is preceded by an odd count of '\', temporary delete 136 # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as 137 # wildcards 138 $tmp_head =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg; 139 140 if ($tmp_head =~ /[*?]/) { # if there are wildcards ... 141 @globdirs = doglob_Mac('d', $head); 142 push(@retval, doglob_Mac($cond, map {"$_$sepchr$tail"} @globdirs)), 143 next OUTER if @globdirs; 144 } 145 146 $head .= $sepchr; 147 $not_esc_head = $head; 148 # unescape $head for file operations 149 $not_esc_head =~ s/\\([*?\\])/$1/g; 150 $_ = $tail; 151 } 152 # 153 # If file component has no wildcards, we can avoid opendir 154 155 my $tmp_tail = $_; 156 # if a '*' or '?' is preceded by an odd count of '\', temporary delete 157 # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as 158 # wildcards 159 $tmp_tail =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg; 160 161 unless ($tmp_tail =~ /[*?]/) { # if there are wildcards ... 162 $not_esc_head = $head = '' if $head eq ':'; 163 my $not_esc_tail = $_; 164 # unescape $head and $tail for file operations 165 $not_esc_tail =~ s/\\([*?\\])/$1/g; 166 $head .= $_; 167 $not_esc_head .= $not_esc_tail; 168 if ($cond eq 'd') { push(@retval,$head) if -d $not_esc_head } 169 else { push(@retval,$head) if -e $not_esc_head } 170 next OUTER; 171 } 172 #print "opendir($not_esc_head)\n"; 173 opendir(D, $not_esc_head) or next OUTER; 174 my @leaves = readdir D; 175 closedir D; 176 177 # escape regex metachars but not '\' and glob chars '*', '?' 178 $_ =~ s:([].+^\-\${}[|]):\\$1:g; 179 # and convert DOS-style wildcards to regex, 180 # but only if they are not escaped 181 $_ =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg; 182 183 #print "regex: '$_', head: '$head', unescaped head: '$not_esc_head'\n"; 184 my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }'; 185 warn($@), next OUTER if $@; 186 INNER: 187 for my $e (@leaves) { 188 next INNER if $e eq '.' or $e eq '..'; 189 next INNER if $cond eq 'd' and ! -d "$not_esc_head$e"; 190 191 if (&$matchsub($e)) { 192 my $leave = (($not_esc_head eq ':') && (-f "$not_esc_head$e")) ? 193 "$e" : "$not_esc_head$e"; 194 # 195 # On Mac OS, the two glob metachars '*' and '?' and the escape 196 # char '\' are valid characters for file and directory names. 197 # We have to escape and treat them specially. 198 $leave =~ s|([*?\\])|\\$1|g; 199 push(@matched, $leave); 200 next INNER; 201 } 202 } 203 push @retval, @matched if @matched; 204 } 205 return @retval; 206 } 207 208 # 209 # _expand_volume() will only be used on Mac OS (Classic): 210 # Takes an array of original patterns as argument and returns an array of 211 # possibly modified patterns. Each original pattern is processed like 212 # that: 213 # + If there's a volume name in the pattern, we push a separate pattern 214 # for each mounted volume that matches (with '*', '?' and '\' escaped). 215 # + If there's no volume name in the original pattern, it is pushed 216 # unchanged. 217 # Note that the returned array of patterns may be empty. 218 # 219 sub _expand_volume { 220 221 require MacPerl; # to be verbose 222 223 my @pat = @_; 224 my @new_pat = (); 225 my @FSSpec_Vols = MacPerl::Volumes(); 226 my @mounted_volumes = (); 227 228 foreach my $spec_vol (@FSSpec_Vols) { 229 # push all mounted volumes into array 230 push @mounted_volumes, MacPerl::MakePath($spec_vol); 231 } 232 #print "mounted volumes: |@mounted_volumes|\n"; 233 234 while (@pat) { 235 my $pat = shift @pat; 236 if ($pat =~ /^([^:]+:)(.*)\z/) { # match a volume name? 237 my $vol_pat = $1; 238 my $tail = $2; 239 # 240 # escape regex metachars but not '\' and glob chars '*', '?' 241 $vol_pat =~ s:([].+^\-\${}[|]):\\$1:g; 242 # and convert DOS-style wildcards to regex, 243 # but only if they are not escaped 244 $vol_pat =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg; 245 #print "volume regex: '$vol_pat' \n"; 246 247 foreach my $volume (@mounted_volumes) { 248 if ($volume =~ m|^$vol_pat\z|ios) { 249 # 250 # On Mac OS, the two glob metachars '*' and '?' and the 251 # escape char '\' are valid characters for volume names. 252 # We have to escape and treat them specially. 253 $volume =~ s|([*?\\])|\\$1|g; 254 push @new_pat, $volume . $tail; 255 } 256 } 257 } else { # no volume name in pattern, push original pattern 258 push @new_pat, $pat; 259 } 260 } 261 return @new_pat; 262 } 263 264 265 # 266 # _preprocess_pattern() will only be used on Mac OS (Classic): 267 # Resolves any updirs in the pattern. Removes a single trailing colon 268 # from the pattern, unless it's a volume name pattern like "*HD:" 269 # 270 sub _preprocess_pattern { 271 my @pat = @_; 272 273 foreach my $p (@pat) { 274 my $proceed; 275 # resolve any updirs, e.g. "*HD:t?p::a*" -> "*HD:a*" 276 do { 277 $proceed = ($p =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/); 278 } while ($proceed); 279 # remove a single trailing colon, e.g. ":*:" -> ":*" 280 $p =~ s/:([^:]+):\z/:$1/; 281 } 282 return @pat; 283 } 284 285 286 # 287 # _un_escape() will only be used on Mac OS (Classic): 288 # Unescapes a list of arguments which may contain escaped 289 # metachars '*', '?' and '\'. 290 # 291 sub _un_escape { 292 foreach (@_) { 293 s/\\([*?\\])/$1/g; 294 } 295 return @_; 296 } 297 298 # 299 # this can be used to override CORE::glob in a specific 300 # package by saying C<use File::DosGlob 'glob';> in that 301 # namespace. 302 # 303 304 # context (keyed by second cxix arg provided by core) 305 my %iter; 306 my %entries; 307 308 sub glob { 309 my($pat,$cxix) = @_; 310 my @pat; 311 312 # glob without args defaults to $_ 313 $pat = $_ unless defined $pat; 314 315 # extract patterns 316 if ($pat =~ /\s/) { 317 require Text::ParseWords; 318 @pat = Text::ParseWords::parse_line('\s+',0,$pat); 319 } 320 else { 321 push @pat, $pat; 322 } 323 324 # Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3. 325 # abc3 will be the original {3} (and drop the {}). 326 # abc1 abc2 will be put in @appendpat. 327 # This was just the esiest way, not nearly the best. 328 REHASH: { 329 my @appendpat = (); 330 for (@pat) { 331 # There must be a "," I.E. abc{efg} is not what we want. 332 while ( /^(.*)(?<!\\)\{(.*?)(?<!\\)\,.*?(?<!\\)\}(.*)$/ ) { 333 my ($start, $match, $end) = ($1, $2, $3); 334 #print "Got: \n\t$start\n\t$match\n\t$end\n"; 335 my $tmp = "$start$match$end"; 336 while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) { 337 #print "Striped: $tmp\n"; 338 # these expanshions will be preformed by the original, 339 # when we call REHASH. 340 } 341 push @appendpat, ("$tmp"); 342 s/^\Q$start\E(?<!\\)\{\Q$match\E(?<!\\)\,/$start\{/; 343 if ( /^\Q$start\E(?<!\\)\{(?!.*?(?<!\\)\,.*?\Q$end\E$)(.*)(?<!\\)\}\Q$end\E$/ ) { 344 $match = $1; 345 #print "GOT: \n\t$start\n\t$match\n\t$end\n\n"; 346 $_ = "$start$match$end"; 347 } 348 } 349 #print "Sould have "GOT" vs "Got"!\n"; 350 #FIXME: There should be checking for this. 351 # How or what should be done about failure is beond me. 352 } 353 if ( $#appendpat != -1 354 ) { 355 #print "LOOP\n"; 356 #FIXME: Max loop, no way! :") 357 for ( @appendpat ) { 358 push @pat, $_; 359 } 360 goto REHASH; 361 } 362 } 363 for ( @pat ) { 364 s/\\{/{/g; 365 s/\\}/}/g; 366 s/\\,/,/g; 367 } 368 #print join ("\n", @pat). "\n"; 369 370 # assume global context if not provided one 371 $cxix = '_G_' unless defined $cxix; 372 $iter{$cxix} = 0 unless exists $iter{$cxix}; 373 374 # if we're just beginning, do it all first 375 if ($iter{$cxix} == 0) { 376 if ($^O eq 'MacOS') { 377 # first, take care of updirs and trailing colons 378 @pat = _preprocess_pattern(@pat); 379 # expand volume names 380 @pat = _expand_volume(@pat); 381 $entries{$cxix} = (@pat) ? [_un_escape( doglob_Mac(1,@pat) )] : [()]; 382 } else { 383 $entries{$cxix} = [doglob(1,@pat)]; 384 } 385 } 386 387 # chuck it all out, quick or slow 388 if (wantarray) { 389 delete $iter{$cxix}; 390 return @{delete $entries{$cxix}}; 391 } 392 else { 393 if ($iter{$cxix} = scalar @{$entries{$cxix}}) { 394 return shift @{$entries{$cxix}}; 395 } 396 else { 397 # return undef for EOL 398 delete $iter{$cxix}; 399 delete $entries{$cxix}; 400 return undef; 401 } 402 } 403 } 404 405 { 406 no strict 'refs'; 407 408 sub import { 409 my $pkg = shift; 410 return unless @_; 411 my $sym = shift; 412 my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0)); 413 *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob'; 414 } 415 } 416 1; 417 418 __END__ 419 420 =head1 NAME 421 422 File::DosGlob - DOS like globbing and then some 423 424 =head1 SYNOPSIS 425 426 require 5.004; 427 428 # override CORE::glob in current package 429 use File::DosGlob 'glob'; 430 431 # override CORE::glob in ALL packages (use with extreme caution!) 432 use File::DosGlob 'GLOBAL_glob'; 433 434 @perlfiles = glob "..\\pe?l/*.p?"; 435 print <..\\pe?l/*.p?>; 436 437 # from the command line (overrides only in main::) 438 > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>" 439 440 =head1 DESCRIPTION 441 442 A module that implements DOS-like globbing with a few enhancements. 443 It is largely compatible with perlglob.exe (the M$ setargv.obj 444 version) in all but one respect--it understands wildcards in 445 directory components. 446 447 For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in 448 that it will find something like '..\lib\File/DosGlob.pm' alright). 449 Note that all path components are case-insensitive, and that 450 backslashes and forward slashes are both accepted, and preserved. 451 You may have to double the backslashes if you are putting them in 452 literally, due to double-quotish parsing of the pattern by perl. 453 454 Spaces in the argument delimit distinct patterns, so 455 C<glob('*.exe *.dll')> globs all filenames that end in C<.exe> 456 or C<.dll>. If you want to put in literal spaces in the glob 457 pattern, you can escape them with either double quotes, or backslashes. 458 e.g. C<glob('c:/"Program Files"/*/*.dll')>, or 459 C<glob('c:/Program\ Files/*/*.dll')>. The argument is tokenized using 460 C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details 461 of the quoting rules used. 462 463 Extending it to csh patterns is left as an exercise to the reader. 464 465 =head1 NOTES 466 467 =over 4 468 469 =item * 470 471 Mac OS (Classic) users should note a few differences. The specification 472 of pathnames in glob patterns adheres to the usual Mac OS conventions: 473 The path separator is a colon ':', not a slash '/' or backslash '\'. A 474 full path always begins with a volume name. A relative pathname on Mac 475 OS must always begin with a ':', except when specifying a file or 476 directory name in the current working directory, where the leading colon 477 is optional. If specifying a volume name only, a trailing ':' is 478 required. Due to these rules, a glob like E<lt>*:E<gt> will find all 479 mounted volumes, while a glob like E<lt>*E<gt> or E<lt>:*E<gt> will find 480 all files and directories in the current directory. 481 482 Note that updirs in the glob pattern are resolved before the matching begins, 483 i.e. a pattern like "*HD:t?p::a*" will be matched as "*HD:a*". Note also, 484 that a single trailing ':' in the pattern is ignored (unless it's a volume 485 name pattern like "*HD:"), i.e. a glob like <:*:> will find both directories 486 I<and> files (and not, as one might expect, only directories). 487 488 The metachars '*', '?' and the escape char '\' are valid characters in 489 volume, directory and file names on Mac OS. Hence, if you want to match 490 a '*', '?' or '\' literally, you have to escape these characters. Due to 491 perl's quoting rules, things may get a bit complicated, when you want to 492 match a string like '\*' literally, or when you want to match '\' literally, 493 but treat the immediately following character '*' as metachar. So, here's a 494 rule of thumb (applies to both single- and double-quoted strings): escape 495 each '*' or '?' or '\' with a backslash, if you want to treat them literally, 496 and then double each backslash and your are done. E.g. 497 498 - Match '\*' literally 499 500 escape both '\' and '*' : '\\\*' 501 double the backslashes : '\\\\\\*' 502 503 (Internally, the glob routine sees a '\\\*', which means that both '\' and 504 '*' are escaped.) 505 506 507 - Match '\' literally, treat '*' as metachar 508 509 escape '\' but not '*' : '\\*' 510 double the backslashes : '\\\\*' 511 512 (Internally, the glob routine sees a '\\*', which means that '\' is escaped and 513 '*' is not.) 514 515 Note that you also have to quote literal spaces in the glob pattern, as described 516 above. 517 518 =back 519 520 =head1 EXPORTS (by request only) 521 522 glob() 523 524 =head1 BUGS 525 526 Should probably be built into the core, and needs to stop 527 pandering to DOS habits. Needs a dose of optimizium too. 528 529 =head1 AUTHOR 530 531 Gurusamy Sarathy <gsar@activestate.com> 532 533 =head1 HISTORY 534 535 =over 4 536 537 =item * 538 539 Support for globally overriding glob() (GSAR 3-JUN-98) 540 541 =item * 542 543 Scalar context, independent iterator context fixes (GSAR 15-SEP-97) 544 545 =item * 546 547 A few dir-vs-file optimizations result in glob importation being 548 10 times faster than using perlglob.exe, and using perlglob.bat is 549 only twice as slow as perlglob.exe (GSAR 28-MAY-97) 550 551 =item * 552 553 Several cleanups prompted by lack of compatible perlglob.exe 554 under Borland (GSAR 27-MAY-97) 555 556 =item * 557 558 Initial version (GSAR 20-FEB-97) 559 560 =back 561 562 =head1 SEE ALSO 563 564 perl 565 566 perlglob.bat 567 568 Text::ParseWords 569 570 =cut 571
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
| Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |