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