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