In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/f4eedc6b8c8773817aee4a0424179660710446bf?hp=689d8423b7692a628b08f883e8c57c3f4db2f96a>
- Log -----------------------------------------------------------------
commit f4eedc6b8c8773817aee4a0424179660710446bf
Author: Daniel Dragan <bul...@hotmail.com>
Date: Sun Oct 12 03:42:38 2014 -0400
speed up building with less disk IO pod moves+__END__+misc
In Cwd.pm, dont search for pwd on Win32.
Also trim down the list of makefile suffixes on Win32 so it doesn't try
searching for av.pas and perl.f90 and hash.cbl on disk.
Add __END__ tokens to stop the last read() call on the handle which
returns 0 bytes at EOF.
M dist/PathTools/Cwd.pm
M dist/PathTools/lib/File/Spec.pm
M dist/PathTools/lib/File/Spec/Cygwin.pm
M dist/PathTools/lib/File/Spec/Epoc.pm
M dist/PathTools/lib/File/Spec/Functions.pm
M dist/PathTools/lib/File/Spec/Mac.pm
M dist/PathTools/lib/File/Spec/OS2.pm
M dist/PathTools/lib/File/Spec/Unix.pm
M dist/PathTools/lib/File/Spec/VMS.pm
M dist/PathTools/lib/File/Spec/Win32.pm
M ext/File-Find/lib/File/Find.pm
M lib/warnings/register.pm
M pod/perldelta.pod
M win32/Makefile
M write_buildcustomize.pl
commit 56873d4238039e462718436d7c6b45e4689209de
Author: Daniel Dragan <bul...@hotmail.com>
Date: Sun Oct 12 22:42:15 2014 -0400
remove excess whitespace from warnings.pm
Some lines end with spaces, remove that, use tabs instead of spaces in code
so the perl code is less bytes to read from disk. This patch saved 183
bytes. Part of [perl #122955].
M lib/warnings.pm
M regen/warnings.pl
commit effd17dc012719d584aa712c6c7bd5dc142885b6
Author: Daniel Dragan <bul...@hotmail.com>
Date: Sun Oct 12 21:57:01 2014 -0400
move POD in warnings.pm to end of file to reduce module load I/O calls
warnings.pm is the hottest file/takes the most read() calls of any
module during a make all. By moving POD to the end, ~40KB of OS read()
IO was reduced to ~16KB of OS read() IO calls. Also the parser doesn't need
to search for Perl code in the POD further lessining load time because of
the __END__ token. Filed as [perl #122955].
M lib/warnings.pm
M regen/warnings.pl
commit 6b6919154b178ae575034bdfff686ab13c6a9d1c
Author: Daniel Dragan <bul...@hotmail.com>
Date: Mon Oct 13 15:20:30 2014 -0400
silence warning after "Fold join to const or stringify where possible"
VC 2003
op.c(4022) : warning C4244: '=' : conversion from 'unsigned short' to
'char', possible loss of data
M op.c
-----------------------------------------------------------------------
Summary of changes:
dist/PathTools/Cwd.pm | 355 +++---
dist/PathTools/lib/File/Spec.pm | 2 +-
dist/PathTools/lib/File/Spec/Cygwin.pm | 2 +-
dist/PathTools/lib/File/Spec/Epoc.pm | 2 +-
dist/PathTools/lib/File/Spec/Functions.pm | 2 +-
dist/PathTools/lib/File/Spec/Mac.pm | 2 +-
dist/PathTools/lib/File/Spec/OS2.pm | 2 +-
dist/PathTools/lib/File/Spec/Unix.pm | 2 +-
dist/PathTools/lib/File/Spec/VMS.pm | 2 +-
dist/PathTools/lib/File/Spec/Win32.pm | 2 +-
ext/File-Find/lib/File/Find.pm | 1889 +++++++++++++++--------------
lib/warnings.pm | 1378 ++++++++++-----------
lib/warnings/register.pm | 41 +-
op.c | 2 +-
pod/perldelta.pod | 12 +
regen/warnings.pl | 494 ++++----
win32/Makefile | 5 +-
write_buildcustomize.pl | 1 +
18 files changed, 2106 insertions(+), 2089 deletions(-)
diff --git a/dist/PathTools/Cwd.pm b/dist/PathTools/Cwd.pm
index 5e85be8..ddc16fe 100644
--- a/dist/PathTools/Cwd.pm
+++ b/dist/PathTools/Cwd.pm
@@ -1,177 +1,9 @@
package Cwd;
-
-=head1 NAME
-
-Cwd - get pathname of current working directory
-
-=head1 SYNOPSIS
-
- use Cwd;
- my $dir = getcwd;
-
- use Cwd 'abs_path';
- my $abs_path = abs_path($file);
-
-=head1 DESCRIPTION
-
-This module provides functions for determining the pathname of the
-current working directory. It is recommended that getcwd (or another
-*cwd() function) be used in I<all> code to ensure portability.
-
-By default, it exports the functions cwd(), getcwd(), fastcwd(), and
-fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.
-
-
-=head2 getcwd and friends
-
-Each of these functions are called without arguments and return the
-absolute path of the current working directory.
-
-=over 4
-
-=item getcwd
-
- my $cwd = getcwd();
-
-Returns the current working directory.
-
-Exposes the POSIX function getcwd(3) or re-implements it if it's not
-available.
-
-=item cwd
-
- my $cwd = cwd();
-
-The cwd() is the most natural form for the current architecture. For
-most systems it is identical to `pwd` (but without the trailing line
-terminator).
-
-=item fastcwd
-
- my $cwd = fastcwd();
-
-A more dangerous version of getcwd(), but potentially faster.
-
-It might conceivably chdir() you out of a directory that it can't
-chdir() you back into. If fastcwd encounters a problem it will return
-undef but will probably leave you in a different directory. For a
-measure of extra security, if everything appears to have worked, the
-fastcwd() function will check that it leaves you in the same directory
-that it started in. If it has changed it will C<die> with the message
-"Unstable directory path, current directory changed
-unexpectedly". That should never happen.
-
-=item fastgetcwd
-
- my $cwd = fastgetcwd();
-
-The fastgetcwd() function is provided as a synonym for cwd().
-
-=item getdcwd
-
- my $cwd = getdcwd();
- my $cwd = getdcwd('C:');
-
-The getdcwd() function is also provided on Win32 to get the current working
-directory on the specified drive, since Windows maintains a separate current
-working directory for each drive. If no drive is specified then the current
-drive is assumed.
-
-This function simply calls the Microsoft C library _getdcwd() function.
-
-=back
-
-
-=head2 abs_path and friends
-
-These functions are exported only on request. They each take a single
-argument and return the absolute pathname for it. If no argument is
-given they'll use the current working directory.
-
-=over 4
-
-=item abs_path
-
- my $abs_path = abs_path($file);
-
-Uses the same algorithm as getcwd(). Symbolic links and relative-path
-components ("." and "..") are resolved to return the canonical
-pathname, just like realpath(3).
-
-=item realpath
-
- my $abs_path = realpath($file);
-
-A synonym for abs_path().
-
-=item fast_abs_path
-
- my $abs_path = fast_abs_path($file);
-
-A more dangerous, but potentially faster version of abs_path.
-
-=back
-
-=head2 $ENV{PWD}
-
-If you ask to override your chdir() built-in function,
-
- use Cwd qw(chdir);
-
-then your PWD environment variable will be kept up to date. Note that
-it will only be kept up to date if all packages which use chdir import
-it from Cwd.
-
-
-=head1 NOTES
-
-=over 4
-
-=item *
-
-Since the path separators are different on some operating systems ('/'
-on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
-modules wherever portability is a concern.
-
-=item *
-
-Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
-functions are all aliases for the C<cwd()> function, which, on Mac OS,
-calls `pwd`. Likewise, the C<abs_path()> function is an alias for
-C<fast_abs_path()>.
-
-=back
-
-=head1 AUTHOR
-
-Originally by the perl5-porters.
-
-Maintained by Ken Williams <kwilli...@cpan.org>
-
-=head1 COPYRIGHT
-
-Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-Portions of the C code in this library are copyright (c) 1994 by the
-Regents of the University of California. All rights reserved. The
-license on this code is compatible with the licensing of the rest of
-the distribution - please see the source code in F<Cwd.xs> for the
-details.
-
-=head1 SEE ALSO
-
-L<File::chdir>
-
-=cut
-
use strict;
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
-$VERSION = '3.50';
+$VERSION = '3.51';
my $xs_version = $VERSION;
$VERSION =~ tr/_//;
@@ -335,14 +167,15 @@ $METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
# are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
# so everything works under taint mode.
my $pwd_cmd;
-foreach my $try ('/bin/pwd',
- '/usr/bin/pwd',
- '/QOpenSys/bin/pwd', # OS/400 PASE.
- ) {
-
- if( -x $try ) {
- $pwd_cmd = $try;
- last;
+if($^O ne 'MSWin32') {
+ foreach my $try ('/bin/pwd',
+ '/usr/bin/pwd',
+ '/QOpenSys/bin/pwd', # OS/400 PASE.
+ ) {
+ if( -x $try ) {
+ $pwd_cmd = $try;
+ last;
+ }
}
}
@@ -856,3 +689,171 @@ if (exists $METHOD_MAP{$^O}) {
*realpath = \&abs_path;
1;
+__END__
+
+=head1 NAME
+
+Cwd - get pathname of current working directory
+
+=head1 SYNOPSIS
+
+ use Cwd;
+ my $dir = getcwd;
+
+ use Cwd 'abs_path';
+ my $abs_path = abs_path($file);
+
+=head1 DESCRIPTION
+
+This module provides functions for determining the pathname of the
+current working directory. It is recommended that getcwd (or another
+*cwd() function) be used in I<all> code to ensure portability.
+
+By default, it exports the functions cwd(), getcwd(), fastcwd(), and
+fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.
+
+
+=head2 getcwd and friends
+
+Each of these functions are called without arguments and return the
+absolute path of the current working directory.
+
+=over 4
+
+=item getcwd
+
+ my $cwd = getcwd();
+
+Returns the current working directory.
+
+Exposes the POSIX function getcwd(3) or re-implements it if it's not
+available.
+
+=item cwd
+
+ my $cwd = cwd();
+
+The cwd() is the most natural form for the current architecture. For
+most systems it is identical to `pwd` (but without the trailing line
+terminator).
+
+=item fastcwd
+
+ my $cwd = fastcwd();
+
+A more dangerous version of getcwd(), but potentially faster.
+
+It might conceivably chdir() you out of a directory that it can't
+chdir() you back into. If fastcwd encounters a problem it will return
+undef but will probably leave you in a different directory. For a
+measure of extra security, if everything appears to have worked, the
+fastcwd() function will check that it leaves you in the same directory
+that it started in. If it has changed it will C<die> with the message
+"Unstable directory path, current directory changed
+unexpectedly". That should never happen.
+
+=item fastgetcwd
+
+ my $cwd = fastgetcwd();
+
+The fastgetcwd() function is provided as a synonym for cwd().
+
+=item getdcwd
+
+ my $cwd = getdcwd();
+ my $cwd = getdcwd('C:');
+
+The getdcwd() function is also provided on Win32 to get the current working
+directory on the specified drive, since Windows maintains a separate current
+working directory for each drive. If no drive is specified then the current
+drive is assumed.
+
+This function simply calls the Microsoft C library _getdcwd() function.
+
+=back
+
+
+=head2 abs_path and friends
+
+These functions are exported only on request. They each take a single
+argument and return the absolute pathname for it. If no argument is
+given they'll use the current working directory.
+
+=over 4
+
+=item abs_path
+
+ my $abs_path = abs_path($file);
+
+Uses the same algorithm as getcwd(). Symbolic links and relative-path
+components ("." and "..") are resolved to return the canonical
+pathname, just like realpath(3).
+
+=item realpath
+
+ my $abs_path = realpath($file);
+
+A synonym for abs_path().
+
+=item fast_abs_path
+
+ my $abs_path = fast_abs_path($file);
+
+A more dangerous, but potentially faster version of abs_path.
+
+=back
+
+=head2 $ENV{PWD}
+
+If you ask to override your chdir() built-in function,
+
+ use Cwd qw(chdir);
+
+then your PWD environment variable will be kept up to date. Note that
+it will only be kept up to date if all packages which use chdir import
+it from Cwd.
+
+
+=head1 NOTES
+
+=over 4
+
+=item *
+
+Since the path separators are different on some operating systems ('/'
+on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
+modules wherever portability is a concern.
+
+=item *
+
+Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
+functions are all aliases for the C<cwd()> function, which, on Mac OS,
+calls `pwd`. Likewise, the C<abs_path()> function is an alias for
+C<fast_abs_path()>.
+
+=back
+
+=head1 AUTHOR
+
+Originally by the perl5-porters.
+
+Maintained by Ken Williams <kwilli...@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Portions of the C code in this library are copyright (c) 1994 by the
+Regents of the University of California. All rights reserved. The
+license on this code is compatible with the licensing of the rest of
+the distribution - please see the source code in F<Cwd.xs> for the
+details.
+
+=head1 SEE ALSO
+
+L<File::chdir>
+
+=cut
diff --git a/dist/PathTools/lib/File/Spec.pm b/dist/PathTools/lib/File/Spec.pm
index 5545c52..f47aca0 100644
--- a/dist/PathTools/lib/File/Spec.pm
+++ b/dist/PathTools/lib/File/Spec.pm
@@ -3,7 +3,7 @@ package File::Spec;
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = '3.50';
+$VERSION = '3.51';
$VERSION =~ tr/_//;
my %module = (MacOS => 'Mac',
diff --git a/dist/PathTools/lib/File/Spec/Cygwin.pm
b/dist/PathTools/lib/File/Spec/Cygwin.pm
index 6c67db7..3794320 100644
--- a/dist/PathTools/lib/File/Spec/Cygwin.pm
+++ b/dist/PathTools/lib/File/Spec/Cygwin.pm
@@ -4,7 +4,7 @@ use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.50';
+$VERSION = '3.51';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
diff --git a/dist/PathTools/lib/File/Spec/Epoc.pm
b/dist/PathTools/lib/File/Spec/Epoc.pm
index 5794616..a2fd86a 100644
--- a/dist/PathTools/lib/File/Spec/Epoc.pm
+++ b/dist/PathTools/lib/File/Spec/Epoc.pm
@@ -3,7 +3,7 @@ package File::Spec::Epoc;
use strict;
use vars qw($VERSION @ISA);
-$VERSION = '3.50';
+$VERSION = '3.51';
$VERSION =~ tr/_//;
require File::Spec::Unix;
diff --git a/dist/PathTools/lib/File/Spec/Functions.pm
b/dist/PathTools/lib/File/Spec/Functions.pm
index 52e2286..6b75f74 100644
--- a/dist/PathTools/lib/File/Spec/Functions.pm
+++ b/dist/PathTools/lib/File/Spec/Functions.pm
@@ -5,7 +5,7 @@ use strict;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
-$VERSION = '3.50';
+$VERSION = '3.51';
$VERSION =~ tr/_//;
require Exporter;
diff --git a/dist/PathTools/lib/File/Spec/Mac.pm
b/dist/PathTools/lib/File/Spec/Mac.pm
index 96253d0..4f2ecca 100644
--- a/dist/PathTools/lib/File/Spec/Mac.pm
+++ b/dist/PathTools/lib/File/Spec/Mac.pm
@@ -4,7 +4,7 @@ use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.50';
+$VERSION = '3.51';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
diff --git a/dist/PathTools/lib/File/Spec/OS2.pm
b/dist/PathTools/lib/File/Spec/OS2.pm
index df65d0c..c5e7544 100644
--- a/dist/PathTools/lib/File/Spec/OS2.pm
+++ b/dist/PathTools/lib/File/Spec/OS2.pm
@@ -4,7 +4,7 @@ use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.50';
+$VERSION = '3.51';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
diff --git a/dist/PathTools/lib/File/Spec/Unix.pm
b/dist/PathTools/lib/File/Spec/Unix.pm
index 71545d4..f673c0b 100644
--- a/dist/PathTools/lib/File/Spec/Unix.pm
+++ b/dist/PathTools/lib/File/Spec/Unix.pm
@@ -3,7 +3,7 @@ package File::Spec::Unix;
use strict;
use vars qw($VERSION);
-$VERSION = '3.50';
+$VERSION = '3.51';
my $xs_version = $VERSION;
$VERSION =~ tr/_//;
diff --git a/dist/PathTools/lib/File/Spec/VMS.pm
b/dist/PathTools/lib/File/Spec/VMS.pm
index 4e98aad..d94de9f 100644
--- a/dist/PathTools/lib/File/Spec/VMS.pm
+++ b/dist/PathTools/lib/File/Spec/VMS.pm
@@ -4,7 +4,7 @@ use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.50';
+$VERSION = '3.51';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
diff --git a/dist/PathTools/lib/File/Spec/Win32.pm
b/dist/PathTools/lib/File/Spec/Win32.pm
index 18bfd9c..f238d96 100644
--- a/dist/PathTools/lib/File/Spec/Win32.pm
+++ b/dist/PathTools/lib/File/Spec/Win32.pm
@@ -5,7 +5,7 @@ use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.50';
+$VERSION = '3.51';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
diff --git a/ext/File-Find/lib/File/Find.pm b/ext/File-Find/lib/File/Find.pm
index 61eb3da..af2a2e7 100644
--- a/ext/File-Find/lib/File/Find.pm
+++ b/ext/File-Find/lib/File/Find.pm
@@ -3,1148 +3,1149 @@ use 5.006;
use strict;
use warnings;
use warnings::register;
-our $VERSION = '1.28';
+our $VERSION = '1.29';
require Exporter;
require Cwd;
-#
-# Modified to ensure sub-directory traversal order is not inverted by stack
-# push and pops. That is remains in the same order as in the directory file,
-# or user pre-processing (EG:sorted).
-#
-
-=head1 NAME
-
-File::Find - Traverse a directory tree.
-
-=head1 SYNOPSIS
-
- use File::Find;
- find(\&wanted, @directories_to_search);
- sub wanted { ... }
-
- use File::Find;
- finddepth(\&wanted, @directories_to_search);
- sub wanted { ... }
+our @ISA = qw(Exporter);
+our @EXPORT = qw(find finddepth);
- use File::Find;
- find({ wanted => \&process, follow => 1 }, '.');
-=head1 DESCRIPTION
+use strict;
+my $Is_VMS;
+my $Is_Win32;
-These are functions for searching through directory trees doing work
-on each file found similar to the Unix I<find> command. File::Find
-exports two functions, C<find> and C<finddepth>. They work similarly
-but have subtle differences.
+require File::Basename;
+require File::Spec;
-=over 4
+# Should ideally be my() not our() but local() currently
+# refuses to operate on lexicals
-=item B<find>
+our %SLnkSeen;
+our ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
+ $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
+ $pre_process, $post_process, $dangling_symlinks);
- find(\&wanted, @directories);
- find(\%options, @directories);
+sub contract_name {
+ my ($cdir,$fn) = @_;
-C<find()> does a depth-first search over the given C<@directories> in
-the order they are given. For each file or directory found, it calls
-the C<&wanted> subroutine. (See below for details on how to use the
-C<&wanted> function). Additionally, for each directory found, it will
-C<chdir()> into that directory and continue the search, invoking the
-C<&wanted> function on each file or subdirectory in the directory.
+ return substr($cdir,0,rindex($cdir,'/')) if $fn eq
$File::Find::current_dir;
-=item B<finddepth>
+ $cdir = substr($cdir,0,rindex($cdir,'/')+1);
- finddepth(\&wanted, @directories);
- finddepth(\%options, @directories);
+ $fn =~ s|^\./||;
-C<finddepth()> works just like C<find()> except that it invokes the
-C<&wanted> function for a directory I<after> invoking it for the
-directory's contents. It does a postorder traversal instead of a
-preorder traversal, working from the bottom of the directory tree up
-where C<find()> works from the top of the tree down.
+ my $abs_name= $cdir . $fn;
-=back
+ if (substr($fn,0,3) eq '../') {
+ 1 while $abs_name =~ s!/[^/]*/\.\./+!/!;
+ }
-=head2 %options
+ return $abs_name;
+}
-The first argument to C<find()> is either a code reference to your
-C<&wanted> function, or a hash reference describing the operations
-to be performed for each file. The
-code reference is described in L<The wanted function> below.
+sub PathCombine($$) {
+ my ($Base,$Name) = @_;
+ my $AbsName;
-Here are the possible keys for the hash:
+ if (substr($Name,0,1) eq '/') {
+ $AbsName= $Name;
+ }
+ else {
+ $AbsName= contract_name($Base,$Name);
+ }
-=over 3
+ # (simple) check for recursion
+ my $newlen= length($AbsName);
+ if ($newlen <= length($Base)) {
+ if (($newlen == length($Base) || substr($Base,$newlen,1) eq '/')
+ && $AbsName eq substr($Base,0,$newlen))
+ {
+ return undef;
+ }
+ }
+ return $AbsName;
+}
-=item C<wanted>
+sub Follow_SymLink($) {
+ my ($AbsName) = @_;
-The value should be a code reference. This code reference is
-described in L<The wanted function> below. The C<&wanted> subroutine is
-mandatory.
+ my ($NewName,$DEV, $INO);
+ ($DEV, $INO)= lstat $AbsName;
-=item C<bydepth>
+ while (-l _) {
+ if ($SLnkSeen{$DEV, $INO}++) {
+ if ($follow_skip < 2) {
+ die "$AbsName is encountered a second time";
+ }
+ else {
+ return undef;
+ }
+ }
+ $NewName= PathCombine($AbsName, readlink($AbsName));
+ unless(defined $NewName) {
+ if ($follow_skip < 2) {
+ die "$AbsName is a recursive symbolic link";
+ }
+ else {
+ return undef;
+ }
+ }
+ else {
+ $AbsName= $NewName;
+ }
+ ($DEV, $INO) = lstat($AbsName);
+ return undef unless defined $DEV; # dangling symbolic link
+ }
-Reports the name of a directory only AFTER all its entries
-have been reported. Entry point C<finddepth()> is a shortcut for
-specifying C<< { bydepth => 1 } >> in the first argument of C<find()>.
+ if ($full_check && defined $DEV && $SLnkSeen{$DEV, $INO}++) {
+ if ( ($follow_skip < 1) || ((-d _) && ($follow_skip < 2)) ) {
+ die "$AbsName encountered a second time";
+ }
+ else {
+ return undef;
+ }
+ }
-=item C<preprocess>
+ return $AbsName;
+}
-The value should be a code reference. This code reference is used to
-preprocess the current directory. The name of the currently processed
-directory is in C<$File::Find::dir>. Your preprocessing function is
-called after C<readdir()>, but before the loop that calls the C<wanted()>
-function. It is called with a list of strings (actually file/directory
-names) and is expected to return a list of strings. The code can be
-used to sort the file/directory names alphabetically, numerically,
-or to filter out directory entries based on their name alone. When
-I<follow> or I<follow_fast> are in effect, C<preprocess> is a no-op.
+our($dir, $name, $fullname, $prune);
+sub _find_dir_symlnk($$$);
+sub _find_dir($$$);
-=item C<postprocess>
+# check whether or not a scalar variable is tainted
+# (code straight from the Camel, 3rd ed., page 561)
+sub is_tainted_pp {
+ my $arg = shift;
+ my $nada = substr($arg, 0, 0); # zero-length
+ local $@;
+ eval { eval "# $nada" };
+ return length($@) != 0;
+}
-The value should be a code reference. It is invoked just before leaving
-the currently processed directory. It is called in void context with no
-arguments. The name of the current directory is in C<$File::Find::dir>. This
-hook is handy for summarizing a directory, such as calculating its disk
-usage. When I<follow> or I<follow_fast> are in effect, C<postprocess> is a
-no-op.
+sub _find_opt {
+ my $wanted = shift;
+ die "invalid top directory" unless defined $_[0];
-=item C<follow>
+ # This function must local()ize everything because callbacks may
+ # call find() or finddepth()
-Causes symbolic links to be followed. Since directory trees with symbolic
-links (followed) may contain files more than once and may even have
-cycles, a hash has to be built up with an entry for each file.
-This might be expensive both in space and time for a large
-directory tree. See L</follow_fast> and L</follow_skip> below.
-If either I<follow> or I<follow_fast> is in effect:
+ local %SLnkSeen;
+ local ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
+ $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
+ $pre_process, $post_process, $dangling_symlinks);
+ local($dir, $name, $fullname, $prune);
+ local *_ = \my $a;
-=over 6
+ my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::getcwd();
+ if ($Is_VMS) {
+ # VMS returns this by default in VMS format which just doesn't
+ # work for the rest of this module.
+ $cwd = VMS::Filespec::unixpath($cwd);
-=item *
+ # Apparently this is not expected to have a trailing space.
+ # To attempt to make VMS/UNIX conversions mostly reversible,
+ # a trailing slash is needed. The run-time functions ignore the
+ # resulting double slash, but it causes the perl tests to fail.
+ $cwd =~ s#/\z##;
-It is guaranteed that an I<lstat> has been called before the user's
-C<wanted()> function is called. This enables fast file checks involving S<_>.
-Note that this guarantee no longer holds if I<follow> or I<follow_fast>
-are not set.
+ # This comes up in upper case now, but should be lower.
+ # In the future this could be exact case, no need to change.
+ }
+ my $cwd_untainted = $cwd;
+ my $check_t_cwd = 1;
+ $wanted_callback = $wanted->{wanted};
+ $bydepth = $wanted->{bydepth};
+ $pre_process = $wanted->{preprocess};
+ $post_process = $wanted->{postprocess};
+ $no_chdir = $wanted->{no_chdir};
+ $full_check = $Is_Win32 ? 0 : $wanted->{follow};
+ $follow = $Is_Win32 ? 0 :
+ $full_check || $wanted->{follow_fast};
+ $follow_skip = $wanted->{follow_skip};
+ $untaint = $wanted->{untaint};
+ $untaint_pat = $wanted->{untaint_pattern};
+ $untaint_skip = $wanted->{untaint_skip};
+ $dangling_symlinks = $wanted->{dangling_symlinks};
-=item *
+ # for compatibility reasons (find.pl, find2perl)
+ local our ($topdir, $topdev, $topino, $topmode, $topnlink);
-There is a variable C<$File::Find::fullname> which holds the absolute
-pathname of the file with all symbolic links resolved. If the link is
-a dangling symbolic link, then fullname will be set to C<undef>.
+ # a symbolic link to a directory doesn't increase the link count
+ $avoid_nlink = $follow || $File::Find::dont_use_nlink;
-=back
+ my ($abs_dir, $Is_Dir);
-This is a no-op on Win32.
+ Proc_Top_Item:
+ foreach my $TOP (@_) {
+ my $top_item = $TOP;
+ $top_item = VMS::Filespec::unixify($top_item) if $Is_VMS;
-=item C<follow_fast>
+ ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat
$top_item;
-This is similar to I<follow> except that it may report some files more
-than once. It does detect cycles, however. Since only symbolic links
-have to be hashed, this is much cheaper both in space and time. If
-processing a file more than once (by the user's C<wanted()> function)
-is worse than just taking time, the option I<follow> should be used.
+ if ($Is_Win32) {
+ $top_item =~ s|[/\\]\z||
+ unless $top_item =~ m{^(?:\w:)?[/\\]$};
+ }
+ else {
+ $top_item =~ s|/\z|| unless $top_item eq '/';
+ }
-This is also a no-op on Win32.
+ $Is_Dir= 0;
-=item C<follow_skip>
+ if ($follow) {
-C<follow_skip==1>, which is the default, causes all files which are
-neither directories nor symbolic links to be ignored if they are about
-to be processed a second time. If a directory or a symbolic link
-are about to be processed a second time, File::Find dies.
+ if (substr($top_item,0,1) eq '/') {
+ $abs_dir = $top_item;
+ }
+ elsif ($top_item eq $File::Find::current_dir) {
+ $abs_dir = $cwd;
+ }
+ else { # care about any ../
+ $top_item =~ s/\.dir\z//i if $Is_VMS;
+ $abs_dir = contract_name("$cwd/",$top_item);
+ }
+ $abs_dir= Follow_SymLink($abs_dir);
+ unless (defined $abs_dir) {
+ if ($dangling_symlinks) {
+ if (ref $dangling_symlinks eq 'CODE') {
+ $dangling_symlinks->($top_item, $cwd);
+ } else {
+ warnings::warnif "$top_item is a dangling symbolic
link\n";
+ }
+ }
+ next Proc_Top_Item;
+ }
-C<follow_skip==0> causes File::Find to die if any file is about to be
-processed a second time.
+ if (-d _) {
+ $top_item =~ s/\.dir\z//i if $Is_VMS;
+ _find_dir_symlnk($wanted, $abs_dir, $top_item);
+ $Is_Dir= 1;
+ }
+ }
+ else { # no follow
+ $topdir = $top_item;
+ unless (defined $topnlink) {
+ warnings::warnif "Can't stat $top_item: $!\n";
+ next Proc_Top_Item;
+ }
+ if (-d _) {
+ $top_item =~ s/\.dir\z//i if $Is_VMS;
+ _find_dir($wanted, $top_item, $topnlink);
+ $Is_Dir= 1;
+ }
+ else {
+ $abs_dir= $top_item;
+ }
+ }
-C<follow_skip==2> causes File::Find to ignore any duplicate files and
-directories but to proceed normally otherwise.
+ unless ($Is_Dir) {
+ unless (($_,$dir) = File::Basename::fileparse($abs_dir)) {
+ ($dir,$_) = ('./', $top_item);
+ }
-=item C<dangling_symlinks>
+ $abs_dir = $dir;
+ if (( $untaint ) && (is_tainted($dir) )) {
+ ( $abs_dir ) = $dir =~ m|$untaint_pat|;
+ unless (defined $abs_dir) {
+ if ($untaint_skip == 0) {
+ die "directory $dir is still tainted";
+ }
+ else {
+ next Proc_Top_Item;
+ }
+ }
+ }
-If true and a code reference, will be called with the symbolic link
-name and the directory it lives in as arguments. Otherwise, if true
-and warnings are on, warning "symbolic_link_name is a dangling
-symbolic link\n" will be issued. If false, the dangling symbolic link
-will be silently ignored.
+ unless ($no_chdir || chdir $abs_dir) {
+ warnings::warnif "Couldn't chdir $abs_dir: $!\n";
+ next Proc_Top_Item;
+ }
-=item C<no_chdir>
+ $name = $abs_dir . $_; # $File::Find::name
+ $_ = $name if $no_chdir;
-Does not C<chdir()> to each directory as it recurses. The C<wanted()>
-function will need to be aware of this, of course. In this case,
-C<$_> will be the same as C<$File::Find::name>.
+ { $wanted_callback->() }; # protect against wild "next"
-=item C<untaint>
+ }
-If find is used in taint-mode (-T command line switch or if EUID != UID
-or if EGID != GID) then internally directory names have to be untainted
-before they can be chdir'ed to. Therefore they are checked against a regular
-expression I<untaint_pattern>. Note that all names passed to the user's
-I<wanted()> function are still tainted. If this option is used while
-not in taint-mode, C<untaint> is a no-op.
+ unless ( $no_chdir ) {
+ if ( ($check_t_cwd) && (($untaint) && (is_tainted($cwd) )) ) {
+ ( $cwd_untainted ) = $cwd =~ m|$untaint_pat|;
+ unless (defined $cwd_untainted) {
+ die "insecure cwd in find(depth)";
+ }
+ $check_t_cwd = 0;
+ }
+ unless (chdir $cwd_untainted) {
+ die "Can't cd to $cwd: $!\n";
+ }
+ }
+ }
+}
-=item C<untaint_pattern>
+# API:
+# $wanted
+# $p_dir : "parent directory"
+# $nlink : what came back from the stat
+# preconditions:
+# chdir (if not no_chdir) to dir
-See above. This should be set using the C<qr> quoting operator.
-The default is set to C<qr|^([-+@\w./]+)$|>.
-Note that the parentheses are vital.
+sub _find_dir($$$) {
+ my ($wanted, $p_dir, $nlink) = @_;
+ my ($CdLvl,$Level) = (0,0);
+ my @Stack;
+ my @filenames;
+ my ($subcount,$sub_nlink);
+ my $SE= [];
+ my $dir_name= $p_dir;
+ my $dir_pref;
+ my $dir_rel = $File::Find::current_dir;
+ my $tainted = 0;
+ my $no_nlink;
-=item C<untaint_skip>
+ if ($Is_Win32) {
+ $dir_pref
+ = ($p_dir =~ m{^(?:\w:[/\\]?|[/\\])$} ? $p_dir : "$p_dir/" );
+ } elsif ($Is_VMS) {
-If set, a directory which fails the I<untaint_pattern> is skipped,
-including all its sub-directories. The default is to 'die' in such a case.
+ # VMS is returning trailing .dir on directories
+ # and trailing . on files and symbolic links
+ # in UNIX syntax.
+ #
-=back
+ $p_dir =~ s/\.(dir)?$//i unless $p_dir eq '.';
-=head2 The wanted function
+ $dir_pref = ($p_dir =~ m/[\]>]+$/ ? $p_dir : "$p_dir/" );
+ }
+ else {
+ $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" );
+ }
-The C<wanted()> function does whatever verifications you want on
-each file and directory. Note that despite its name, the C<wanted()>
-function is a generic callback function, and does B<not> tell
-File::Find if a file is "wanted" or not. In fact, its return value
-is ignored.
+ local ($dir, $name, $prune, *DIR);
-The wanted function takes no arguments but rather does its work
-through a collection of variables.
+ unless ( $no_chdir || ($p_dir eq $File::Find::current_dir)) {
+ my $udir = $p_dir;
+ if (( $untaint ) && (is_tainted($p_dir) )) {
+ ( $udir ) = $p_dir =~ m|$untaint_pat|;
+ unless (defined $udir) {
+ if ($untaint_skip == 0) {
+ die "directory $p_dir is still tainted";
+ }
+ else {
+ return;
+ }
+ }
+ }
+ unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) {
+ warnings::warnif "Can't cd to $udir: $!\n";
+ return;
+ }
+ }
-=over 4
+ # push the starting directory
+ push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth;
-=item C<$File::Find::dir> is the current directory name,
+ while (defined $SE) {
+ unless ($bydepth) {
+ $dir= $p_dir; # $File::Find::dir
+ $name= $dir_name; # $File::Find::name
+ $_= ($no_chdir ? $dir_name : $dir_rel ); # $_
+ # prune may happen here
+ $prune= 0;
+ { $wanted_callback->() }; # protect against wild "next"
+ next if $prune;
+ }
-=item C<$_> is the current filename within that directory
+ # change to that directory
+ unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
+ my $udir= $dir_rel;
+ if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_rel)
)) ) {
+ ( $udir ) = $dir_rel =~ m|$untaint_pat|;
+ unless (defined $udir) {
+ if ($untaint_skip == 0) {
+ die "directory (" . ($p_dir ne '/' ? $p_dir : '') . "/)
$dir_rel is still tainted";
+ } else { # $untaint_skip == 1
+ next;
+ }
+ }
+ }
+ unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir))
{
+ warnings::warnif "Can't cd to (" .
+ ($p_dir ne '/' ? $p_dir : '') . "/) $udir: $!\n";
+ next;
+ }
+ $CdLvl++;
+ }
-=item C<$File::Find::name> is the complete pathname to the file.
+ $dir= $dir_name; # $File::Find::dir
-=back
+ # Get the list of files in the current directory.
+ unless (opendir DIR, ($no_chdir ? $dir_name :
$File::Find::current_dir)) {
+ warnings::warnif "Can't opendir($dir_name): $!\n";
+ next;
+ }
+ @filenames = readdir DIR;
+ closedir(DIR);
+ @filenames = $pre_process->(@filenames) if $pre_process;
+ push @Stack,[$CdLvl,$dir_name,"",-2] if $post_process;
-The above variables have all been localized and may be changed without
-affecting data outside of the wanted function.
+ # default: use whatever was specified
+ # (if $nlink >= 2, and $avoid_nlink == 0, this will switch back)
+ $no_nlink = $avoid_nlink;
+ # if dir has wrong nlink count, force switch to slower stat method
+ $no_nlink = 1 if ($nlink < 2);
-For example, when examining the file F</some/path/foo.ext> you will have:
+ if ($nlink == 2 && !$no_nlink) {
+ # This dir has no subdirectories.
+ for my $FN (@filenames) {
+ if ($Is_VMS) {
+ # Big hammer here - Compensate for VMS trailing . and .dir
+ # No win situation until this is changed, but this
+ # will handle the majority of the cases with breaking the fewest
- $File::Find::dir = /some/path/
- $_ = foo.ext
- $File::Find::name = /some/path/foo.ext
+ $FN =~ s/\.dir\z//i;
+ $FN =~ s#\.$## if ($FN ne '.');
+ }
+ next if $FN =~ $File::Find::skip_pattern;
+
+ $name = $dir_pref . $FN; # $File::Find::name
+ $_ = ($no_chdir ? $name : $FN); # $_
+ { $wanted_callback->() }; # protect against wild "next"
+ }
-You are chdir()'d to C<$File::Find::dir> when the function is called,
-unless C<no_chdir> was specified. Note that when changing to
-directories is in effect the root directory (F</>) is a somewhat
-special case inasmuch as the concatenation of C<$File::Find::dir>,
-C<'/'> and C<$_> is not literally equal to C<$File::Find::name>. The
-table below summarizes all variants:
+ }
+ else {
+ # This dir has subdirectories.
+ $subcount = $nlink - 2;
- $File::Find::name $File::Find::dir $_
- default / / .
- no_chdir=>0 /etc / etc
- /etc/x /etc x
+ # HACK: insert directories at this position. so as to preserve
+ # the user pre-processed ordering of files.
+ # EG: directory traversal is in user sorted order, not at random.
+ my $stack_top = @Stack;
- no_chdir=>1 / / /
- /etc / /etc
- /etc/x /etc /etc/x
+ for my $FN (@filenames) {
+ next if $FN =~ $File::Find::skip_pattern;
+ if ($subcount > 0 || $no_nlink) {
+ # Seen all the subdirs?
+ # check for directoriness.
+ # stat is faster for a file in the current directory
+ $sub_nlink = (lstat ($no_chdir ? $dir_pref . $FN : $FN))[3];
+ if (-d _) {
+ --$subcount;
+ $FN =~ s/\.dir\z//i if $Is_VMS;
+ # HACK: replace push to preserve dir traversal order
+ #push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink];
+ splice @Stack, $stack_top, 0,
+ [$CdLvl,$dir_name,$FN,$sub_nlink];
+ }
+ else {
+ $name = $dir_pref . $FN; # $File::Find::name
+ $_= ($no_chdir ? $name : $FN); # $_
+ { $wanted_callback->() }; # protect against wild "next"
+ }
+ }
+ else {
+ $name = $dir_pref . $FN; # $File::Find::name
+ $_= ($no_chdir ? $name : $FN); # $_
+ { $wanted_callback->() }; # protect against wild "next"
+ }
+ }
+ }
+ }
+ continue {
+ while ( defined ($SE = pop @Stack) ) {
+ ($Level, $p_dir, $dir_rel, $nlink) = @$SE;
+ if ($CdLvl > $Level && !$no_chdir) {
+ my $tmp;
+ if ($Is_VMS) {
+ $tmp = '[' . ('-' x ($CdLvl-$Level)) . ']';
+ }
+ else {
+ $tmp = join('/',('..') x ($CdLvl-$Level));
+ }
+ die "Can't cd to $tmp from $dir_name: $!"
+ unless chdir ($tmp);
+ $CdLvl = $Level;
+ }
-When C<follow> or C<follow_fast> are in effect, there is
-also a C<$File::Find::fullname>. The function may set
-C<$File::Find::prune> to prune the tree unless C<bydepth> was
-specified. Unless C<follow> or C<follow_fast> is specified, for
-compatibility reasons (find.pl, find2perl) there are in addition the
-following globals available: C<$File::Find::topdir>,
-C<$File::Find::topdev>, C<$File::Find::topino>,
-C<$File::Find::topmode> and C<$File::Find::topnlink>.
+ if ($Is_Win32) {
+ $dir_name = ($p_dir =~ m{^(?:\w:[/\\]?|[/\\])$}
+ ? "$p_dir$dir_rel" : "$p_dir/$dir_rel");
+ $dir_pref = "$dir_name/";
+ }
+ elsif ($^O eq 'VMS') {
+ if ($p_dir =~ m/[\]>]+$/) {
+ $dir_name = $p_dir;
+ $dir_name =~ s/([\]>]+)$/.$dir_rel$1/;
+ $dir_pref = $dir_name;
+ }
+ else {
+ $dir_name = "$p_dir/$dir_rel";
+ $dir_pref = "$dir_name/";
+ }
+ }
+ else {
+ $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
+ $dir_pref = "$dir_name/";
+ }
-This library is useful for the C<find2perl> tool, which when fed,
+ if ( $nlink == -2 ) {
+ $name = $dir = $p_dir; # $File::Find::name / dir
+ $_ = $File::Find::current_dir;
+ $post_process->(); # End-of-directory processing
+ }
+ elsif ( $nlink < 0 ) { # must be finddepth, report dirname now
+ $name = $dir_name;
+ if ( substr($name,-2) eq '/.' ) {
+ substr($name, length($name) == 2 ? -1 : -2) = '';
+ }
+ $dir = $p_dir;
+ $_ = ($no_chdir ? $dir_name : $dir_rel );
+ if ( substr($_,-2) eq '/.' ) {
+ substr($_, length($_) == 2 ? -1 : -2) = '';
+ }
+ { $wanted_callback->() }; # protect against wild "next"
+ }
+ else {
+ push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth;
+ last;
+ }
+ }
+ }
+}
- find2perl / -name .nfs\* -mtime +7 \
- -exec rm -f {} \; -o -fstype nfs -prune
-produces something like:
+# API:
+# $wanted
+# $dir_loc : absolute location of a dir
+# $p_dir : "parent directory"
+# preconditions:
+# chdir (if not no_chdir) to dir
- sub wanted {
- /^\.nfs.*\z/s &&
- (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_)) &&
- int(-M _) > 7 &&
- unlink($_)
- ||
- ($nlink || (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))) &&
- $dev < 0 &&
- ($File::Find::prune = 1);
- }
+sub _find_dir_symlnk($$$) {
+ my ($wanted, $dir_loc, $p_dir) = @_; # $dir_loc is the absolute directory
+ my @Stack;
+ my @filenames;
+ my $new_loc;
+ my $updir_loc = $dir_loc; # untainted parent directory
+ my $SE = [];
+ my $dir_name = $p_dir;
+ my $dir_pref;
+ my $loc_pref;
+ my $dir_rel = $File::Find::current_dir;
+ my $byd_flag; # flag for pending stack entry if $bydepth
+ my $tainted = 0;
+ my $ok = 1;
-Notice the C<_> in the above C<int(-M _)>: the C<_> is a magical
-filehandle that caches the information from the preceding
-C<stat()>, C<lstat()>, or filetest.
+ $dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" );
+ $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" );
-Here's another interesting wanted function. It will find all symbolic
-links that don't resolve:
+ local ($dir, $name, $fullname, $prune, *DIR);
- sub wanted {
- -l && !-e && print "bogus link: $File::Find::name\n";
+ unless ($no_chdir) {
+ # untaint the topdir
+ if (( $untaint ) && (is_tainted($dir_loc) )) {
+ ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|; # parent dir, now
untainted
+ # once untainted, $updir_loc is pushed on the stack (as parent
directory);
+ # hence, we don't need to untaint the parent directory every time
we chdir
+ # to it later
+ unless (defined $updir_loc) {
+ if ($untaint_skip == 0) {
+ die "directory $dir_loc is still tainted";
+ }
+ else {
+ return;
+ }
+ }
+ }
+ $ok = chdir($updir_loc) unless ($p_dir eq $File::Find::current_dir);
+ unless ($ok) {
+ warnings::warnif "Can't cd to $updir_loc: $!\n";
+ return;
+ }
}
-Note that you may mix directories and (non-directory) files in the list of
-directories to be searched by the C<wanted()> function.
+ push @Stack,[$dir_loc,$updir_loc,$p_dir,$dir_rel,-1] if $bydepth;
- find(\&wanted, "./foo", "./bar", "./baz/epsilon");
+ while (defined $SE) {
-In the example above, no file in F<./baz/> other than F<./baz/epsilon> will be
-evaluated by C<wanted()>.
+ unless ($bydepth) {
+ # change (back) to parent directory (always untainted)
+ unless ($no_chdir) {
+ unless (chdir $updir_loc) {
+ warnings::warnif "Can't cd to $updir_loc: $!\n";
+ next;
+ }
+ }
+ $dir= $p_dir; # $File::Find::dir
+ $name= $dir_name; # $File::Find::name
+ $_= ($no_chdir ? $dir_name : $dir_rel ); # $_
+ $fullname= $dir_loc; # $File::Find::fullname
+ # prune may happen here
+ $prune= 0;
+ lstat($_); # make sure file tests with '_' work
+ { $wanted_callback->() }; # protect against wild "next"
+ next if $prune;
+ }
-See also the script C<pfind> on CPAN for a nice application of this
-module.
+ # change to that directory
+ unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
+ $updir_loc = $dir_loc;
+ if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_loc)
)) ) {
+ # untaint $dir_loc, what will be pushed on the stack as
(untainted) parent dir
+ ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|;
+ unless (defined $updir_loc) {
+ if ($untaint_skip == 0) {
+ die "directory $dir_loc is still tainted";
+ }
+ else {
+ next;
+ }
+ }
+ }
+ unless (chdir $updir_loc) {
+ warnings::warnif "Can't cd to $updir_loc: $!\n";
+ next;
+ }
+ }
-=head1 WARNINGS
+ $dir = $dir_name; # $File::Find::dir
-If you run your program with the C<-w> switch, or if you use the
-C<warnings> pragma, File::Find will report warnings for several weird
-situations. You can disable these warnings by putting the statement
+ # Get the list of files in the current directory.
+ unless (opendir DIR, ($no_chdir ? $dir_loc : $File::Find::current_dir))
{
+ warnings::warnif "Can't opendir($dir_loc): $!\n";
+ next;
+ }
+ @filenames = readdir DIR;
+ closedir(DIR);
- no warnings 'File::Find';
+ for my $FN (@filenames) {
+ if ($Is_VMS) {
+ # Big hammer here - Compensate for VMS trailing . and .dir
+ # No win situation until this is changed, but this
+ # will handle the majority of the cases with breaking the fewest.
-in the appropriate scope. See L<warnings> for more info about lexical
-warnings.
+ $FN =~ s/\.dir\z//i;
+ $FN =~ s#\.$## if ($FN ne '.');
+ }
+ next if $FN =~ $File::Find::skip_pattern;
-=head1 CAVEAT
+ # follow symbolic links / do an lstat
+ $new_loc = Follow_SymLink($loc_pref.$FN);
-=over 2
+ # ignore if invalid symlink
+ unless (defined $new_loc) {
+ if (!defined -l _ && $dangling_symlinks) {
+ $fullname = undef;
+ if (ref $dangling_symlinks eq 'CODE') {
+ $dangling_symlinks->($FN, $dir_pref);
+ } else {
+ warnings::warnif "$dir_pref$FN is a dangling symbolic
link\n";
+ }
+ }
+ else {
+ $fullname = $loc_pref . $FN;
+ }
+ $name = $dir_pref . $FN;
+ $_ = ($no_chdir ? $name : $FN);
+ { $wanted_callback->() };
+ next;
+ }
-=item $dont_use_nlink
+ if (-d _) {
+ if ($Is_VMS) {
+ $FN =~ s/\.dir\z//i;
+ $FN =~ s#\.$## if ($FN ne '.');
+ $new_loc =~ s/\.dir\z//i;
+ $new_loc =~ s#\.$## if ($new_loc ne '.');
+ }
+ push @Stack,[$new_loc,$updir_loc,$dir_name,$FN,1];
+ }
+ else {
+ $fullname = $new_loc; # $File::Find::fullname
+ $name = $dir_pref . $FN; # $File::Find::name
+ $_ = ($no_chdir ? $name : $FN); # $_
+ { $wanted_callback->() }; # protect against wild "next"
+ }
+ }
-You can set the variable C<$File::Find::dont_use_nlink> to 1, if you want to
-force File::Find to always stat directories. This was used for file systems
-that do not have an C<nlink> count matching the number of sub-directories.
-Examples are ISO-9660 (CD-ROM), AFS, HPFS (OS/2 file system), FAT (DOS file
-system) and a couple of others.
+ }
+ continue {
+ while (defined($SE = pop @Stack)) {
+ ($dir_loc, $updir_loc, $p_dir, $dir_rel, $byd_flag) = @$SE;
+ $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
+ $dir_pref = "$dir_name/";
+ $loc_pref = "$dir_loc/";
+ if ( $byd_flag < 0 ) { # must be finddepth, report dirname now
+ unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
+ unless (chdir $updir_loc) { # $updir_loc (parent dir) is
always untainted
+ warnings::warnif "Can't cd to $updir_loc: $!\n";
+ next;
+ }
+ }
+ $fullname = $dir_loc; # $File::Find::fullname
+ $name = $dir_name; # $File::Find::name
+ if ( substr($name,-2) eq '/.' ) {
+ substr($name, length($name) == 2 ? -1 : -2) = ''; #
$File::Find::name
+ }
+ $dir = $p_dir; # $File::Find::dir
+ $_ = ($no_chdir ? $dir_name : $dir_rel); # $_
+ if ( substr($_,-2) eq '/.' ) {
+ substr($_, length($_) == 2 ? -1 : -2) = '';
+ }
-You shouldn't need to set this variable, since File::Find should now detect
-such file systems on-the-fly and switch itself to using stat. This works even
-for parts of your file system, like a mounted CD-ROM.
+ lstat($_); # make sure file tests with '_' work
+ { $wanted_callback->() }; # protect against wild "next"
+ }
+ else {
+ push @Stack,[$dir_loc, $updir_loc, $p_dir, $dir_rel,-1] if
$bydepth;
+ last;
+ }
+ }
+ }
+}
-If you do set C<$File::Find::dont_use_nlink> to 1, you will notice slow-downs.
-=item symlinks
+sub wrap_wanted {
+ my $wanted = shift;
+ if ( ref($wanted) eq 'HASH' ) {
+ # RT #122547
+ my %valid_options = map {$_ => 1} qw(
+ wanted
+ bydepth
+ preprocess
+ postprocess
+ follow
+ follow_fast
+ follow_skip
+ dangling_symlinks
+ no_chdir
+ untaint
+ untaint_pattern
+ untaint_skip
+ );
+ my @invalid_options = ();
+ for my $v (keys %{$wanted}) {
+ push @invalid_options, $v unless exists $valid_options{$v};
+ }
+ warn "Invalid option(s): @invalid_options" if @invalid_options;
+
+ unless( exists $wanted->{wanted} and ref( $wanted->{wanted} ) eq
'CODE' ) {
+ die 'no &wanted subroutine given';
+ }
+ if ( $wanted->{follow} || $wanted->{follow_fast}) {
+ $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip};
+ }
+ if ( $wanted->{untaint} ) {
+ $wanted->{untaint_pattern} = $File::Find::untaint_pattern
+ unless defined $wanted->{untaint_pattern};
+ $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip};
+ }
+ return $wanted;
+ }
+ elsif( ref( $wanted ) eq 'CODE' ) {
+ return { wanted => $wanted };
+ }
+ else {
+ die 'no &wanted subroutine given';
+ }
+}
-Be aware that the option to follow symbolic links can be dangerous.
-Depending on the structure of the directory tree (including symbolic
-links to directories) you might traverse a given (physical) directory
-more than once (only if C<follow_fast> is in effect).
-Furthermore, deleting or changing files in a symbolically linked directory
-might cause very unpleasant surprises, since you delete or change files
-in an unknown directory.
+sub find {
+ my $wanted = shift;
+ _find_opt(wrap_wanted($wanted), @_);
+}
-=back
+sub finddepth {
+ my $wanted = wrap_wanted(shift);
+ $wanted->{bydepth} = 1;
+ _find_opt($wanted, @_);
+}
-=head1 BUGS AND CAVEATS
+# default
+$File::Find::skip_pattern = qr/^\.{1,2}\z/;
+$File::Find::untaint_pattern = qr|^([-+@\w./]+)$|;
-Despite the name of the C<finddepth()> function, both C<find()> and
-C<finddepth()> perform a depth-first search of the directory
-hierarchy.
+# These are hard-coded for now, but may move to hint files.
+if ($^O eq 'VMS') {
+ $Is_VMS = 1;
+ $File::Find::dont_use_nlink = 1;
+}
+elsif ($^O eq 'MSWin32') {
+ $Is_Win32 = 1;
+}
-=head1 HISTORY
+# this _should_ work properly on all platforms
+# where File::Find can be expected to work
+$File::Find::current_dir = File::Spec->curdir || '.';
-File::Find used to produce incorrect results if called recursively.
-During the development of perl 5.8 this bug was fixed.
-The first fixed version of File::Find was 1.01.
+$File::Find::dont_use_nlink = 1
+ if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $Is_Win32 ||
+ $^O eq 'interix' || $^O eq 'cygwin' || $^O eq 'qnx' || $^O eq 'nto';
-=head1 SEE ALSO
+# Set dont_use_nlink in your hint file if your system's stat doesn't
+# report the number of links in a directory as an indication
+# of the number of files.
+# See, e.g. hints/machten.sh for MachTen 2.2.
+unless ($File::Find::dont_use_nlink) {
+ require Config;
+ $File::Find::dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'});
+}
-find, find2perl.
+# We need a function that checks if a scalar is tainted. Either use the
+# Scalar::Util module's tainted() function or our (slower) pure Perl
+# fallback is_tainted_pp()
+{
+ local $@;
+ eval { require Scalar::Util };
+ *is_tainted = $@ ? \&is_tainted_pp : \&Scalar::Util::tainted;
+}
-=cut
+1;
-our @ISA = qw(Exporter);
-our @EXPORT = qw(find finddepth);
+__END__
+#
+# Modified to ensure sub-directory traversal order is not inverted by stack
+# push and pops. That is remains in the same order as in the directory file,
+# or user pre-processing (EG:sorted).
+#
+=head1 NAME
-use strict;
-my $Is_VMS;
-my $Is_Win32;
+File::Find - Traverse a directory tree.
-require File::Basename;
-require File::Spec;
+=head1 SYNOPSIS
-# Should ideally be my() not our() but local() currently
-# refuses to operate on lexicals
+ use File::Find;
+ find(\&wanted, @directories_to_search);
+ sub wanted { ... }
-our %SLnkSeen;
-our ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
- $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
- $pre_process, $post_process, $dangling_symlinks);
+ use File::Find;
+ finddepth(\&wanted, @directories_to_search);
+ sub wanted { ... }
-sub contract_name {
- my ($cdir,$fn) = @_;
+ use File::Find;
+ find({ wanted => \&process, follow => 1 }, '.');
- return substr($cdir,0,rindex($cdir,'/')) if $fn eq
$File::Find::current_dir;
+=head1 DESCRIPTION
- $cdir = substr($cdir,0,rindex($cdir,'/')+1);
+These are functions for searching through directory trees doing work
+on each file found similar to the Unix I<find> command. File::Find
+exports two functions, C<find> and C<finddepth>. They work similarly
+but have subtle differences.
- $fn =~ s|^\./||;
+=over 4
- my $abs_name= $cdir . $fn;
+=item B<find>
- if (substr($fn,0,3) eq '../') {
- 1 while $abs_name =~ s!/[^/]*/\.\./+!/!;
- }
+ find(\&wanted, @directories);
+ find(\%options, @directories);
- return $abs_name;
-}
+C<find()> does a depth-first search over the given C<@directories> in
+the order they are given. For each file or directory found, it calls
+the C<&wanted> subroutine. (See below for details on how to use the
+C<&wanted> function). Additionally, for each directory found, it will
+C<chdir()> into that directory and continue the search, invoking the
+C<&wanted> function on each file or subdirectory in the directory.
-sub PathCombine($$) {
- my ($Base,$Name) = @_;
- my $AbsName;
+=item B<finddepth>
- if (substr($Name,0,1) eq '/') {
- $AbsName= $Name;
- }
- else {
- $AbsName= contract_name($Base,$Name);
- }
+ finddepth(\&wanted, @directories);
+ finddepth(\%options, @directories);
- # (simple) check for recursion
- my $newlen= length($AbsName);
- if ($newlen <= length($Base)) {
- if (($newlen == length($Base) || substr($Base,$newlen,1) eq '/')
- && $AbsName eq substr($Base,0,$newlen))
- {
- return undef;
- }
- }
- return $AbsName;
-}
+C<finddepth()> works just like C<find()> except that it invokes the
+C<&wanted> function for a directory I<after> invoking it for the
+directory's contents. It does a postorder traversal instead of a
+preorder traversal, working from the bottom of the directory tree up
+where C<find()> works from the top of the tree down.
-sub Follow_SymLink($) {
- my ($AbsName) = @_;
+=back
- my ($NewName,$DEV, $INO);
- ($DEV, $INO)= lstat $AbsName;
+=head2 %options
- while (-l _) {
- if ($SLnkSeen{$DEV, $INO}++) {
- if ($follow_skip < 2) {
- die "$AbsName is encountered a second time";
- }
- else {
- return undef;
- }
- }
- $NewName= PathCombine($AbsName, readlink($AbsName));
- unless(defined $NewName) {
- if ($follow_skip < 2) {
- die "$AbsName is a recursive symbolic link";
- }
- else {
- return undef;
- }
- }
- else {
- $AbsName= $NewName;
- }
- ($DEV, $INO) = lstat($AbsName);
- return undef unless defined $DEV; # dangling symbolic link
- }
+The first argument to C<find()> is either a code reference to your
+C<&wanted> function, or a hash reference describing the operations
+to be performed for each file. The
+code reference is described in L<The wanted function> below.
- if ($full_check && defined $DEV && $SLnkSeen{$DEV, $INO}++) {
- if ( ($follow_skip < 1) || ((-d _) && ($follow_skip < 2)) ) {
- die "$AbsName encountered a second time";
- }
- else {
- return undef;
- }
- }
+Here are the possible keys for the hash:
- return $AbsName;
-}
+=over 3
-our($dir, $name, $fullname, $prune);
-sub _find_dir_symlnk($$$);
-sub _find_dir($$$);
+=item C<wanted>
-# check whether or not a scalar variable is tainted
-# (code straight from the Camel, 3rd ed., page 561)
-sub is_tainted_pp {
- my $arg = shift;
- my $nada = substr($arg, 0, 0); # zero-length
- local $@;
- eval { eval "# $nada" };
- return length($@) != 0;
-}
+The value should be a code reference. This code reference is
+described in L<The wanted function> below. The C<&wanted> subroutine is
+mandatory.
-sub _find_opt {
- my $wanted = shift;
- die "invalid top directory" unless defined $_[0];
+=item C<bydepth>
- # This function must local()ize everything because callbacks may
- # call find() or finddepth()
+Reports the name of a directory only AFTER all its entries
+have been reported. Entry point C<finddepth()> is a shortcut for
+specifying C<< { bydepth => 1 } >> in the first argument of C<find()>.
- local %SLnkSeen;
- local ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
- $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
- $pre_process, $post_process, $dangling_symlinks);
- local($dir, $name, $fullname, $prune);
- local *_ = \my $a;
+=item C<preprocess>
- my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::getcwd();
- if ($Is_VMS) {
- # VMS returns this by default in VMS format which just doesn't
- # work for the rest of this module.
- $cwd = VMS::Filespec::unixpath($cwd);
+The value should be a code reference. This code reference is used to
+preprocess the current directory. The name of the currently processed
+directory is in C<$File::Find::dir>. Your preprocessing function is
+called after C<readdir()>, but before the loop that calls the C<wanted()>
+function. It is called with a list of strings (actually file/directory
+names) and is expected to return a list of strings. The code can be
+used to sort the file/directory names alphabetically, numerically,
+or to filter out directory entries based on their name alone. When
+I<follow> or I<follow_fast> are in effect, C<preprocess> is a no-op.
- # Apparently this is not expected to have a trailing space.
- # To attempt to make VMS/UNIX conversions mostly reversible,
- # a trailing slash is needed. The run-time functions ignore the
- # resulting double slash, but it causes the perl tests to fail.
- $cwd =~ s#/\z##;
+=item C<postprocess>
- # This comes up in upper case now, but should be lower.
- # In the future this could be exact case, no need to change.
- }
- my $cwd_untainted = $cwd;
- my $check_t_cwd = 1;
- $wanted_callback = $wanted->{wanted};
- $bydepth = $wanted->{bydepth};
- $pre_process = $wanted->{preprocess};
- $post_process = $wanted->{postprocess};
- $no_chdir = $wanted->{no_chdir};
- $full_check = $Is_Win32 ? 0 : $wanted->{follow};
- $follow = $Is_Win32 ? 0 :
- $full_check || $wanted->{follow_fast};
- $follow_skip = $wanted->{follow_skip};
- $untaint = $wanted->{untaint};
- $untaint_pat = $wanted->{untaint_pattern};
- $untaint_skip = $wanted->{untaint_skip};
- $dangling_symlinks = $wanted->{dangling_symlinks};
+The value should be a code reference. It is invoked just before leaving
+the currently processed directory. It is called in void context with no
+arguments. The name of the current directory is in C<$File::Find::dir>. This
+hook is handy for summarizing a directory, such as calculating its disk
+usage. When I<follow> or I<follow_fast> are in effect, C<postprocess> is a
+no-op.
- # for compatibility reasons (find.pl, find2perl)
- local our ($topdir, $topdev, $topino, $topmode, $topnlink);
+=item C<follow>
- # a symbolic link to a directory doesn't increase the link count
- $avoid_nlink = $follow || $File::Find::dont_use_nlink;
+Causes symbolic links to be followed. Since directory trees with symbolic
+links (followed) may contain files more than once and may even have
+cycles, a hash has to be built up with an entry for each file.
+This might be expensive both in space and time for a large
+directory tree. See L</follow_fast> and L</follow_skip> below.
+If either I<follow> or I<follow_fast> is in effect:
- my ($abs_dir, $Is_Dir);
+=over 6
- Proc_Top_Item:
- foreach my $TOP (@_) {
- my $top_item = $TOP;
- $top_item = VMS::Filespec::unixify($top_item) if $Is_VMS;
+=item *
- ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat
$top_item;
+It is guaranteed that an I<lstat> has been called before the user's
+C<wanted()> function is called. This enables fast file checks involving S<_>.
+Note that this guarantee no longer holds if I<follow> or I<follow_fast>
+are not set.
- if ($Is_Win32) {
- $top_item =~ s|[/\\]\z||
- unless $top_item =~ m{^(?:\w:)?[/\\]$};
- }
- else {
- $top_item =~ s|/\z|| unless $top_item eq '/';
- }
+=item *
- $Is_Dir= 0;
+There is a variable C<$File::Find::fullname> which holds the absolute
+pathname of the file with all symbolic links resolved. If the link is
+a dangling symbolic link, then fullname will be set to C<undef>.
- if ($follow) {
+=back
- if (substr($top_item,0,1) eq '/') {
- $abs_dir = $top_item;
- }
- elsif ($top_item eq $File::Find::current_dir) {
- $abs_dir = $cwd;
- }
- else { # care about any ../
- $top_item =~ s/\.dir\z//i if $Is_VMS;
- $abs_dir = contract_name("$cwd/",$top_item);
- }
- $abs_dir= Follow_SymLink($abs_dir);
- unless (defined $abs_dir) {
- if ($dangling_symlinks) {
- if (ref $dangling_symlinks eq 'CODE') {
- $dangling_symlinks->($top_item, $cwd);
- } else {
- warnings::warnif "$top_item is a dangling symbolic
link\n";
- }
- }
- next Proc_Top_Item;
- }
+This is a no-op on Win32.
- if (-d _) {
- $top_item =~ s/\.dir\z//i if $Is_VMS;
- _find_dir_symlnk($wanted, $abs_dir, $top_item);
- $Is_Dir= 1;
- }
- }
- else { # no follow
- $topdir = $top_item;
- unless (defined $topnlink) {
- warnings::warnif "Can't stat $top_item: $!\n";
- next Proc_Top_Item;
- }
- if (-d _) {
- $top_item =~ s/\.dir\z//i if $Is_VMS;
- _find_dir($wanted, $top_item, $topnlink);
- $Is_Dir= 1;
- }
- else {
- $abs_dir= $top_item;
- }
- }
+=item C<follow_fast>
- unless ($Is_Dir) {
- unless (($_,$dir) = File::Basename::fileparse($abs_dir)) {
- ($dir,$_) = ('./', $top_item);
- }
+This is similar to I<follow> except that it may report some files more
+than once. It does detect cycles, however. Since only symbolic links
+have to be hashed, this is much cheaper both in space and time. If
+processing a file more than once (by the user's C<wanted()> function)
+is worse than just taking time, the option I<follow> should be used.
- $abs_dir = $dir;
- if (( $untaint ) && (is_tainted($dir) )) {
- ( $abs_dir ) = $dir =~ m|$untaint_pat|;
- unless (defined $abs_dir) {
- if ($untaint_skip == 0) {
- die "directory $dir is still tainted";
- }
- else {
- next Proc_Top_Item;
- }
- }
- }
+This is also a no-op on Win32.
- unless ($no_chdir || chdir $abs_dir) {
- warnings::warnif "Couldn't chdir $abs_dir: $!\n";
- next Proc_Top_Item;
- }
+=item C<follow_skip>
- $name = $abs_dir . $_; # $File::Find::name
- $_ = $name if $no_chdir;
+C<follow_skip==1>, which is the default, causes all files which are
+neither directories nor symbolic links to be ignored if they are about
+to be processed a second time. If a directory or a symbolic link
+are about to be processed a second time, File::Find dies.
- { $wanted_callback->() }; # protect against wild "next"
+C<follow_skip==0> causes File::Find to die if any file is about to be
+processed a second time.
- }
+C<follow_skip==2> causes File::Find to ignore any duplicate files and
+directories but to proceed normally otherwise.
- unless ( $no_chdir ) {
- if ( ($check_t_cwd) && (($untaint) && (is_tainted($cwd) )) ) {
- ( $cwd_untainted ) = $cwd =~ m|$untaint_pat|;
- unless (defined $cwd_untainted) {
- die "insecure cwd in find(depth)";
- }
- $check_t_cwd = 0;
- }
- unless (chdir $cwd_untainted) {
- die "Can't cd to $cwd: $!\n";
- }
- }
- }
-}
+=item C<dangling_symlinks>
-# API:
-# $wanted
-# $p_dir : "parent directory"
-# $nlink : what came back from the stat
-# preconditions:
-# chdir (if not no_chdir) to dir
+If true and a code reference, will be called with the symbolic link
+name and the directory it lives in as arguments. Otherwise, if true
+and warnings are on, warning "symbolic_link_name is a dangling
+symbolic link\n" will be issued. If false, the dangling symbolic link
+will be silently ignored.
-sub _find_dir($$$) {
- my ($wanted, $p_dir, $nlink) = @_;
- my ($CdLvl,$Level) = (0,0);
- my @Stack;
- my @filenames;
- my ($subcount,$sub_nlink);
- my $SE= [];
- my $dir_name= $p_dir;
- my $dir_pref;
- my $dir_rel = $File::Find::current_dir;
- my $tainted = 0;
- my $no_nlink;
+=item C<no_chdir>
- if ($Is_Win32) {
- $dir_pref
- = ($p_dir =~ m{^(?:\w:[/\\]?|[/\\])$} ? $p_dir : "$p_dir/" );
- } elsif ($Is_VMS) {
+Does not C<chdir()> to each directory as it recurses. The C<wanted()>
+function will need to be aware of this, of course. In this case,
+C<$_> will be the same as C<$File::Find::name>.
- # VMS is returning trailing .dir on directories
- # and trailing . on files and symbolic links
- # in UNIX syntax.
- #
+=item C<untaint>
- $p_dir =~ s/\.(dir)?$//i unless $p_dir eq '.';
+If find is used in taint-mode (-T command line switch or if EUID != UID
+or if EGID != GID) then internally directory names have to be untainted
+before they can be chdir'ed to. Therefore they are checked against a regular
+expression I<untaint_pattern>. Note that all names passed to the user's
+I<wanted()> function are still tainted. If this option is used while
+not in taint-mode, C<untaint> is a no-op.
- $dir_pref = ($p_dir =~ m/[\]>]+$/ ? $p_dir : "$p_dir/" );
- }
- else {
- $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" );
- }
+=item C<untaint_pattern>
- local ($dir, $name, $prune, *DIR);
+See above. This should be set using the C<qr> quoting operator.
+The default is set to C<qr|^([-+@\w./]+)$|>.
+Note that the parentheses are vital.
- unless ( $no_chdir || ($p_dir eq $File::Find::current_dir)) {
**** PATCH TRUNCATED AT 2000 LINES -- 2836 NOT SHOWN ****
--
Perl5 Master Repository
