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

package File::Find;
require 5.000;
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.

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.*$/ &&
        (($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;
}

use vars qw/ $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};


    # 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, $nlink, $Is_Dir);

    Proc_Top_Item:
    foreach my $TOP (@_) {
        my $top_item = $TOP;
        $top_item =~ s|/$||;
        $Is_Dir= 0;
        
        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
            $nlink = (lstat $top_item)[3];
            unless (defined $nlink) {
                warn "Can't stat $top_item: $!\n";
                next Proc_Top_Item;
            }
            if (-d _) {
		$top_item =~ s/\.dir$// if $Is_VMS;
		_find_dir($wanted, $top_item, $nlink);
		$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_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/) $dir_rel is still tainted";
		    }
		}
	    }
	    unless (chdir $udir) {
		warn "Can't cd to ($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}$/;
		
		$name = "$dir_name/$FN";
		$_ = ($no_chdir ? $name : $FN);
		&$wanted_callback;
	    }

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

	    for my $FN (@filenames) {
		next if $FN =~ /^\.{1,2}$/;
		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_name/$FN" : $FN))[3];

		    if (-d _) {
			--$subcount;
			$FN =~ s/\.dir$// if $Is_VMS;
			push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink];
		    }
		    else {
			$name = "$dir_name/$FN";
			$_= ($no_chdir ? $name : $FN);
			&$wanted_callback;
		    }
		}
		else { $name = "$dir_name/$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/$dir_rel";
	}
    }
}


# 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_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}$/;

	    # follow symbolic links / do an lstat
	    $new_loc= Follow_SymLink("$dir_loc/$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_name/$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/$dir_rel";
	}
    }
}


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;
	2	require 5.000;
	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
	56	=item
	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
	61	=item
	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.
47a735e8	125
20408e3c	126	This library is useful for the C<find2perl> tool, which when fed,
f06db76b	127
f06db76b	128	find2perl / -name .nfs\* -mtime +7 \
81793b90	129	-exec rm -f {} \; -o -fstype nfs -prune
f06db76b	130
	131	produces something like:
	132
	133	sub wanted {
	134	/^\.nfs.*$/ &&
81793b90	135	(($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_)) &&
f06db76b	136	int(-M _) > 7 &&
	137	unlink($_)
	138	\|\|
81793b90	139	($nlink \|\| (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))) &&
f06db76b	140	$dev < 0 &&
6280b799	141	($File::Find::prune = 1);
f06db76b	142	}
f06db76b	143
81793b90	144	Set the variable C<$File::Find::dont_use_nlink> if you're using AFS,
6280b799	145	since AFS cheats.
f06db76b	146
f06db76b	147
	148	Here's another interesting wanted function. It will find all symlinks
	149	that don't resolve:
	150
	151	sub wanted {
81793b90	152	-l && !-e && print "bogus link: $File::Find::name\n";
237437d0	153	}
f06db76b	154
81793b90	155	See also the script C<pfind> on CPAN for a nice application of this
	156	module.
	157
	158	=head1 CAVEAT
	159
	160	Be aware that the option to follow symblic links can be dangerous.
	161	Depending on the structure of the directory tree (including symbolic
	162	links to directories) you might traverse a given (physical) directory
	163	more than once (only if C<follow_fast> is in effect).
	164	Furthermore, deleting or changing files in a symbolically linked directory
	165	might cause very unpleasant surprises, since you delete or change files
	166	in an unknown directory.
