[p5sagit/p5-mst-13.2.git] / lib / File / Find.pm

package File::Find;
use 5.005_64;
require Exporter;
require Cwd;

=head1 NAME

find - traverse a file tree

finddepth - traverse a directory structure depth-first

=head1 SYNOPSIS

    use File::Find;
    find(\&wanted, '/foo', '/bar');
    sub wanted { ... }

    use File::Find;
    finddepth(\&wanted, '/foo', '/bar');
    sub wanted { ... }
    
    use File::Find;
    find({ wanted => \&process, follow => 1 }, '.');

=head1 DESCRIPTION

The first argument to find() is either a hash reference describing the
operations to be performed for each file, or a code reference.

Here are the possible keys for the hash:

=over 3

=item C<wanted>

The value should be a code reference.  This code reference is called
I<the wanted() function> below.

=item C<bydepth>

Reports the name of a directory only AFTER all its entries
have been reported.  Entry point finddepth() is a shortcut for
specifying C<{ bydepth => 1 }> in the first argument of find().

=item C<follow>

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 I<follow_fast> and I<follow_skip> below.
If either I<follow> or I<follow_fast> is in effect:

=over 6

=item *

It is guarantueed that an I<lstat> has been called before the user's
I<wanted()> function is called. This enables fast file checks involving S< _>.

=item *

There is a variable C<$File::Find::fullname> which holds the absolute
pathname of the file with all symbolic links resolved

=back

=item C<follow_fast>

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 I<wanted()> function)
is worse than just taking time, the option I<follow> should be used.

=item C<follow_skip>

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.
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
dirctories but to proceed normally otherwise.


=item C<no_chdir>

Does not C<chdir()> to each directory as it recurses. The wanted()
function will need to be aware of this, of course. In this case,
C<$_> will be the same as C<$File::Find::name>.

=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 cd'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. 

=item C<untaint_pattern>

See above. This should be set using the C<qr> quoting operator.
The default is set to  C<qr|^([-+@\w./]+)$|>. 
Note that the paranthesis which are vital.

=item C<untaint_skip>

If set, directories (subtrees) which fail the I<untaint_pattern>
are skipped. The default is to 'die' in such a case.

=back

The wanted() function does whatever verifications you want.
C<$File::Find::dir> contains the current directory name, and C<$_> the
current filename within that directory.  C<$File::Find::name> contains
the complete pathname to the file. You are chdir()'d to C<$File::Find::dir> when
the function is called, unless C<no_chdir> was specified.
When <follow> or <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>.

This library is useful for the C<find2perl> tool, which when fed,

    find2perl / -name .nfs\* -mtime +7 \
        -exec rm -f {} \; -o -fstype nfs -prune

produces something like:

    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);
    }

Set the variable C<$File::Find::dont_use_nlink> if you're using AFS,
since AFS cheats.


Here's another interesting wanted function.  It will find all symlinks
that don't resolve:

    sub wanted {
         -l && !-e && print "bogus link: $File::Find::name\n";
    }

See also the script C<pfind> on CPAN for a nice application of this
module.

=head1 CAVEAT

Be aware that the option to follow symblic 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.


=cut

@ISA = qw(Exporter);
@EXPORT = qw(find finddepth);


use strict;
my $Is_VMS;

require File::Basename;

my %SLnkSeen;
my ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
    $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat);

sub contract_name {
    my ($cdir,$fn) = @_;

    return substr($cdir,0,rindex($cdir,'/')) if $fn eq '.';

    $cdir = substr($cdir,0,rindex($cdir,'/')+1);

    $fn =~ s|^\./||;

    my $abs_name= $cdir . $fn;

    if (substr($fn,0,3) eq '../') {
	do 1 while ($abs_name=~ s|/(?>[^/]+)/\.\./|/|);
    }

    return $abs_name;
}


sub PathCombine($$) {
    my ($Base,$Name) = @_;
    my $AbsName;

    if (substr($Name,0,1) eq '/') {
	$AbsName= $Name;
    }
    else {
	$AbsName= contract_name($Base,$Name);
    }

    # (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;
}

sub Follow_SymLink($) {
    my ($AbsName) = @_;

    my ($NewName,$DEV, $INO);
    ($DEV, $INO)= lstat $AbsName;

    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
    }

    if ($full_check && $SLnkSeen{$DEV, $INO}++) {
	if ($follow_skip < 1) {
	    die "$AbsName encountered a second time";
	}
	else {
	    return undef;
	}
    }

    return $AbsName;
}

our($dir, $name, $fullname, $prune);
sub _find_dir_symlnk($$$);
sub _find_dir($$$);

