lib/File/Find.pm

   1 package File::Find;
   2 use 5.006;
   3 use strict;
   4 use warnings;
   5 use warnings::register;
   6 our $VERSION = '1.06';
   7 require Exporter;
   8 require Cwd;
   9
  10 #
  11 # Modified to ensure sub-directory traversal order is not inverded by stack
  12 # push and pops.  That is remains in the same order as in the directory file,
  13 # or user pre-processing (EG:sorted).
  14 #
  15
  16 =head1 NAME
  17
  18 File::Find - Traverse a directory tree.
  19
  20 =head1 SYNOPSIS
  21
  22     use File::Find;
  23     find(\&wanted, @directories_to_search);
  24     sub wanted { ... }
  25
  26     use File::Find;
  27     finddepth(\&wanted, @directories_to_search);
  28     sub wanted { ... }
  29
  30     use File::Find;
  31     find({ wanted => \&process, follow => 1 }, '.');
  32
  33 =head1 DESCRIPTION
  34
  35 These are functions for searching through directory trees doing work
  36 on each file found similar to the Unix I<find> command.  File::Find
  37 exports two functions, C<find> and C<finddepth>.  They work similarly
  38 but have subtle differences.
  39
  40 =over 4
  41
  42 =item B<find>
  43
  44   find(\&wanted,  @directories);
  45   find(\%options, @directories);
  46
  47 C<find()> does a depth-first search over the given C<@directories> in
  48 the order they are given.  For each file or directory found, it calls
  49 the C<&wanted> subroutine.  (See below for details on how to use the
  50 C<&wanted> function).  Additionally, for each directory found, it will
  51 C<chdir()> into that directory and continue the search, invoking the
  52 C<&wanted> function on each file or subdirectory in the directory.
  53
  54 =item B<finddepth>
  55
  56   finddepth(\&wanted,  @directories);
  57   finddepth(\%options, @directories);
  58
  59 C<finddepth()> works just like C<find()> except that is invokes the
  60 C<&wanted> function for a directory I<after> invoking it for the
  61 directory's contents.  It does a postorder traversal instead of a
  62 preorder traversal, working from the bottom of the directory tree up
  63 where C<find()> works from the top of the tree down.
  64
  65 =back
  66
  67 =head2 %options
  68
  69 The first argument to C<find()> is either a code reference to your
  70 C<&wanted> function, or a hash reference describing the operations
  71 to be performed for each file.  The
  72 code reference is described in L<The wanted function> below.
  73
  74 Here are the possible keys for the hash:
  75
  76 =over 3
  77
  78 =item C<wanted>
  79
  80 The value should be a code reference.  This code reference is
  81 described in L<The wanted function> below.
  82
  83 =item C<bydepth>
  84
  85 Reports the name of a directory only AFTER all its entries
  86 have been reported.  Entry point C<finddepth()> is a shortcut for
  87 specifying C<<{ bydepth => 1 }>> in the first argument of C<find()>.
  88
  89 =item C<preprocess>
  90
  91 The value should be a code reference. This code reference is used to
  92 preprocess the current directory. The name of the currently processed
  93 directory is in C<$File::Find::dir>. Your preprocessing function is
  94 called after C<readdir()>, but before the loop that calls the C<wanted()>
  95 function. It is called with a list of strings (actually file/directory
  96 names) and is expected to return a list of strings. The code can be
  97 used to sort the file/directory names alphabetically, numerically,
  98 or to filter out directory entries based on their name alone. When
  99 I<follow> or I<follow_fast> are in effect, C<preprocess> is a no-op.
 100
 101 =item C<postprocess>
 102
 103 The value should be a code reference. It is invoked just before leaving
 104 the currently processed directory. It is called in void context with no
 105 arguments. The name of the current directory is in C<$File::Find::dir>. This
 106 hook is handy for summarizing a directory, such as calculating its disk
 107 usage. When I<follow> or I<follow_fast> are in effect, C<postprocess> is a
 108 no-op.
 109
 110 =item C<follow>
 111
 112 Causes symbolic links to be followed. Since directory trees with symbolic
 113 links (followed) may contain files more than once and may even have
 114 cycles, a hash has to be built up with an entry for each file.
 115 This might be expensive both in space and time for a large
 116 directory tree. See I<follow_fast> and I<follow_skip> below.
 117 If either I<follow> or I<follow_fast> is in effect:
 118
 119 =over 6
 120
 121 =item *
 122
 123 It is guaranteed that an I<lstat> has been called before the user's
 124 C<wanted()> function is called. This enables fast file checks involving S< _>.
 125
 126 =item *
 127
 128 There is a variable C<$File::Find::fullname> which holds the absolute
 129 pathname of the file with all symbolic links resolved
 130
 131 =back
 132
 133 =item C<follow_fast>
 134
 135 This is similar to I<follow> except that it may report some files more
 136 than once.  It does detect cycles, however.  Since only symbolic links
 137 have to be hashed, this is much cheaper both in space and time.  If
 138 processing a file more than once (by the user's C<wanted()> function)
 139 is worse than just taking time, the option I<follow> should be used.
 140
 141 =item C<follow_skip>
 142
 143 C<follow_skip==1>, which is the default, causes all files which are
 144 neither directories nor symbolic links to be ignored if they are about
 145 to be processed a second time. If a directory or a symbolic link
 146 are about to be processed a second time, File::Find dies.
 147
 148 C<follow_skip==0> causes File::Find to die if any file is about to be
 149 processed a second time.
 150
 151 C<follow_skip==2> causes File::Find to ignore any duplicate files and
 152 directories but to proceed normally otherwise.
 153
 154 =item C<dangling_symlinks>
 155
 156 If true and a code reference, will be called with the symbolic link
 157 name and the directory it lives in as arguments.  Otherwise, if true
 158 and warnings are on, warning "symbolic_link_name is a dangling
 159 symbolic link\n" will be issued.  If false, the dangling symbolic link
 160 will be silently ignored.
 161
 162 =item C<no_chdir>
 163
 164 Does not C<chdir()> to each directory as it recurses. The C<wanted()>
 165 function will need to be aware of this, of course. In this case,
 166 C<$_> will be the same as C<$File::Find::name>.
 167
 168 =item C<untaint>
 169
 170 If find is used in taint-mode (-T command line switch or if EUID != UID
 171 or if EGID != GID) then internally directory names have to be untainted
 172 before they can be chdir'ed to. Therefore they are checked against a regular
 173 expression I<untaint_pattern>.  Note that all names passed to the user's
 174 I<wanted()> function are still tainted. If this option is used while
 175 not in taint-mode, C<untaint> is a no-op.
 176
 177 =item C<untaint_pattern>
 178
 179 See above. This should be set using the C<qr> quoting operator.
 180 The default is set to  C<qr|^([-+@\w./]+)$|>.
 181 Note that the parentheses are vital.
 182
 183 =item C<untaint_skip>
 184
 185 If set, a directory which fails the I<untaint_pattern> is skipped,
 186 including all its sub-directories. The default is to 'die' in such a case.
 187
 188 =back
 189
 190 =head2 The wanted function
 191
 192 The C<wanted()> function does whatever verifications you want on
 193 each file and directory.  Note that despite its name, the C<wanted()>
 194 function is a generic callback function, and does B<not> tell
 195 File::Find if a file is "wanted" or not.  In fact, its return value
 196 is ignored.
 197
 198 The wanted function takes no arguments but rather does its work
 199 through a collection of variables.
 200
 201 =over 4
 202
 203 =item C<$File::Find::dir> is the current directory name,
 204
 205 =item C<$_> is the current filename within that directory
 206
 207 =item C<$File::Find::name> is the complete pathname to the file.
 208
 209 =back
 210
 211 Don't modify these variables.
 212
 213 For example, when examining the file F</some/path/foo.ext> you will have:
 214
 215     $File::Find::dir  = /some/path/
 216     $_                = foo.ext
 217     $File::Find::name = /some/path/foo.ext
 218
 219 You are chdir()'d toC<$File::Find::dir> when the function is called,
 220 unless C<no_chdir> was specified. Note that when changing to
 221 directories is in effect the root directory (F</>) is a somewhat
 222 special case inasmuch as the concatenation of C<$File::Find::dir>,
 223 C<'/'> and C<$_> is not literally equal to C<$File::Find::name>. The
 224 table below summarizes all variants:
 225
 226               $File::Find::name  $File::Find::dir  $_
 227  default      /                  /                 .
 228  no_chdir=>0  /etc               /                 etc
 229               /etc/x             /etc              x
 230
 231  no_chdir=>1  /                  /                 /
 232               /etc               /                 /etc
 233               /etc/x             /etc              /etc/x
 234
 235
 236 When <follow> or <follow_fast> are in effect, there is
 237 also a C<$File::Find::fullname>.  The function may set
 238 C<$File::Find::prune> to prune the tree unless C<bydepth> was
 239 specified.  Unless C<follow> or C<follow_fast> is specified, for
 240 compatibility reasons (find.pl, find2perl) there are in addition the
 241 following globals available: C<$File::Find::topdir>,
 242 C<$File::Find::topdev>, C<$File::Find::topino>,
 243 C<$File::Find::topmode> and C<$File::Find::topnlink>.
 244
 245 This library is useful for the C<find2perl> tool, which when fed,
 246
 247     find2perl / -name .nfs\* -mtime +7 \
 248         -exec rm -f {} \; -o -fstype nfs -prune
 249
 250 produces something like:
 251
 252     sub wanted {
 253         /^\.nfs.*\z/s &&
 254         (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_)) &&
 255         int(-M _) > 7 &&
 256         unlink($_)
 257         ||
 258         ($nlink || (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))) &&
 259         $dev < 0 &&
 260         ($File::Find::prune = 1);
 261     }
 262
 263 Notice the C<_> in the above C<int(-M _)>: the C<_> is a magical
 264 filehandle that caches the information from the preceding
 265 C<stat()>, C<lstat()>, or filetest.
 266
 267 Here's another interesting wanted function.  It will find all symbolic
 268 links that don't resolve:
 269
 270     sub wanted {
 271          -l && !-e && print "bogus link: $File::Find::name\n";
 272     }
 273
 274 See also the script C<pfind> on CPAN for a nice application of this
 275 module.
 276
 277 =head1 WARNINGS
 278
 279 If you run your program with the C<-w> switch, or if you use the
 280 C<warnings> pragma, File::Find will report warnings for several weird
 281 situations. You can disable these warnings by putting the statement
 282
 283     no warnings 'File::Find';
 284
 285 in the appropriate scope. See L<perllexwarn> for more info about lexical
 286 warnings.
 287
 288 =head1 CAVEAT
 289
 290 =over 2
 291
 292 =item $dont_use_nlink
 293
 294 You can set the variable C<$File::Find::dont_use_nlink> to 1, if you want to
 295 force File::Find to always stat directories. This was used for file systems
 296 that do not have an C<nlink> count matching the number of sub-directories.
 297 Examples are ISO-9660 (CD-ROM), AFS, HPFS (OS/2 file system), FAT (DOS file
 298 system) and a couple of others.
 299
 300 You shouldn't need to set this variable, since File::Find should now detect
 301 such file systems on-the-fly and switch itself to using stat. This works even
 302 for parts of your file system, like a mounted CD-ROM.
 303
 304 If you do set C<$File::Find::dont_use_nlink> to 1, you will notice slow-downs.
 305
 306 =item symlinks
 307
 308 Be aware that the option to follow symbolic links can be dangerous.
 309 Depending on the structure of the directory tree (including symbolic
 310 links to directories) you might traverse a given (physical) directory
 311 more than once (only if C<follow_fast> is in effect).
 312 Furthermore, deleting or changing files in a symbolically linked directory
 313 might cause very unpleasant surprises, since you delete or change files
 314 in an unknown directory.
 315
 316 =back
 317
 318 =head1 NOTES
 319
 320 =over 4
 321
 322 =item *
 323
 324 Mac OS (Classic) users should note a few differences:
 325
 326 =over 4
 327
 328 =item *
 329
 330 The path separator is ':', not '/', and the current directory is denoted
 331 as ':', not '.'. You should be careful about specifying relative pathnames.
 332 While a full path always begins with a volume name, a relative pathname
 333 should always begin with a ':'.  If specifying a volume name only, a
 334 trailing ':' is required.
 335
 336 =item *
 337
 338 C<$File::Find::dir> is guaranteed to end with a ':'. If C<$_>
 339 contains the name of a directory, that name may or may not end with a
 340 ':'. Likewise, C<$File::Find::name>, which contains the complete
 341 pathname to that directory, and C<$File::Find::fullname>, which holds
 342 the absolute pathname of that directory with all symbolic links resolved,
 343 may or may not end with a ':'.
 344
 345 =item *
 346
 347 The default C<untaint_pattern> (see above) on Mac OS is set to
 348 C<qr|^(.+)$|>. Note that the parentheses are vital.
 349
 350 =item *
 351
 352 The invisible system file "Icon\015" is ignored. While this file may
 353 appear in every directory, there are some more invisible system files
 354 on every volume, which are all located at the volume root level (i.e.
 355 "MacintoshHD:"). These system files are B<not> excluded automatically.
 356 Your filter may use the following code to recognize invisible files or
 357 directories (requires Mac::Files):
 358
 359  use Mac::Files;
 360
 361  # invisible() --  returns 1 if file/directory is invisible,
 362  # 0 if it's visible or undef if an error occurred
 363
 364  sub invisible($) {
 365    my $file = shift;
 366    my ($fileCat, $fileInfo);
 367    my $invisible_flag =  1 << 14;
 368
 369    if ( $fileCat = FSpGetCatInfo($file) ) {
 370      if ($fileInfo = $fileCat->ioFlFndrInfo() ) {
 371        return (($fileInfo->fdFlags & $invisible_flag) && 1);
 372      }
 373    }
 374    return undef;
 375  }
 376
 377 Generally, invisible files are system files, unless an odd application
 378 decides to use invisible files for its own purposes. To distinguish
 379 such files from system files, you have to look at the B<type> and B<creator>
 380 file attributes. The MacPerl built-in functions C<GetFileInfo(FILE)> and
 381 C<SetFileInfo(CREATOR, TYPE, FILES)> offer access to these attributes
 382 (see MacPerl.pm for details).
 383
 384 Files that appear on the desktop actually reside in an (hidden) directory
 385 named "Desktop Folder" on the particular disk volume. Note that, although
 386 all desktop files appear to be on the same "virtual" desktop, each disk
 387 volume actually maintains its own "Desktop Folder" directory.
 388
 389 =back
 390
 391 =back
 392
 393 =head1 BUGS AND CAVEATS
 394
 395 Despite the name of the C<finddepth()> function, both C<find()> and
 396 C<finddepth()> perform a depth-first search of the directory
 397 hierarchy.
 398
 399 =head1 HISTORY
 400
 401 File::Find used to produce incorrect results if called recursively.
 402 During the development of perl 5.8 this bug was fixed.
 403 The first fixed version of File::Find was 1.01.
 404
 405 =cut
 406
 407 our @ISA = qw(Exporter);
 408 our @EXPORT = qw(find finddepth);
 409
 410
 411 use strict;
 412 my $Is_VMS;
 413 my $Is_MacOS;
 414
 415 require File::Basename;
 416 require File::Spec;
 417
 418 # Should ideally be my() not our() but local() currently
 419 # refuses to operate on lexicals
 420
 421 our %SLnkSeen;
 422 our ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
 423     $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
 424     $pre_process, $post_process, $dangling_symlinks);
 425
 426 sub contract_name {
 427     my ($cdir,$fn) = @_;
 428
 429     return substr($cdir,0,rindex($cdir,'/')) if $fn eq $File::Find::current_dir;
 430
 431     $cdir = substr($cdir,0,rindex($cdir,'/')+1);
 432
 433     $fn =~ s|^\./||;
 434
 435     my $abs_name= $cdir . $fn;
 436
 437     if (substr($fn,0,3) eq '../') {
 438        1 while $abs_name =~ s!/[^/]*/\.\./!/!;
 439     }
 440
 441     return $abs_name;
 442 }
 443
 444 # return the absolute name of a directory or file
 445 sub contract_name_Mac {
 446     my ($cdir,$fn) = @_;
 447     my $abs_name;
 448
 449     if ($fn =~ /^(:+)(.*)$/) { # valid pathname starting with a ':'
 450
 451         my $colon_count = length ($1);
 452         if ($colon_count == 1) {
 453             $abs_name = $cdir . $2;
 454             return $abs_name;
 455         }
 456         else {
 457             # need to move up the tree, but
 458             # only if it's not a volume name
 459             for (my $i=1; $i<$colon_count; $i++) {
 460                 unless ($cdir =~ /^[^:]+:$/) { # volume name
 461                     $cdir =~ s/[^:]+:$//;
 462                 }
 463                 else {
 464                     return undef;
 465                 }
 466             }
 467             $abs_name = $cdir . $2;
 468             return $abs_name;
 469         }
 470
 471     }
 472     else {
 473
 474         # $fn may be a valid path to a directory or file or (dangling)
 475         # symlink, without a leading ':'
 476         if ( (-e $fn) || (-l $fn) ) {
 477             if ($fn =~ /^[^:]+:/) { # a volume name like DataHD:*
 478                 return $fn; # $fn is already an absolute path
 479             }
 480             else {
 481                 $abs_name = $cdir . $fn;
 482                 return $abs_name;
 483             }
 484         }
 485         else { # argh!, $fn is not a valid directory/file
 486              return undef;
 487         }
 488     }
 489 }
 490
 491 sub PathCombine($$) {
 492     my ($Base,$Name) = @_;
 493     my $AbsName;
 494
 495     if ($Is_MacOS) {
 496         # $Name is the resolved symlink (always a full path on MacOS),
 497         # i.e. there's no need to call contract_name_Mac()
 498         $AbsName = $Name;
 499
 500         # (simple) check for recursion
 501         if ( ( $Base =~ /^$AbsName/) && (-d $AbsName) ) { # recursion
 502             return undef;
 503         }
 504     }
 505     else {
 506         if (substr($Name,0,1) eq '/') {
 507             $AbsName= $Name;
 508         }
 509         else {
 510             $AbsName= contract_name($Base,$Name);
 511         }
 512
 513         # (simple) check for recursion
 514         my $newlen= length($AbsName);
 515         if ($newlen <= length($Base)) {
 516             if (($newlen == length($Base) || substr($Base,$newlen,1) eq '/')
 517                 && $AbsName eq substr($Base,0,$newlen))
 518             {
 519                 return undef;
 520             }
 521         }
 522     }
 523     return $AbsName;
 524 }
 525
 526 sub Follow_SymLink($) {
 527     my ($AbsName) = @_;
 528
 529     my ($NewName,$DEV, $INO);
 530     ($DEV, $INO)= lstat $AbsName;
 531
 532     while (-l _) {
 533         if ($SLnkSeen{$DEV, $INO}++) {
 534             if ($follow_skip < 2) {
 535                 die "$AbsName is encountered a second time";
 536             }
 537             else {
 538                 return undef;
 539             }
 540         }
 541         $NewName= PathCombine($AbsName, readlink($AbsName));
 542         unless(defined $NewName) {
 543             if ($follow_skip < 2) {
 544                 die "$AbsName is a recursive symbolic link";
 545             }
 546             else {
 547                 return undef;
 548             }
 549         }
 550         else {
 551             $AbsName= $NewName;
 552         }
 553         ($DEV, $INO) = lstat($AbsName);
 554         return undef unless defined $DEV;  #  dangling symbolic link
 555     }
 556
 557     if ($full_check && defined $DEV && $SLnkSeen{$DEV, $INO}++) {
 558         if ( ($follow_skip < 1) || ((-d _) && ($follow_skip < 2)) ) {
 559             die "$AbsName encountered a second time";
 560         }
 561         else {
 562             return undef;
 563         }
 564     }
 565
 566     return $AbsName;
 567 }
 568
 569 our($dir, $name, $fullname, $prune);
 570 sub _find_dir_symlnk($$$);
 571 sub _find_dir($$$);
 572
 573 # check whether or not a scalar variable is tainted
 574 # (code straight from the Camel, 3rd ed., page 561)
 575 sub is_tainted_pp {
 576     my $arg = shift;
 577     my $nada = substr($arg, 0, 0); # zero-length
 578     local $@;
 579     eval { eval "# $nada" };
 580     return length($@) != 0;
 581 }
 582
 583 sub _find_opt {
 584     my $wanted = shift;
 585     die "invalid top directory" unless defined $_[0];
 586
 587     # This function must local()ize everything because callbacks may
 588     # call find() or finddepth()
 589
 590     local %SLnkSeen;
 591     local ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
 592         $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
 593         $pre_process, $post_process, $dangling_symlinks);
 594     local($dir, $name, $fullname, $prune, $_);
 595
 596     my $cwd            = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::getcwd();
 597     my $cwd_untainted  = $cwd;
 598     my $check_t_cwd    = 1;
 599     $wanted_callback   = $wanted->{wanted};
 600     $bydepth           = $wanted->{bydepth};
 601     $pre_process       = $wanted->{preprocess};
 602     $post_process      = $wanted->{postprocess};
 603     $no_chdir          = $wanted->{no_chdir};
 604     $full_check        = $wanted->{follow};
 605     $follow            = $full_check || $wanted->{follow_fast};
 606     $follow_skip       = $wanted->{follow_skip};
 607     $untaint           = $wanted->{untaint};
 608     $untaint_pat       = $wanted->{untaint_pattern};
 609     $untaint_skip      = $wanted->{untaint_skip};
 610     $dangling_symlinks = $wanted->{dangling_symlinks};
 611
 612     # for compatibility reasons (find.pl, find2perl)
 613     local our ($topdir, $topdev, $topino, $topmode, $topnlink);
 614
 615     # a symbolic link to a directory doesn't increase the link count
 616     $avoid_nlink      = $follow || $File::Find::dont_use_nlink;
 617
 618     my ($abs_dir, $Is_Dir);
 619
 620     Proc_Top_Item:
 621     foreach my $TOP (@_) {
 622         my $top_item = $TOP;
 623
 624         if ($Is_MacOS) {
 625             ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item;
 626             $top_item = ":$top_item"
 627                 if ( (-d _) && ( $top_item !~ /:/ ) );
 628         }
 629         else {
 630             $top_item =~ s|/\z|| unless $top_item eq '/';
 631             ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item;
 632         }
 633
 634         $Is_Dir= 0;
 635
 636         if ($follow) {
 637
 638             if ($Is_MacOS) {
 639                 $cwd = "$cwd:" unless ($cwd =~ /:$/); # for safety
 640
 641                 if ($top_item eq $File::Find::current_dir) {
 642                     $abs_dir = $cwd;
 643                 }
 644                 else {
 645                     $abs_dir = contract_name_Mac($cwd, $top_item);
 646                     unless (defined $abs_dir) {
 647                         warnings::warnif "Can't determine absolute path for $top_item (No such file or directory)\n";
 648                         next Proc_Top_Item;
 649                     }
 650                 }
 651
 652             }
 653             else {
 654                 if (substr($top_item,0,1) eq '/') {
 655                     $abs_dir = $top_item;
 656                 }
 657                 elsif ($top_item eq $File::Find::current_dir) {
 658                     $abs_dir = $cwd;
 659                 }
 660                 else {  # care about any  ../
 661                     $abs_dir = contract_name("$cwd/",$top_item);
 662                 }
 663             }
 664             $abs_dir= Follow_SymLink($abs_dir);
 665             unless (defined $abs_dir) {
 666                 if ($dangling_symlinks) {
 667                     if (ref $dangling_symlinks eq 'CODE') {
 668                         $dangling_symlinks->($top_item, $cwd);
 669                     } else {
 670                         warnings::warnif "$top_item is a dangling symbolic link\n";
 671                     }
 672                 }
 673                 next Proc_Top_Item;
 674             }
 675
 676             if (-d _) {
 677                 _find_dir_symlnk($wanted, $abs_dir, $top_item);
 678                 $Is_Dir= 1;
 679             }
 680         }
 681         else { # no follow
 682             $topdir = $top_item;
 683             unless (defined $topnlink) {
 684                 warnings::warnif "Can't stat $top_item: $!\n";
 685                 next Proc_Top_Item;
 686             }
 687             if (-d _) {
 688                 $top_item =~ s/\.dir\z//i if $Is_VMS;
 689                 _find_dir($wanted, $top_item, $topnlink);
 690                 $Is_Dir= 1;
 691             }
 692             else {
 693                 $abs_dir= $top_item;
 694             }
 695         }
 696
 697         unless ($Is_Dir) {
 698             unless (($_,$dir) = File::Basename::fileparse($abs_dir)) {
 699                 if ($Is_MacOS) {
 700                     ($dir,$_) = (':', $top_item); # $File::Find::dir, $_
 701                 }
 702                 else {
 703                     ($dir,$_) = ('./', $top_item);
 704                 }
 705             }
 706
 707             $abs_dir = $dir;
 708             if (( $untaint ) && (is_tainted($dir) )) {
 709                 ( $abs_dir ) = $dir =~ m|$untaint_pat|;
 710                 unless (defined $abs_dir) {
 711                     if ($untaint_skip == 0) {
 712                         die "directory $dir is still tainted";
 713                     }
 714                     else {
 715                         next Proc_Top_Item;
 716                     }
 717                 }
 718             }
 719
 720             unless ($no_chdir || chdir $abs_dir) {
 721                 warnings::warnif "Couldn't chdir $abs_dir: $!\n";
 722                 next Proc_Top_Item;
 723             }
 724
 725             $name = $abs_dir . $_; # $File::Find::name
 726             $_ = $name if $no_chdir;
 727
 728             { $wanted_callback->() }; # protect against wild "next"
 729
 730         }
 731
 732         unless ( $no_chdir ) {
 733             if ( ($check_t_cwd) && (($untaint) && (is_tainted($cwd) )) ) {
 734                 ( $cwd_untainted ) = $cwd =~ m|$untaint_pat|;
 735                 unless (defined $cwd_untainted) {
 736                     die "insecure cwd in find(depth)";
 737                 }
 738                 $check_t_cwd = 0;
 739             }
 740             unless (chdir $cwd_untainted) {
 741                 die "Can't cd to $cwd: $!\n";
 742             }
 743         }
 744     }
 745 }
 746
 747 # API:
 748 #  $wanted
 749 #  $p_dir :  "parent directory"
 750 #  $nlink :  what came back from the stat
 751 # preconditions:
 752 #  chdir (if not no_chdir) to dir
 753
 754 sub _find_dir($$$) {
 755     my ($wanted, $p_dir, $nlink) = @_;
 756     my ($CdLvl,$Level) = (0,0);
 757     my @Stack;
 758     my @filenames;
 759     my ($subcount,$sub_nlink);
 760     my $SE= [];
 761     my $dir_name= $p_dir;
 762     my $dir_pref;
 763     my $dir_rel = $File::Find::current_dir;
 764     my $tainted = 0;
 765     my $no_nlink;
 766
 767     if ($Is_MacOS) {
 768         $dir_pref= ($p_dir =~ /:$/) ? $p_dir : "$p_dir:"; # preface
 769     }
 770     else {
 771         $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" );
 772     }
 773
 774     local ($dir, $name, $prune, *DIR);
 775
 776     unless ( $no_chdir || ($p_dir eq $File::Find::current_dir)) {
 777         my $udir = $p_dir;
 778         if (( $untaint ) && (is_tainted($p_dir) )) {
 779             ( $udir ) = $p_dir =~ m|$untaint_pat|;
 780             unless (defined $udir) {
 781                 if ($untaint_skip == 0) {
 782                     die "directory $p_dir is still tainted";
 783                 }
 784                 else {
 785                     return;
 786                 }
 787             }
 788         }
 789         unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) {
 790             warnings::warnif "Can't cd to $udir: $!\n";
 791             return;
 792         }
 793     }
 794
 795     # push the starting directory
 796     push @Stack,[$CdLvl,$p_dir,$dir_rel,-1]  if  $bydepth;
 797
 798     if ($Is_MacOS) {
 799         $p_dir = $dir_pref;  # ensure trailing ':'
 800     }
 801
 802     while (defined $SE) {
 803         unless ($bydepth) {
 804             $dir= $p_dir; # $File::Find::dir
 805             $name= $dir_name; # $File::Find::name
 806             $_= ($no_chdir ? $dir_name : $dir_rel ); # $_
 807             # prune may happen here
 808             $prune= 0;
 809             { $wanted_callback->() };   # protect against wild "next"
 810             next if $prune;
 811         }
 812
 813         # change to that directory
 814         unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
 815             my $udir= $dir_rel;
 816             if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_rel) )) ) {
 817                 ( $udir ) = $dir_rel =~ m|$untaint_pat|;
 818                 unless (defined $udir) {
 819                     if ($untaint_skip == 0) {
 820                         if ($Is_MacOS) {
 821                             die "directory ($p_dir) $dir_rel is still tainted";
 822                         }
 823                         else {
 824                             die "directory (" . ($p_dir ne '/' ? $p_dir : '') . "/) $dir_rel is still tainted";
 825                         }
 826                     } else { # $untaint_skip == 1
 827                         next;
 828                     }
 829                 }
 830             }
 831             unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) {
 832                 if ($Is_MacOS) {
 833                     warnings::warnif "Can't cd to ($p_dir) $udir: $!\n";
 834                 }
 835                 else {
 836                     warnings::warnif "Can't cd to (" .
 837                         ($p_dir ne '/' ? $p_dir : '') . "/) $udir: $!\n";
 838                 }
 839                 next;
 840             }
 841             $CdLvl++;
 842         }
 843
 844         if ($Is_MacOS) {
 845             $dir_name = "$dir_name:" unless ($dir_name =~ /:$/);
 846         }
 847
 848         $dir= $dir_name; # $File::Find::dir
 849
 850         # Get the list of files in the current directory.
 851         unless (opendir DIR, ($no_chdir ? $dir_name : $File::Find::current_dir)) {
 852             warnings::warnif "Can't opendir($dir_name): $!\n";
 853             next;
 854         }
 855         @filenames = readdir DIR;
 856         closedir(DIR);
 857         @filenames = $pre_process->(@filenames) if $pre_process;
 858         push @Stack,[$CdLvl,$dir_name,"",-2]   if $post_process;
 859
 860         # default: use whatever was specifid
 861         # (if $nlink >= 2, and $avoid_nlink == 0, this will switch back)
 862         $no_nlink = $avoid_nlink;
 863         # if dir has wrong nlink count, force switch to slower stat method
 864         $no_nlink = 1 if ($nlink < 2);
 865
 866         if ($nlink == 2 && !$no_nlink) {
 867             # This dir has no subdirectories.
 868             for my $FN (@filenames) {
 869                 next if $FN =~ $File::Find::skip_pattern;
 870
 871                 $name = $dir_pref . $FN; # $File::Find::name
 872                 $_ = ($no_chdir ? $name : $FN); # $_
 873                 { $wanted_callback->() }; # protect against wild "next"
 874             }
 875
 876         }
 877         else {
 878             # This dir has subdirectories.
 879             $subcount = $nlink - 2;
 880
 881             # HACK: insert directories at this position. so as to preserve
 882             # the user pre-processed ordering of files.
 883             # EG: directory traversal is in user sorted order, not at random.
 884             my $stack_top = @Stack;
 885
 886             for my $FN (@filenames) {
 887                 next if $FN =~ $File::Find::skip_pattern;
 888                 if ($subcount > 0 || $no_nlink) {
 889                     # Seen all the subdirs?
 890                     # check for directoriness.
 891                     # stat is faster for a file in the current directory
 892                     $sub_nlink = (lstat ($no_chdir ? $dir_pref . $FN : $FN))[3];
 893
 894                     if (-d _) {
 895                         --$subcount;
 896                         $FN =~ s/\.dir\z//i if $Is_VMS;
 897                         # HACK: replace push to preserve dir traversal order
 898                         #push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink];
 899                         splice @Stack, $stack_top, 0,
 900                                  [$CdLvl,$dir_name,$FN,$sub_nlink];
 901                     }
 902                     else {
 903                         $name = $dir_pref . $FN; # $File::Find::name
 904                         $_= ($no_chdir ? $name : $FN); # $_
 905                         { $wanted_callback->() }; # protect against wild "next"
 906                     }
 907                 }
 908                 else {
 909                     $name = $dir_pref . $FN; # $File::Find::name
 910                     $_= ($no_chdir ? $name : $FN); # $_
 911                     { $wanted_callback->() }; # protect against wild "next"
 912                 }
 913             }
 914         }
 915     }
 916     continue {
 917         while ( defined ($SE = pop @Stack) ) {
 918             ($Level, $p_dir, $dir_rel, $nlink) = @$SE;
 919             if ($CdLvl > $Level && !$no_chdir) {
 920                 my $tmp;
 921                 if ($Is_MacOS) {
 922                     $tmp = (':' x ($CdLvl-$Level)) . ':';
 923                 }
 924                 else {
 925                     $tmp = join('/',('..') x ($CdLvl-$Level));
 926                 }
 927                 die "Can't cd to $dir_name" . $tmp
 928                     unless chdir ($tmp);
 929                 $CdLvl = $Level;
 930             }
 931
 932             if ($Is_MacOS) {
 933                 # $pdir always has a trailing ':', except for the starting dir,
 934                 # where $dir_rel eq ':'
 935                 $dir_name = "$p_dir$dir_rel";
 936                 $dir_pref = "$dir_name:";
 937             }
 938             else {
 939                 $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
 940                 $dir_pref = "$dir_name/";
 941             }
 942
 943             if ( $nlink == -2 ) {
 944                 $name = $dir = $p_dir; # $File::Find::name / dir
 945                 $_ = $File::Find::current_dir;
 946                 $post_process->();              # End-of-directory processing
 947             }
 948             elsif ( $nlink < 0 ) {  # must be finddepth, report dirname now
 949                 $name = $dir_name;
 950                 if ($Is_MacOS) {
 951                     if ($dir_rel eq ':') { # must be the top dir, where we started
 952                         $name =~ s|:$||; # $File::Find::name
 953                         $p_dir = "$p_dir:" unless ($p_dir =~ /:$/);
 954                     }
 955                     $dir = $p_dir; # $File::Find::dir
 956                     $_ = ($no_chdir ? $name : $dir_rel); # $_
 957                 }
 958                 else {
 959                     if ( substr($name,-2) eq '/.' ) {
 960                         substr($name, length($name) == 2 ? -1 : -2) = '';
 961                     }
 962                     $dir = $p_dir;
 963                     $_ = ($no_chdir ? $dir_name : $dir_rel );
 964                     if ( substr($_,-2) eq '/.' ) {
 965                         substr($_, length($_) == 2 ? -1 : -2) = '';
 966                     }
 967                 }
 968                 { $wanted_callback->() }; # protect against wild "next"
 969              }
 970              else {
 971                 push @Stack,[$CdLvl,$p_dir,$dir_rel,-1]  if  $bydepth;
 972                 last;
 973             }
 974         }
 975     }
 976 }
 977
 978
 979 # API:
 980 #  $wanted
 981 #  $dir_loc : absolute location of a dir
 982 #  $p_dir   : "parent directory"
 983 # preconditions:
 984 #  chdir (if not no_chdir) to dir
 985
 986 sub _find_dir_symlnk($$$) {
 987     my ($wanted, $dir_loc, $p_dir) = @_; # $dir_loc is the absolute directory
 988     my @Stack;
 989     my @filenames;
 990     my $new_loc;
 991     my $updir_loc = $dir_loc; # untainted parent directory
 992     my $SE = [];
 993     my $dir_name = $p_dir;
 994     my $dir_pref;
 995     my $loc_pref;
 996     my $dir_rel = $File::Find::current_dir;
 997     my $byd_flag; # flag for pending stack entry if $bydepth
 998     my $tainted = 0;
 999     my $ok = 1;
1000
1001     if ($Is_MacOS) {
1002         $dir_pref = ($p_dir =~ /:$/) ? "$p_dir" : "$p_dir:";
1003         $loc_pref = ($dir_loc =~ /:$/) ? "$dir_loc" : "$dir_loc:";
1004     } else {
1005         $dir_pref = ( $p_dir   eq '/' ? '/' : "$p_dir/" );
1006         $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" );
1007     }
1008
1009     local ($dir, $name, $fullname, $prune, *DIR);
1010
1011     unless ($no_chdir) {
1012         # untaint the topdir
1013         if (( $untaint ) && (is_tainted($dir_loc) )) {
1014             ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|; # parent dir, now untainted
1015              # once untainted, $updir_loc is pushed on the stack (as parent directory);
1016             # hence, we don't need to untaint the parent directory every time we chdir
1017             # to it later
1018             unless (defined $updir_loc) {
1019                 if ($untaint_skip == 0) {
1020                     die "directory $dir_loc is still tainted";
1021                 }
1022                 else {
1023                     return;
1024                 }
1025             }
1026         }
1027         $ok = chdir($updir_loc) unless ($p_dir eq $File::Find::current_dir);
1028         unless ($ok) {
1029             warnings::warnif "Can't cd to $updir_loc: $!\n";
1030             return;
1031         }
1032     }
1033
1034     push @Stack,[$dir_loc,$updir_loc,$p_dir,$dir_rel,-1]  if  $bydepth;
1035
1036     if ($Is_MacOS) {
1037         $p_dir = $dir_pref; # ensure trailing ':'
1038     }
1039
1040     while (defined $SE) {
1041
1042         unless ($bydepth) {
1043             # change (back) to parent directory (always untainted)
1044             unless ($no_chdir) {
1045                 unless (chdir $updir_loc) {
1046                     warnings::warnif "Can't cd to $updir_loc: $!\n";
1047                     next;
1048                 }
1049             }
1050             $dir= $p_dir; # $File::Find::dir
1051             $name= $dir_name; # $File::Find::name
1052             $_= ($no_chdir ? $dir_name : $dir_rel ); # $_
1053             $fullname= $dir_loc; # $File::Find::fullname
1054             # prune may happen here
1055             $prune= 0;
1056             lstat($_); # make sure  file tests with '_' work
1057             { $wanted_callback->() }; # protect against wild "next"
1058             next if $prune;
1059         }
1060
1061         # change to that directory
1062         unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
1063             $updir_loc = $dir_loc;
1064             if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_loc) )) ) {
1065                 # untaint $dir_loc, what will be pushed on the stack as (untainted) parent dir
1066                 ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|;
1067                 unless (defined $updir_loc) {
1068                     if ($untaint_skip == 0) {
1069                         die "directory $dir_loc is still tainted";
1070                     }
1071                     else {
1072                         next;
1073                     }
1074                 }
1075             }
1076             unless (chdir $updir_loc) {
1077                 warnings::warnif "Can't cd to $updir_loc: $!\n";
1078                 next;
1079             }
1080         }
1081
1082         if ($Is_MacOS) {
1083             $dir_name = "$dir_name:" unless ($dir_name =~ /:$/);
1084         }
1085
1086         $dir = $dir_name; # $File::Find::dir
1087
1088         # Get the list of files in the current directory.
1089         unless (opendir DIR, ($no_chdir ? $dir_loc : $File::Find::current_dir)) {
1090             warnings::warnif "Can't opendir($dir_loc): $!\n";
1091             next;
1092         }
1093         @filenames = readdir DIR;
1094         closedir(DIR);
1095
1096         for my $FN (@filenames) {
1097             next if $FN =~ $File::Find::skip_pattern;
1098
1099             # follow symbolic links / do an lstat
1100             $new_loc = Follow_SymLink($loc_pref.$FN);
1101
1102             # ignore if invalid symlink
1103             next unless defined $new_loc;
1104
1105             if (-d _) {
1106                 push @Stack,[$new_loc,$updir_loc,$dir_name,$FN,1];
1107             }
1108             else {
1109                 $fullname = $new_loc; # $File::Find::fullname
1110                 $name = $dir_pref . $FN; # $File::Find::name
1111                 $_ = ($no_chdir ? $name : $FN); # $_
1112                 { $wanted_callback->() }; # protect against wild "next"
1113             }
1114         }
1115
1116     }
1117     continue {
1118         while (defined($SE = pop @Stack)) {
1119             ($dir_loc, $updir_loc, $p_dir, $dir_rel, $byd_flag) = @$SE;
1120             if ($Is_MacOS) {
1121                 # $p_dir always has a trailing ':', except for the starting dir,
1122                 # where $dir_rel eq ':'
1123                 $dir_name = "$p_dir$dir_rel";
1124                 $dir_pref = "$dir_name:";
1125                 $loc_pref = ($dir_loc =~ /:$/) ? $dir_loc : "$dir_loc:";
1126             }
1127             else {
1128                 $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
1129                 $dir_pref = "$dir_name/";
1130                 $loc_pref = "$dir_loc/";
1131             }
1132             if ( $byd_flag < 0 ) {  # must be finddepth, report dirname now
1133                 unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
1134                     unless (chdir $updir_loc) { # $updir_loc (parent dir) is always untainted
1135                         warnings::warnif "Can't cd to $updir_loc: $!\n";
1136                         next;
1137                     }
1138                 }
1139                 $fullname = $dir_loc; # $File::Find::fullname
1140                 $name = $dir_name; # $File::Find::name
1141                 if ($Is_MacOS) {
1142                     if ($dir_rel eq ':') { # must be the top dir, where we started
1143                         $name =~ s|:$||; # $File::Find::name
1144                         $p_dir = "$p_dir:" unless ($p_dir =~ /:$/);
1145                     }
1146                     $dir = $p_dir; # $File::Find::dir
1147                      $_ = ($no_chdir ? $name : $dir_rel); # $_
1148                 }
1149                 else {
1150                     if ( substr($name,-2) eq '/.' ) {
1151                         substr($name, length($name) == 2 ? -1 : -2) = ''; # $File::Find::name
1152                     }
1153                     $dir = $p_dir; # $File::Find::dir
1154                     $_ = ($no_chdir ? $dir_name : $dir_rel); # $_
1155                     if ( substr($_,-2) eq '/.' ) {
1156                         substr($_, length($_) == 2 ? -1 : -2) = '';
1157                     }
1158                 }
1159
1160                 lstat($_); # make sure file tests with '_' work
1161                 { $wanted_callback->() }; # protect against wild "next"
1162             }
1163             else {
1164                 push @Stack,[$dir_loc, $updir_loc, $p_dir, $dir_rel,-1]  if  $bydepth;
1165                 last;
1166             }
1167         }
1168     }
1169 }
1170
1171
1172 sub wrap_wanted {
1173     my $wanted = shift;
1174     if ( ref($wanted) eq 'HASH' ) {
1175         if ( $wanted->{follow} || $wanted->{follow_fast}) {
1176             $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip};
1177         }
1178         if ( $wanted->{untaint} ) {
1179             $wanted->{untaint_pattern} = $File::Find::untaint_pattern
1180                 unless defined $wanted->{untaint_pattern};
1181             $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip};
1182         }
1183         return $wanted;
1184     }
1185     else {
1186         return { wanted => $wanted };
1187     }
1188 }
1189
1190 sub find {
1191     my $wanted = shift;
1192     _find_opt(wrap_wanted($wanted), @_);
1193 }
1194
1195 sub finddepth {
1196     my $wanted = wrap_wanted(shift);
1197     $wanted->{bydepth} = 1;
1198     _find_opt($wanted, @_);
1199 }
1200
1201 # default
1202 $File::Find::skip_pattern    = qr/^\.{1,2}\z/;
1203 $File::Find::untaint_pattern = qr|^([-+@\w./]+)$|;
1204
1205 # These are hard-coded for now, but may move to hint files.
1206 if ($^O eq 'VMS') {
1207     $Is_VMS = 1;
1208     $File::Find::dont_use_nlink  = 1;
1209 }
1210 elsif ($^O eq 'MacOS') {
1211     $Is_MacOS = 1;
1212     $File::Find::dont_use_nlink  = 1;
1213     $File::Find::skip_pattern    = qr/^Icon\015\z/;
1214     $File::Find::untaint_pattern = qr|^(.+)$|;
1215 }
1216
1217 # this _should_ work properly on all platforms
1218 # where File::Find can be expected to work
1219 $File::Find::current_dir = File::Spec->curdir || '.';
1220
1221 $File::Find::dont_use_nlink = 1
1222     if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32' ||
1223        $^O eq 'cygwin' || $^O eq 'epoc' || $^O eq 'qnx' ||
1224            $^O eq 'nto';
1225
1226 # Set dont_use_nlink in your hint file if your system's stat doesn't
1227 # report the number of links in a directory as an indication
1228 # of the number of files.
1229 # See, e.g. hints/machten.sh for MachTen 2.2.
1230 unless ($File::Find::dont_use_nlink) {
1231     require Config;
1232     $File::Find::dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'});
1233 }
1234
1235 # We need a function that checks if a scalar is tainted. Either use the
1236 # Scalar::Util module's tainted() function or our (slower) pure Perl
1237 # fallback is_tainted_pp()
1238 {
1239     local $@;
1240     eval { require Scalar::Util };
1241     *is_tainted = $@ ? \&is_tainted_pp : \&Scalar::Util::tainted;
1242 }
1243
1244 1;