0530a6c4	167
0530a6c4	168
f06db76b	169	=cut
f06db76b	170
a0d0e21e	171	@ISA = qw(Exporter);
6280b799	172	@EXPORT = qw(find finddepth);
6280b799	173
a0d0e21e	174
81793b90	175	use strict;
	176	my $Is_VMS;
	177
	178	require File::Basename;
	179
	180	my %SLnkSeen;
	181	my ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
	182	$follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat);
	183
	184	sub contract_name {
	185	my ($cdir,$fn) = @_;
	186
	187	return substr($cdir,0,rindex($cdir,'/')) if $fn eq '.';
	188
	189	$cdir = substr($cdir,0,rindex($cdir,'/')+1);
	190
	191	$fn =~ s\|^\./\|\|;
	192
	193	my $abs_name= $cdir . $fn;
	194
	195	if (substr($fn,0,3) eq '../') {
	196	do 1 while ($abs_name=~ s\|/(?>[^/]+)/\.\./\|/\|);
	197	}
	198
	199	return $abs_name;
	200	}
	201
	202
	203	sub PathCombine($$) {
	204	my ($Base,$Name) = @_;
	205	my $AbsName;
	206
	207	if (substr($Name,0,1) eq '/') {
	208	$AbsName= $Name;
	209	}
	210	else {
	211	$AbsName= contract_name($Base,$Name);
	212	}
	213
	214	# (simple) check for recursion
	215	my $newlen= length($AbsName);
	216	if ($newlen <= length($Base)) {
	217	if (($newlen == length($Base) \|\| substr($Base,$newlen,1) eq '/')
	218	&& $AbsName eq substr($Base,0,$newlen))
	219	{
	220	return undef;
	221	}
	222	}
	223	return $AbsName;
	224	}
	225
	226	sub Follow_SymLink($) {
	227	my ($AbsName) = @_;
	228
	229	my ($NewName,$DEV, $INO);
	230	($DEV, $INO)= lstat $AbsName;
	231
	232	while (-l _) {
	233	if ($SLnkSeen{$DEV, $INO}++) {
	234	if ($follow_skip < 2) {
	235	die "$AbsName is encountered a second time";
a0d0e21e	236	}
a0d0e21e	237	else {
81793b90	238	return undef;
a0d0e21e	239	}
a0d0e21e	240	}
81793b90	241	$NewName= PathCombine($AbsName, readlink($AbsName));
	242	unless(defined $NewName) {
	243	if ($follow_skip < 2) {
	244	die "$AbsName is a recursive symbolic link";
	245	}
	246	else {
	247	return undef;
a0d0e21e	248	}
81793b90	249	}
	250	else {
	251	$AbsName= $NewName;
	252	}
	253	($DEV, $INO) = lstat($AbsName);
	254	return undef unless defined $DEV; # dangling symbolic link
	255	}
	256
	257	if ($full_check && $SLnkSeen{$DEV, $INO}++) {
	258	if ($follow_skip < 1) {
	259	die "$AbsName encountered a second time";
	260	}
	261	else {
	262	return undef;
	263	}
	264	}
	265
	266	return $AbsName;
	267	}
	268
	269	use vars qw/ $dir $name $fullname $prune /;
	270	sub _find_dir_symlnk($$$);
	271	sub _find_dir($$$);
	272
	273	sub _find_opt {
	274	my $wanted = shift;
	275	die "invalid top directory" unless defined $_[0];
	276
	277	my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::cwd();
	278	my $cwd_untainted = $cwd;
	279	$wanted_callback = $wanted->{wanted};
	280	$bydepth = $wanted->{bydepth};
	281	$no_chdir = $wanted->{no_chdir};
	282	$full_check = $wanted->{follow};
	283	$follow = $full_check \|\| $wanted->{follow_fast};
	284	$follow_skip = $wanted->{follow_skip};
	285	$untaint = $wanted->{untaint};
	286	$untaint_pat = $wanted->{untaint_pattern};
	287	$untaint_skip = $wanted->{untaint_skip};
	288
	289
	290	# a symbolic link to a directory doesn't increase the link count
	291	$avoid_nlink = $follow \|\| $File::Find::dont_use_nlink;
	292
	293	if ( $untaint ) {
	294	$cwd_untainted= $1 if $cwd_untainted =~ m\|$untaint_pat\|;
	295	die "insecure cwd in find(depth)" unless defined($cwd_untainted);
	296	}
	297
	298	my ($abs_dir, $nlink, $Is_Dir);
	299
	300	Proc_Top_Item:
	301	foreach my $TOP (@_) {
	302	my $top_item = $TOP;
	303	$top_item =~ s\|/$\|\|;
	304	$Is_Dir= 0;
	305
	306	if ($follow) {
	307	if (substr($top_item,0,1) eq '/') {
	308	$abs_dir = $top_item;
	309	}
	310	elsif ($top_item eq '.') {
	311	$abs_dir = $cwd;
237437d0	312	}
81793b90	313	else { # care about any ../
	314	$abs_dir = contract_name("$cwd/",$top_item);
	315	}
	316	$abs_dir= Follow_SymLink($abs_dir);
	317	unless (defined $abs_dir) {
	318	warn "$top_item is a dangling symbolic link\n";
	319	next Proc_Top_Item;
	320	}
	321	if (-d _) {
	322	_find_dir_symlnk($wanted, $abs_dir, $top_item);
	323	$Is_Dir= 1;
	324	}
	325	}
	326	else { # no follow
	327	$nlink = (lstat $top_item)[3];
	328	unless (defined $nlink) {
	329	warn "Can't stat $top_item: $!\n";
	330	next Proc_Top_Item;
	331	}
	332	if (-d _) {
	333	$top_item =~ s/\.dir$// if $Is_VMS;
	334	_find_dir($wanted, $top_item, $nlink);
	335	$Is_Dir= 1;
	336	}
237437d0	337	else {
81793b90	338	$abs_dir= $top_item;
	339	}
	340	}
	341
	342	unless ($Is_Dir) {
	343	unless (($_,$dir) = File::Basename::fileparse($abs_dir)) {
	344	($dir,$_) = ('.', $top_item);
	345	}
	346
	347	$abs_dir = $dir;
	348	if ($untaint) {
	349	my $abs_dir_save = $abs_dir;
	350	$abs_dir = $1 if $abs_dir =~ m\|$untaint_pat\|;
	351	unless (defined $abs_dir) {
	352	if ($untaint_skip == 0) {
	353	die "directory $abs_dir_save is still tainted";
	354	}
	355	else {
	356	next Proc_Top_Item;
	357	}
	358	}
	359	}
	360
	361	unless ($no_chdir or chdir $abs_dir) {
	362	warn "Couldn't chdir $abs_dir: $!\n";
	363	next Proc_Top_Item;
	364	}
	365
	366	$name = $abs_dir;
	367
	368	&$wanted_callback;
	369
	370	}
	371
	372	$no_chdir or chdir $cwd_untainted;
	373	}
	374	}
	375
	376	# API:
	377	# $wanted
	378	# $p_dir : "parent directory"
	379	# $nlink : what came back from the stat
	380	# preconditions:
	381	# chdir (if not no_chdir) to dir
	382
	383	sub _find_dir($$$) {
	384	my ($wanted, $p_dir, $nlink) = @_;
	385	my ($CdLvl,$Level) = (0,0);
	386	my @Stack;
	387	my @filenames;
	388	my ($subcount,$sub_nlink);
	389	my $SE= [];
	390	my $dir_name= $p_dir;
	391	my $dir_rel= '.'; # directory name relative to current directory
	392
	393	local ($dir, $name, $prune, *DIR);
	394
	395	unless ($no_chdir or $p_dir eq '.') {
	396	my $udir = $p_dir;
	397	if ($untaint) {
	398	$udir = $1 if $p_dir =~ m\|$untaint_pat\|;
	399	unless (defined $udir) {
	400	if ($untaint_skip == 0) {
	401	die "directory $p_dir is still tainted";
402	}
403	else {
404	return;
405	}
237437d0	406	}
a0d0e21e	407	}
81793b90	408	unless (chdir $udir) {
	409	warn "Can't cd to $udir: $!\n";
	410	return;
	411	}
	412	}
	413
	414	while (defined $SE) {
	415	unless ($bydepth) {
	416	$dir= $p_dir;
	417	$name= $dir_name;
	418	$_= ($no_chdir ? $dir_name : $dir_rel );
	419	# prune may happen here
	420	$prune= 0;
	421	&$wanted_callback;
	422	next if $prune;
	423	}
	424
	425	# change to that directory
	426	unless ($no_chdir or $dir_rel eq '.') {
	427	my $udir= $dir_rel;
	428	if ($untaint) {
	429	$udir = $1 if $dir_rel =~ m\|$untaint_pat\|;
	430	unless (defined $udir) {
	431	if ($untaint_skip == 0) {
	432	die "directory ($p_dir/) $dir_rel is still tainted";
	433	}
	434	}
	435	}
	436	unless (chdir $udir) {
	437	warn "Can't cd to ($p_dir/) $udir : $!\n";
	438	next;
	439	}
	440	$CdLvl++;
	441	}
	442
	443	$dir= $dir_name;
	444
	445	# Get the list of files in the current directory.
	446	unless (opendir DIR, ($no_chdir ? $dir_name : '.')) {
	447	warn "Can't opendir($dir_name): $!\n";
	448	next;
	449	}
	450	@filenames = readdir DIR;
	451	closedir(DIR);
	452
	453	if ($nlink == 2 && !$avoid_nlink) {
	454	# This dir has no subdirectories.
	455	for my $FN (@filenames) {
	456	next if $FN =~ /^\.{1,2}$/;
	457
	458	$name = "$dir_name/$FN";
	459	$_ = ($no_chdir ? $name : $FN);
	460	&$wanted_callback;
	461	}
	462
	463	}
	464	else {
	465	# This dir has subdirectories.
	466	$subcount = $nlink - 2;
	467
	468	for my $FN (@filenames) {
	469	next if $FN =~ /^\.{1,2}$/;
	470	if ($subcount > 0 \|\| $avoid_nlink) {
	471	# Seen all the subdirs?
472	# check for directoriness.
473	# stat is faster for a file in the current directory
474	$sub_nlink = (lstat ($no_chdir ? "$dir_name/$FN" : $FN))[3];
475
476	if (-d _) {
477	--$subcount;
478	$FN =~ s/\.dir$// if $Is_VMS;
479	push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink];
480	}
481	else {
482	$name = "$dir_name/$FN";
483	$_= ($no_chdir ? $name : $FN);
484	&$wanted_callback;
485	}
486	}
487	else { $name = "$dir_name/$FN";
488	$_= ($no_chdir ? $name : $FN);
489	&$wanted_callback;
490	}
491	}
492	}
493	if ($bydepth) {
494	$name = $dir_name;
495	$dir = $p_dir;
496	$_ = ($no_chdir ? $dir_name : $dir_rel );
497	&$wanted_callback;
498	}
17b275ff	499	}
17b275ff	500	continue {
81793b90	501	if ( defined ($SE = pop @Stack) ) {
	502	($Level, $p_dir, $dir_rel, $nlink) = @$SE;
	503	if ($CdLvl > $Level && !$no_chdir) {
	504	die "Can't cd to $dir_name" . '../' x ($CdLvl-$Level)
	505	unless chdir '../' x ($CdLvl-$Level);
	506	$CdLvl = $Level;
	507	}
	508	$dir_name = "$p_dir/$dir_rel";
	509	}
a0d0e21e	510	}
	511	}
	512