sub _find_opt {
    my $wanted = shift;
    die "invalid top directory" unless defined $_[0];

    my $cwd           = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::cwd();
    my $cwd_untainted = $cwd;
    $wanted_callback  = $wanted->{wanted};
    $bydepth          = $wanted->{bydepth};
    $no_chdir         = $wanted->{no_chdir};
    $full_check       = $wanted->{follow};
    $follow           = $full_check || $wanted->{follow_fast};
    $follow_skip      = $wanted->{follow_skip};
    $untaint          = $wanted->{untaint};
    $untaint_pat      = $wanted->{untaint_pattern};
    $untaint_skip     = $wanted->{untaint_skip};

    # for compatability reasons (find.pl, find2perl)
    our ($topdir, $topdev, $topino, $topmode, $topnlink);

    # a symbolic link to a directory doesn't increase the link count
    $avoid_nlink      = $follow || $File::Find::dont_use_nlink;
    
    if ( $untaint ) {
	$cwd_untainted= $1 if $cwd_untainted =~ m|$untaint_pat|;
	die "insecure cwd in find(depth)"  unless defined($cwd_untainted);
    }
    
    my ($abs_dir, $Is_Dir);

    Proc_Top_Item:
    foreach my $TOP (@_) {
        my $top_item = $TOP;
        $top_item =~ s|/\z|| unless $top_item eq '/';
        $Is_Dir= 0;
        
        ($topdev,$topino,$topmode,$topnlink) = stat $top_item;

        if ($follow) {
            if (substr($top_item,0,1) eq '/') {
                $abs_dir = $top_item;
            }
	    elsif ($top_item eq '.') {
		$abs_dir = $cwd;
	    }
            else {  # care about any  ../
		$abs_dir = contract_name("$cwd/",$top_item); 
            }
            $abs_dir= Follow_SymLink($abs_dir);
            unless (defined $abs_dir) {
		warn "$top_item is a dangling symbolic link\n";
		next Proc_Top_Item;
            }
            if (-d _) {
		_find_dir_symlnk($wanted, $abs_dir, $top_item);
		$Is_Dir= 1;
            }
        }
	else { # no follow
            $topdir = $top_item;
            unless (defined $topnlink) {
                warn "Can't stat $top_item: $!\n";
                next Proc_Top_Item;
            }
            if (-d _) {
		$top_item =~ s/\.dir\z// if $Is_VMS;
		_find_dir($wanted, $top_item, $topnlink);
		$Is_Dir= 1;
            }
	    else {
		$abs_dir= $top_item;
            }
        }

        unless ($Is_Dir) {
	    unless (($_,$dir) = File::Basename::fileparse($abs_dir)) {
		($dir,$_) = ('.', $top_item);
	    }

            $abs_dir = $dir;
            if ($untaint) {
		my $abs_dir_save = $abs_dir;
		$abs_dir = $1 if $abs_dir =~ m|$untaint_pat|;
		unless (defined $abs_dir) {
		    if ($untaint_skip == 0) {
			die "directory $abs_dir_save is still tainted";
		    }
		    else {
			next Proc_Top_Item;
		    }
		}
            }

            unless ($no_chdir or chdir $abs_dir) {
                warn "Couldn't chdir $abs_dir: $!\n";
                next Proc_Top_Item;
            }
            
            $name = $abs_dir;
            
            &$wanted_callback;

        }

        $no_chdir or chdir $cwd_untainted;
    }
}

# API:
#  $wanted
#  $p_dir :  "parent directory"
#  $nlink :  what came back from the stat
# preconditions:
#  chdir (if not no_chdir) to dir

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= ( $p_dir eq '/' ? '/' : "$p_dir/" );
    my $dir_rel= '.';      # directory name relative to current directory

    local ($dir, $name, $prune, *DIR);
     
    unless ($no_chdir or $p_dir eq '.') {
	my $udir = $p_dir;
	if ($untaint) {
	    $udir = $1 if $p_dir =~ m|$untaint_pat|;
	    unless (defined $udir) {
		if ($untaint_skip == 0) {
		    die "directory $p_dir is still tainted";
		}
		else {
		    return;
		}
	    }
	}
	unless (chdir $udir) {
	    warn "Can't cd to $udir: $!\n";
	    return;
	}
    }

    while (defined $SE) {
	unless ($bydepth) {
            $dir= $p_dir;
            $name= $dir_name;
            $_= ($no_chdir ? $dir_name : $dir_rel );
	    # prune may happen here
            $prune= 0;
            &$wanted_callback; 
            next if $prune;
	}
      
	# change to that directory
	unless ($no_chdir or $dir_rel eq '.') {
	    my $udir= $dir_rel;
	    if ($untaint) {
		$udir = $1 if $dir_rel =~ m|$untaint_pat|;
		unless (defined $udir) {
		    if ($untaint_skip == 0) {
			die "directory ("
			    . ($p_dir ne '/' ? $p_dir : '')
			    . "/) $dir_rel is still tainted";
		    }
		}
	    }
	    unless (chdir $udir) {
		warn "Can't cd to ("
		    . ($p_dir ne '/' ? $p_dir : '')
		    . "/) $udir : $!\n";
		next;
	    }
	    $CdLvl++;
	}

	$dir= $dir_name;

	# Get the list of files in the current directory.
	unless (opendir DIR, ($no_chdir ? $dir_name : '.')) {
	    warn "Can't opendir($dir_name): $!\n";
	    next;
	}
	@filenames = readdir DIR;
	closedir(DIR);

	if ($nlink == 2 && !$avoid_nlink) {
	    # This dir has no subdirectories.
	    for my $FN (@filenames) {
		next if $FN =~ /^\.{1,2}\z/;
		
		$name = $dir_pref . $FN;
		$_ = ($no_chdir ? $name : $FN);
		&$wanted_callback;
	    }

	}
	else {
	    # This dir has subdirectories.
	    $subcount = $nlink - 2;

	    for my $FN (@filenames) {
		next if $FN =~ /^\.{1,2}\z/;
		if ($subcount > 0 || $avoid_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// if $Is_VMS;
			push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink];
		    }
		    else {
			$name = $dir_pref . $FN;
			$_= ($no_chdir ? $name : $FN);
			&$wanted_callback;
		    }
		}
		else {
		    $name = $dir_pref . $FN;
		    $_= ($no_chdir ? $name : $FN);
		    &$wanted_callback;
		}
	    }
	}
	if ($bydepth) {
            $name = $dir_name;
            $dir = $p_dir;
            $_ = ($no_chdir ? $dir_name : $dir_rel );
            &$wanted_callback;
	}
    }
    continue {
	if ( defined ($SE = pop @Stack) ) {
	    ($Level, $p_dir, $dir_rel, $nlink) = @$SE;
	    if ($CdLvl > $Level && !$no_chdir) {
		die "Can't cd to $dir_name" . '../' x ($CdLvl-$Level)
		    unless  chdir '../' x ($CdLvl-$Level);
		$CdLvl = $Level;
	    }
	    $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
	    $dir_pref = "$dir_name/";
	}
    }
}


