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