81793b90	513
	514	# API:
	515	# $wanted
	516	# $dir_loc : absolute location of a dir
	517	# $p_dir : "parent directory"
	518	# preconditions:
	519	# chdir (if not no_chdir) to dir
	520
	521	sub _find_dir_symlnk($$$) {
	522	my ($wanted, $dir_loc, $p_dir) = @_;
	523	my @Stack;
	524	my @filenames;
	525	my $new_loc;
	526	my $SE = [];
	527	my $dir_name = $p_dir;
	528	my $dir_rel = '.'; # directory name relative to current directory
	529
	530	local ($dir, $name, $fullname, $prune, *DIR);
	531
	532	unless ($no_chdir or $p_dir eq '.') {
	533	my $udir = $dir_loc;
	534	if ($untaint) {
	535	$udir = $1 if $dir_loc =~ m\|$untaint_pat\|;
	536	unless (defined $udir) {
	537	if ($untaint_skip == 0) {
	538	die "directory $dir_loc is still tainted";
	539	}
	540	else {
	541	return;
	542	}
	543	}
	544	}
	545	unless (chdir $udir) {
	546	warn "Can't cd to $udir: $!\n";
	547	return;
	548	}
	549	}
	550
	551	while (defined $SE) {
	552
	553	unless ($bydepth) {
	554	$dir= $p_dir;
	555	$name= $dir_name;
	556	$_= ($no_chdir ? $dir_name : $dir_rel );
	557	$fullname= $dir_loc;
	558	# prune may happen here
	559	$prune= 0;
	560	&$wanted_callback;
	561	next if $prune;
	562	}
	563
	564	# change to that directory
	565	unless ($no_chdir or $dir_rel eq '.') {
	566	my $udir = $dir_loc;
	567	if ($untaint) {
	568	$udir = $1 if $dir_loc =~ m\|$untaint_pat\|;
	569	unless (defined $udir ) {
	570	if ($untaint_skip == 0) {
	571	die "directory $dir_loc is still tainted";
a0d0e21e	572	}
237437d0	573	else {
81793b90	574	next;
237437d0	575	}
a0d0e21e	576	}
a0d0e21e	577	}
81793b90	578	unless (chdir $udir) {
	579	warn "Can't cd to $udir: $!\n";
	580	next;
	581	}
	582	}
	583
	584	$dir = $dir_name;
	585
	586	# Get the list of files in the current directory.
	587	unless (opendir DIR, ($no_chdir ? $dir_loc : '.')) {
	588	warn "Can't opendir($dir_loc): $!\n";
	589	next;
	590	}
	591	@filenames = readdir DIR;
	592	closedir(DIR);
	593
	594	for my $FN (@filenames) {
	595	next if $FN =~ /^\.{1,2}$/;
	596
	597	# follow symbolic links / do an lstat
	598	$new_loc= Follow_SymLink("$dir_loc/$FN");
	599
	600	# ignore if invalid symlink
	601	next unless defined $new_loc;
	602
	603	if (-d _) {
	604	push @Stack,[$new_loc,$dir_name,$FN];
	605	}
	606	else {
	607	$fullname = $new_loc;
	608	$name = "$dir_name/$FN";
	609	$_ = ($no_chdir ? $name : $FN);
	610	&$wanted_callback;
	611	}
	612	}
	613
	614	if ($bydepth) {
	615	$fullname = $dir_loc;
	616	$name = $dir_name;
	617	$_ = ($no_chdir ? $dir_name : $dir_rel);
	618	&$wanted_callback;
	619	}
	620	}
	621	continue {
	622	if (defined($SE = pop @Stack)) {
	623	($dir_loc, $p_dir, $dir_rel) = @$SE;
	624	$dir_name = "$p_dir/$dir_rel";
a0d0e21e	625	}
	626	}
	627	}
	628