# API:
#  $wanted
#  $dir_loc : absolute location of a dir
#  $p_dir   : "parent directory"
# preconditions:
#  chdir (if not no_chdir) to dir

sub _find_dir_symlnk($$$) {
    my ($wanted, $dir_loc, $p_dir) = @_;
    my @Stack;
    my @filenames;
    my $new_loc;
    my $SE = [];
    my $dir_name = $p_dir;
    my $dir_pref = ( $p_dir   eq '/' ? '/' : "$p_dir/" );
    my $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" );
    my $dir_rel = '.';		# directory name relative to current directory

    local ($dir, $name, $fullname, $prune, *DIR);
    
    unless ($no_chdir or $p_dir eq '.') {
	my $udir = $dir_loc;
	if ($untaint) {
	    $udir = $1 if $dir_loc =~ m|$untaint_pat|;
	    unless (defined $udir) {
		if ($untaint_skip == 0) {
		    die "directory $dir_loc is still tainted";
		}
		else {
		    return;
		}
	    }
	}
	unless (chdir $udir) {
	    warn "Can't cd to $udir: $!\n";
	    return;
	}
    }

    while (defined $SE) {

	unless ($bydepth) {
	    $dir= $p_dir;
            $name= $dir_name;
            $_= ($no_chdir ? $dir_name : $dir_rel );
            $fullname= $dir_loc;
	    # prune may happen here
            $prune= 0;
            &$wanted_callback;
            next if  $prune;
	}

	# change to that directory
	unless ($no_chdir or $dir_rel eq '.') {
	    my $udir = $dir_loc;
	    if ($untaint) {
		$udir = $1 if $dir_loc =~ m|$untaint_pat|;
		unless (defined $udir ) {
		    if ($untaint_skip == 0) {
			die "directory $dir_loc is still tainted";
		    }
		    else {
			next;
		    }
		}
	    }
	    unless (chdir $udir) {
		warn "Can't cd to $udir: $!\n";
		next;
	    }
	}

	$dir = $dir_name;

	# Get the list of files in the current directory.
	unless (opendir DIR, ($no_chdir ? $dir_loc : '.')) {
	    warn "Can't opendir($dir_loc): $!\n";
	    next;
	}
	@filenames = readdir DIR;
	closedir(DIR);

	for my $FN (@filenames) {
	    next if $FN =~ /^\.{1,2}\z/;

	    # follow symbolic links / do an lstat
	    $new_loc = Follow_SymLink($loc_pref.$FN);

	    # ignore if invalid symlink
	    next unless defined $new_loc;
     
	    if (-d _) {
		push @Stack,[$new_loc,$dir_name,$FN];
	    }
	    else {
		$fullname = $new_loc;
		$name = $dir_pref . $FN;
		$_ = ($no_chdir ? $name : $FN);
		&$wanted_callback;
	    }
	}

	if ($bydepth) {
	    $fullname = $dir_loc;
	    $name = $dir_name;
	    $_ = ($no_chdir ? $dir_name : $dir_rel);
	    &$wanted_callback;
	}
    }
    continue {
	if (defined($SE = pop @Stack)) {
	    ($dir_loc, $p_dir, $dir_rel) = @$SE;
	    $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
	    $dir_pref = "$dir_name/";
	    $loc_pref = "$dir_loc/";
	}
    }
}


sub wrap_wanted {
    my $wanted = shift;
    if ( ref($wanted) eq 'HASH' ) {
	if ( $wanted->{follow} || $wanted->{follow_fast}) {
	    $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip};
	}
	if ( $wanted->{untaint} ) {
	    $wanted->{untaint_pattern} = qr|^([-+@\w./]+)$|  
		unless defined $wanted->{untaint_pattern};
	    $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip};
	}
	return $wanted;
    }
    else {
	return { wanted => $wanted };
    }
}

sub find {
    my $wanted = shift;
    _find_opt(wrap_wanted($wanted), @_);
    %SLnkSeen= ();  # free memory
}

sub finddepth {
    my $wanted = wrap_wanted(shift);
    $wanted->{bydepth} = 1;
    _find_opt($wanted, @_);
    %SLnkSeen= ();  # free memory
}

# 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;
}

$File::Find::dont_use_nlink = 1
    if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32';

# 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'});
}

1;
Commit	Line	Data
a0d0e21e	1	package File::Find;
17f410f9	2	use 5.005_64;
a0d0e21e	3	require Exporter;
6280b799	4	require Cwd;
a0d0e21e	5
f06db76b	6	=head1 NAME
	7
	8	find - traverse a file tree
	9
	10	finddepth - traverse a directory structure depth-first
	11
	12	=head1 SYNOPSIS
	13
	14	use File::Find;
81793b90	15	find(\&wanted, '/foo', '/bar');
f06db76b	16	sub wanted { ... }
237437d0	17
f06db76b	18	use File::Find;
81793b90	19	finddepth(\&wanted, '/foo', '/bar');
f06db76b	20	sub wanted { ... }
81793b90	21
	22	use File::Find;
	23	find({ wanted => \&process, follow => 1 }, '.');
f06db76b	24
	25	=head1 DESCRIPTION
	26
20408e3c	27	The first argument to find() is either a hash reference describing the
81793b90	28	operations to be performed for each file, or a code reference.
20408e3c	29
81793b90	30	Here are the possible keys for the hash:
	31
	32	=over 3
	33
	34	=item C<wanted>
	35
	36	The value should be a code reference. This code reference is called
	37	I<the wanted() function> below.
	38
	39	=item C<bydepth>
	40
	41	Reports the name of a directory only AFTER all its entries
	42	have been reported. Entry point finddepth() is a shortcut for
	43	specifying C<{ bydepth => 1 }> in the first argument of find().
	44
	45	=item C<follow>
	46
	47	Causes symbolic links to be followed. Since directory trees with symbolic
	48	links (followed) may contain files more than once and may even have
	49	cycles, a hash has to be built up with an entry for each file.
	50	This might be expensive both in space and time for a large
	51	directory tree. See I<follow_fast> and I<follow_skip> below.
	52	If either I<follow> or I<follow_fast> is in effect:
	53
	54	=over 6
	55
a45bd81d	56	=item *
81793b90	57
	58	It is guarantueed that an I<lstat> has been called before the user's
	59	I<wanted()> function is called. This enables fast file checks involving S< _>.
	60
a45bd81d	61	=item *
81793b90	62
	63	There is a variable C<$File::Find::fullname> which holds the absolute
	64	pathname of the file with all symbolic links resolved
	65
	66	=back
	67
	68	=item C<follow_fast>
	69
	70	This is similar to I<follow> except that it may report some files
	71	more than once. It does detect cycles however.
	72	Since only symbolic links have to be hashed, this is
	73	much cheaper both in space and time.
	74	If processing a file more than once (by the user's I<wanted()> function)
	75	is worse than just taking time, the option I<follow> should be used.
	76
	77	=item C<follow_skip>
	78
	79	C<follow_skip==1>, which is the default, causes all files which are
	80	neither directories nor symbolic links to be ignored if they are about
	81	to be processed a second time. If a directory or a symbolic link
	82	are about to be processed a second time, File::Find dies.
	83	C<follow_skip==0> causes File::Find to die if any file is about to be
	84	processed a second time.
	85	C<follow_skip==2> causes File::Find to ignore any duplicate files and
	86	dirctories but to proceed normally otherwise.
20408e3c	87
f06db76b	88
81793b90	89	=item C<no_chdir>
	90
	91	Does not C<chdir()> to each directory as it recurses. The wanted()
	92	function will need to be aware of this, of course. In this case,
	93	C<$_> will be the same as C<$File::Find::name>.
	94
	95	=item C<untaint>
	96
	97	If find is used in taint-mode (-T command line switch or if EUID != UID
	98	or if EGID != GID) then internally directory names have to be untainted
	99	before they can be cd'ed to. Therefore they are checked against a regular
	100	expression I<untaint_pattern>. Note, that all names passed to the
	101	user's I<wanted()> function are still tainted.
	102
	103	=item C<untaint_pattern>
	104
	105	See above. This should be set using the C<qr> quoting operator.
	106	The default is set to C<qr\|^([-+@\w./]+)$\|>.
	107	Note that the paranthesis which are vital.
	108
	109	=item C<untaint_skip>
	110
	111	If set, directories (subtrees) which fail the I<untaint_pattern>
	112	are skipped. The default is to 'die' in such a case.
	113
	114	=back
	115
	116	The wanted() function does whatever verifications you want.
	117	C<$File::Find::dir> contains the current directory name, and C<$_> the
	118	current filename within that directory. C<$File::Find::name> contains
	119	the complete pathname to the file. You are chdir()'d to C<$File::Find::dir> when
	120	the function is called, unless C<no_chdir> was specified.
	121	When <follow> or <follow_fast> are in effect there is also a
	122	C<$File::Find::fullname>.
	123	The function may set C<$File::Find::prune> to prune the tree
	124	unless C<bydepth> was specified.
e7b91b67	125	Unless C<follow> or C<follow_fast> is specified, for compatibility
	126	reasons (find.pl, find2perl) there are in addition the following globals
	127	available: C<$File::Find::topdir>, C<$File::Find::topdev>, C<$File::Find::topino>,
	128	C<$File::Find::topmode> and C<$File::Find::topnlink>.
47a735e8	129
20408e3c	130	This library is useful for the C<find2perl> tool, which when fed,
f06db76b	131
f06db76b	132	find2perl / -name .nfs\* -mtime +7 \
81793b90	133	-exec rm -f {} \; -o -fstype nfs -prune
f06db76b	134
	135	produces something like:
	136
	137	sub wanted {
c7b9dd21	138	/^\.nfs.*\z/s &&
81793b90	139	(($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_)) &&
f06db76b	140	int(-M _) > 7 &&
	141	unlink($_)
	142	\|\|
81793b90	143	($nlink \|\| (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))) &&
f06db76b	144	$dev < 0 &&
6280b799	145	($File::Find::prune = 1);
f06db76b	146	}
f06db76b	147
81793b90	148	Set the variable C<$File::Find::dont_use_nlink> if you're using AFS,
6280b799	149	since AFS cheats.
f06db76b	150
f06db76b	151
	152	Here's another interesting wanted function. It will find all symlinks
	153	that don't resolve:
	154
	155	sub wanted {
81793b90	156	-l && !-e && print "bogus link: $File::Find::name\n";
237437d0	157	}
f06db76b	158
81793b90	159	See also the script C<pfind> on CPAN for a nice application of this
	160	module.
	161
	162	=head1 CAVEAT
	163
	164	Be aware that the option to follow symblic links can be dangerous.
	165	Depending on the structure of the directory tree (including symbolic
	166	links to directories) you might traverse a given (physical) directory
	167	more than once (only if C<follow_fast> is in effect).
	168	Furthermore, deleting or changing files in a symbolically linked directory
	169	might cause very unpleasant surprises, since you delete or change files
	170	in an unknown directory.