81793b90	629
20408e3c	630	sub wrap_wanted {
81793b90	631	my $wanted = shift;
	632	if ( ref($wanted) eq 'HASH' ) {
	633	if ( $wanted->{follow} \|\| $wanted->{follow_fast}) {
	634	$wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip};
	635	}
	636	if ( $wanted->{untaint} ) {
	637	$wanted->{untaint_pattern} = qr\|^([-+@\w./]+)$\|
	638	unless defined $wanted->{untaint_pattern};
	639	$wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip};
	640	}
	641	return $wanted;
	642	}
	643	else {
	644	return { wanted => $wanted };
	645	}
a0d0e21e	646	}
a0d0e21e	647
20408e3c	648	sub find {
81793b90	649	my $wanted = shift;
	650	_find_opt(wrap_wanted($wanted), @_);
	651	%SLnkSeen= (); # free memory
a0d0e21e	652	}
a0d0e21e	653
55d729e4	654	sub finddepth {
81793b90	655	my $wanted = wrap_wanted(shift);
	656	$wanted->{bydepth} = 1;
	657	_find_opt($wanted, @_);
	658	%SLnkSeen= (); # free memory
20408e3c	659	}
6280b799	660
6280b799	661	# These are hard-coded for now, but may move to hint files.
10eba763	662	if ($^O eq 'VMS') {
81793b90	663	$Is_VMS = 1;
81793b90	664	$File::Find::dont_use_nlink = 1;
748a9306	665	}
748a9306	666
81793b90	667	$File::Find::dont_use_nlink = 1
3e8584ad	668	if $^O eq 'os2' \|\| $^O eq 'dos' \|\| $^O eq 'amigaos' \|\| $^O eq 'MSWin32';
6280b799	669
20408e3c	670	# Set dont_use_nlink in your hint file if your system's stat doesn't
	671	# report the number of links in a directory as an indication
	672	# of the number of files.
	673	# See, e.g. hints/machten.sh for MachTen 2.2.
81793b90	674	unless ($File::Find::dont_use_nlink) {
	675	require Config;
	676	$File::Find::dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'});
20408e3c	677	}
20408e3c	678
a0d0e21e	679	1;