0530a6c4	171
0530a6c4	172
f06db76b	173	=cut
f06db76b	174
a0d0e21e	175	@ISA = qw(Exporter);
6280b799	176	@EXPORT = qw(find finddepth);
6280b799	177
a0d0e21e	178
81793b90	179	use strict;
	180	my $Is_VMS;
	181
	182	require File::Basename;
	183
	184	my %SLnkSeen;
	185	my ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
	186	$follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat);
	187
	188	sub contract_name {
	189	my ($cdir,$fn) = @_;
	190
	191	return substr($cdir,0,rindex($cdir,'/')) if $fn eq '.';
	192
	193	$cdir = substr($cdir,0,rindex($cdir,'/')+1);
	194
	195	$fn =~ s\|^\./\|\|;
	196
	197	my $abs_name= $cdir . $fn;
	198
	199	if (substr($fn,0,3) eq '../') {
	200	do 1 while ($abs_name=~ s\|/(?>[^/]+)/\.\./\|/\|);
	201	}
	202
	203	return $abs_name;
	204	}
	205
	206
	207	sub PathCombine($$) {
	208	my ($Base,$Name) = @_;
	209	my $AbsName;
	210
	211	if (substr($Name,0,1) eq '/') {
	212	$AbsName= $Name;
	213	}
	214	else {
	215	$AbsName= contract_name($Base,$Name);
	216	}
	217
	218	# (simple) check for recursion
	219	my $newlen= length($AbsName);
	220	if ($newlen <= length($Base)) {
	221	if (($newlen == length($Base) \|\| substr($Base,$newlen,1) eq '/')
	222	&& $AbsName eq substr($Base,0,$newlen))
	223	{
	224	return undef;
	225	}
	226	}
	227	return $AbsName;
	228	}
	229
	230	sub Follow_SymLink($) {
	231	my ($AbsName) = @_;
	232
	233	my ($NewName,$DEV, $INO);
	234	($DEV, $INO)= lstat $AbsName;
	235
	236	while (-l _) {
	237	if ($SLnkSeen{$DEV, $INO}++) {
	238	if ($follow_skip < 2) {
	239	die "$AbsName is encountered a second time";
a0d0e21e	240	}
a0d0e21e	241	else {
81793b90	242	return undef;
a0d0e21e	243	}
a0d0e21e	244	}
81793b90	245	$NewName= PathCombine($AbsName, readlink($AbsName));
	246	unless(defined $NewName) {
	247	if ($follow_skip < 2) {
	248	die "$AbsName is a recursive symbolic link";
	249	}
	250	else {
	251	return undef;
a0d0e21e	252	}
81793b90	253	}
	254	else {
	255	$AbsName= $NewName;
	256	}
	257	($DEV, $INO) = lstat($AbsName);
	258	return undef unless defined $DEV; # dangling symbolic link
	259	}
	260
	261	if ($full_check && $SLnkSeen{$DEV, $INO}++) {
	262	if ($follow_skip < 1) {
	263	die "$AbsName encountered a second time";
	264	}
	265	else {
	266	return undef;
	267	}
	268	}
	269
	270	return $AbsName;
	271	}
	272
17f410f9	273	our($dir, $name, $fullname, $prune);
81793b90	274	sub _find_dir_symlnk($$$);
	275	sub _find_dir($$$);
	276
	277	sub _find_opt {
	278	my $wanted = shift;
	279	die "invalid top directory" unless defined $_[0];
	280
	281	my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::cwd();
	282	my $cwd_untainted = $cwd;
	283	$wanted_callback = $wanted->{wanted};
	284	$bydepth = $wanted->{bydepth};
	285	$no_chdir = $wanted->{no_chdir};
	286	$full_check = $wanted->{follow};
	287	$follow = $full_check \|\| $wanted->{follow_fast};
	288	$follow_skip = $wanted->{follow_skip};
	289	$untaint = $wanted->{untaint};
	290	$untaint_pat = $wanted->{untaint_pattern};
	291	$untaint_skip = $wanted->{untaint_skip};
	292
e7b91b67	293	# for compatability reasons (find.pl, find2perl)
e7b91b67	294	our ($topdir, $topdev, $topino, $topmode, $topnlink);
81793b90	295
	296	# a symbolic link to a directory doesn't increase the link count
	297	$avoid_nlink = $follow \|\| $File::Find::dont_use_nlink;
	298
	299	if ( $untaint ) {
	300	$cwd_untainted= $1 if $cwd_untainted =~ m\|$untaint_pat\|;
	301	die "insecure cwd in find(depth)" unless defined($cwd_untainted);
	302	}
	303
e7b91b67	304	my ($abs_dir, $Is_Dir);
81793b90	305
	306	Proc_Top_Item:
	307	foreach my $TOP (@_) {
	308	my $top_item = $TOP;
c7b9dd21	309	$top_item =~ s\|/\z\|\| unless $top_item eq '/';
81793b90	310	$Is_Dir= 0;
81793b90	311
3d1e7443	312	($topdev,$topino,$topmode,$topnlink) = stat $top_item;
3d1e7443	313
81793b90	314	if ($follow) {
	315	if (substr($top_item,0,1) eq '/') {
	316	$abs_dir = $top_item;
	317	}
	318	elsif ($top_item eq '.') {
	319	$abs_dir = $cwd;
237437d0	320	}
81793b90	321	else { # care about any ../
	322	$abs_dir = contract_name("$cwd/",$top_item);
	323	}
	324	$abs_dir= Follow_SymLink($abs_dir);
	325	unless (defined $abs_dir) {
	326	warn "$top_item is a dangling symbolic link\n";
	327	next Proc_Top_Item;
	328	}
	329	if (-d _) {
	330	_find_dir_symlnk($wanted, $abs_dir, $top_item);
	331	$Is_Dir= 1;
	332	}
	333	}
	334	else { # no follow
e7b91b67	335	$topdir = $top_item;
e7b91b67	336	unless (defined $topnlink) {
81793b90	337	warn "Can't stat $top_item: $!\n";
	338	next Proc_Top_Item;
	339	}
	340	if (-d _) {
c7b9dd21	341	$top_item =~ s/\.dir\z// if $Is_VMS;
e7b91b67	342	_find_dir($wanted, $top_item, $topnlink);
81793b90	343	$Is_Dir= 1;
81793b90	344	}
237437d0	345	else {
81793b90	346	$abs_dir= $top_item;
	347	}
	348	}
	349
	350	unless ($Is_Dir) {
	351	unless (($_,$dir) = File::Basename::fileparse($abs_dir)) {
	352	($dir,$_) = ('.', $top_item);
	353	}
	354
	355	$abs_dir = $dir;
	356	if ($untaint) {
	357	my $abs_dir_save = $abs_dir;
	358	$abs_dir = $1 if $abs_dir =~ m\|$untaint_pat\|;
	359	unless (defined $abs_dir) {
	360	if ($untaint_skip == 0) {
	361	die "directory $abs_dir_save is still tainted";
	362	}
	363	else {
	364	next Proc_Top_Item;
	365	}
	366	}
	367	}
	368
	369	unless ($no_chdir or chdir $abs_dir) {
	370	warn "Couldn't chdir $abs_dir: $!\n";
	371	next Proc_Top_Item;
	372	}
	373
	374	$name = $abs_dir;
	375
	376	&$wanted_callback;
	377
	378	}
	379
	380	$no_chdir or chdir $cwd_untainted;
	381	}
	382	}
	383
	384	# API:
	385	# $wanted
	386	# $p_dir : "parent directory"
	387	# $nlink : what came back from the stat
	388	# preconditions:
	389	# chdir (if not no_chdir) to dir
	390
	391	sub _find_dir($$$) {
	392	my ($wanted, $p_dir, $nlink) = @_;
	393	my ($CdLvl,$Level) = (0,0);
	394	my @Stack;
	395	my @filenames;
	396	my ($subcount,$sub_nlink);
	397	my $SE= [];
	398	my $dir_name= $p_dir;
07867069	399	my $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" );
81793b90	400	my $dir_rel= '.'; # directory name relative to current directory
	401
	402	local ($dir, $name, $prune, *DIR);
	403
	404	unless ($no_chdir or $p_dir eq '.') {
	405	my $udir = $p_dir;
	406	if ($untaint) {
	407	$udir = $1 if $p_dir =~ m\|$untaint_pat\|;
	408	unless (defined $udir) {
	409	if ($untaint_skip == 0) {
	410	die "directory $p_dir is still tainted";
	411	}
	412	else {
	413	return;
	414	}
237437d0	415	}
a0d0e21e	416	}
81793b90	417	unless (chdir $udir) {
	418	warn "Can't cd to $udir: $!\n";
	419	return;
	420	}
	421	}
	422
	423	while (defined $SE) {
	424	unless ($bydepth) {
	425	$dir= $p_dir;
	426	$name= $dir_name;
	427	$_= ($no_chdir ? $dir_name : $dir_rel );
	428	# prune may happen here
	429	$prune= 0;
	430	&$wanted_callback;
	431	next if $prune;
	432	}
	433
	434	# change to that directory
	435	unless ($no_chdir or $dir_rel eq '.') {
	436	my $udir= $dir_rel;
	437	if ($untaint) {
	438	$udir = $1 if $dir_rel =~ m\|$untaint_pat\|;
	439	unless (defined $udir) {
	440	if ($untaint_skip == 0) {
07867069	441	die "directory ("
	442	. ($p_dir ne '/' ? $p_dir : '')
	443	. "/) $dir_rel is still tainted";
81793b90	444	}
	445	}
	446	}
	447	unless (chdir $udir) {
07867069	448	warn "Can't cd to ("
	449	. ($p_dir ne '/' ? $p_dir : '')
	450	. "/) $udir : $!\n";
81793b90	451	next;
	452	}
	453	$CdLvl++;
	454	}
	455
	456	$dir= $dir_name;
	457
	458	# Get the list of files in the current directory.
	459	unless (opendir DIR, ($no_chdir ? $dir_name : '.')) {
	460	warn "Can't opendir($dir_name): $!\n";
	461	next;
	462	}
	463	@filenames = readdir DIR;
	464	closedir(DIR);
	465
	466	if ($nlink == 2 && !$avoid_nlink) {
	467	# This dir has no subdirectories.
	468	for my $FN (@filenames) {
c7b9dd21	469	next if $FN =~ /^\.{1,2}\z/;
81793b90	470
07867069	471	$name = $dir_pref . $FN;
81793b90	472	$_ = ($no_chdir ? $name : $FN);
	473	&$wanted_callback;
	474	}
	475
	476	}
	477	else {
	478	# This dir has subdirectories.
	479	$subcount = $nlink - 2;
	480
	481	for my $FN (@filenames) {
c7b9dd21	482	next if $FN =~ /^\.{1,2}\z/;
81793b90	483	if ($subcount > 0 \|\| $avoid_nlink) {
	484	# Seen all the subdirs?
	485	# check for directoriness.
	486	# stat is faster for a file in the current directory
07867069	487	$sub_nlink = (lstat ($no_chdir ? $dir_pref . $FN : $FN))[3];
81793b90	488
	489	if (-d _) {
	490	--$subcount;
c7b9dd21	491	$FN =~ s/\.dir\z// if $Is_VMS;
81793b90	492	push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink];
	493	}
	494	else {
07867069	495	$name = $dir_pref . $FN;
81793b90	496	$_= ($no_chdir ? $name : $FN);
	497	&$wanted_callback;
	498	}
	499	}
07867069	500	else {
07867069	501	$name = $dir_pref . $FN;
81793b90	502	$_= ($no_chdir ? $name : $FN);
	503	&$wanted_callback;
	504	}
	505	}
	506	}
	507	if ($bydepth) {
	508	$name = $dir_name;
	509	$dir = $p_dir;
	510	$_ = ($no_chdir ? $dir_name : $dir_rel );
	511	&$wanted_callback;
	512	}
17b275ff	513	}
17b275ff	514	continue {
81793b90	515	if ( defined ($SE = pop @Stack) ) {
	516	($Level, $p_dir, $dir_rel, $nlink) = @$SE;
	517	if ($CdLvl > $Level && !$no_chdir) {
	518	die "Can't cd to $dir_name" . '../' x ($CdLvl-$Level)
	519	unless chdir '../' x ($CdLvl-$Level);
	520	$CdLvl = $Level;
	521	}
07867069	522	$dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
07867069	523	$dir_pref = "$dir_name/";
81793b90	524	}
a0d0e21e	525	}
	526	}
	527
81793b90	528
	529	# API:
	530	# $wanted
	531	# $dir_loc : absolute location of a dir
	532	# $p_dir : "parent directory"
	533	# preconditions:
	534	# chdir (if not no_chdir) to dir
	535
	536	sub _find_dir_symlnk($$$) {
	537	my ($wanted, $dir_loc, $p_dir) = @_;
	538	my @Stack;
	539	my @filenames;
	540	my $new_loc;
	541	my $SE = [];
	542	my $dir_name = $p_dir;
07867069	543	my $dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" );
07867069	544	my $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" );
81793b90	545	my $dir_rel = '.'; # directory name relative to current directory
	546
	547	local ($dir, $name, $fullname, $prune, *DIR);
	548
	549	unless ($no_chdir or $p_dir eq '.') {
	550	my $udir = $dir_loc;
	551	if ($untaint) {
	552	$udir = $1 if $dir_loc =~ m\|$untaint_pat\|;
	553	unless (defined $udir) {
	554	if ($untaint_skip == 0) {
	555	die "directory $dir_loc is still tainted";
	556	}
	557	else {
	558	return;
	559	}
	560	}
	561	}
	562	unless (chdir $udir) {
	563	warn "Can't cd to $udir: $!\n";
	564	return;
	565	}
	566	}
	567
	568	while (defined $SE) {
	569
	570	unless ($bydepth) {
	571	$dir= $p_dir;
	572	$name= $dir_name;
	573	$_= ($no_chdir ? $dir_name : $dir_rel );
	574	$fullname= $dir_loc;
	575	# prune may happen here
	576	$prune= 0;
	577	&$wanted_callback;
	578	next if $prune;
	579	}
	580
	581	# change to that directory
	582	unless ($no_chdir or $dir_rel eq '.') {
	583	my $udir = $dir_loc;
	584	if ($untaint) {
	585	$udir = $1 if $dir_loc =~ m\|$untaint_pat\|;
	586	unless (defined $udir ) {
	587	if ($untaint_skip == 0) {
	588	die "directory $dir_loc is still tainted";
a0d0e21e	589	}
237437d0	590	else {
81793b90	591	next;
237437d0	592	}
a0d0e21e	593	}
a0d0e21e	594	}
81793b90	595	unless (chdir $udir) {
	596	warn "Can't cd to $udir: $!\n";
	597	next;
	598	}
	599	}
	600
	601	$dir = $dir_name;
	602
	603	# Get the list of files in the current directory.
	604	unless (opendir DIR, ($no_chdir ? $dir_loc : '.')) {
	605	warn "Can't opendir($dir_loc): $!\n";
	606	next;
	607	}
	608	@filenames = readdir DIR;
	609	closedir(DIR);
	610
	611	for my $FN (@filenames) {
c7b9dd21	612	next if $FN =~ /^\.{1,2}\z/;
81793b90	613
81793b90	614	# follow symbolic links / do an lstat
07867069	615	$new_loc = Follow_SymLink($loc_pref.$FN);
81793b90	616
	617	# ignore if invalid symlink
	618	next unless defined $new_loc;
	619
	620	if (-d _) {
	621	push @Stack,[$new_loc,$dir_name,$FN];
	622	}
	623	else {
	624	$fullname = $new_loc;
07867069	625	$name = $dir_pref . $FN;
81793b90	626	$_ = ($no_chdir ? $name : $FN);
	627	&$wanted_callback;
	628	}
	629	}
	630
	631	if ($bydepth) {
	632	$fullname = $dir_loc;
	633	$name = $dir_name;
	634	$_ = ($no_chdir ? $dir_name : $dir_rel);
	635	&$wanted_callback;
	636	}
	637	}
	638	continue {
	639	if (defined($SE = pop @Stack)) {
	640	($dir_loc, $p_dir, $dir_rel) = @$SE;
07867069	641	$dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
	642	$dir_pref = "$dir_name/";
	643	$loc_pref = "$dir_loc/";
a0d0e21e	644	}
	645	}
	646	}
	647
81793b90	648
20408e3c	649	sub wrap_wanted {
81793b90	650	my $wanted = shift;
	651	if ( ref($wanted) eq 'HASH' ) {
	652	if ( $wanted->{follow} \|\| $wanted->{follow_fast}) {
	653	$wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip};
	654	}
	655	if ( $wanted->{untaint} ) {
	656	$wanted->{untaint_pattern} = qr\|^([-+@\w./]+)$\|
	657	unless defined $wanted->{untaint_pattern};
	658	$wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip};
	659	}
	660	return $wanted;
	661	}
	662	else {
	663	return { wanted => $wanted };
	664	}
a0d0e21e	665	}
a0d0e21e	666
20408e3c	667	sub find {
81793b90	668	my $wanted = shift;
	669	_find_opt(wrap_wanted($wanted), @_);
	670	%SLnkSeen= (); # free memory
a0d0e21e	671	}
a0d0e21e	672
55d729e4	673	sub finddepth {
81793b90	674	my $wanted = wrap_wanted(shift);
	675	$wanted->{bydepth} = 1;
	676	_find_opt($wanted, @_);
	677	%SLnkSeen= (); # free memory
20408e3c	678	}
6280b799	679
6280b799	680	# These are hard-coded for now, but may move to hint files.
10eba763	681	if ($^O eq 'VMS') {
81793b90	682	$Is_VMS = 1;
81793b90	683	$File::Find::dont_use_nlink = 1;
748a9306	684	}
748a9306	685
81793b90	686	$File::Find::dont_use_nlink = 1
3e8584ad	687	if $^O eq 'os2' \|\| $^O eq 'dos' \|\| $^O eq 'amigaos' \|\| $^O eq 'MSWin32';
6280b799	688
20408e3c	689	# Set dont_use_nlink in your hint file if your system's stat doesn't
	690	# report the number of links in a directory as an indication
	691	# of the number of files.
	692	# See, e.g. hints/machten.sh for MachTen 2.2.
81793b90	693	unless ($File::Find::dont_use_nlink) {
	694	require Config;
	695	$File::Find::dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'});
20408e3c	696	}
20408e3c	697
a0d0e21e	698	1;