find.pm

Astercon2 开源软交换 2.2.0

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

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

    return substr($cdir,0,rindex($cdir,'/')) if $fn eq $File::Find::current_dir;

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

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

    my $abs_name= $cdir . $fn;

    if (substr($fn,0,3) eq '../') {
       1 while $abs_name =~ s!/[^/]*/\.\./!/!;
    }

    return $abs_name;
}

# return the absolute name of a directory or file
sub contract_name_Mac {
    my ($cdir,$fn) = @_;
    my $abs_name;

    if ($fn =~ /^(:+)(.*)$/) { # valid pathname starting with a ':'

	my $colon_count = length ($1);
	if ($colon_count == 1) {
	    $abs_name = $cdir . $2;
	    return $abs_name;
	}
	else {
	    # need to move up the tree, but
	    # only if it's not a volume name
	    for (my $i=1; $i<$colon_count; $i++) {
		unless ($cdir =~ /^[^:]+:$/) { # volume name
		    $cdir =~ s/[^:]+:$//;
		}
		else {
		    return undef;
		}
	    }
	    $abs_name = $cdir . $2;
	    return $abs_name;
	}

    }
    else {

	# $fn may be a valid path to a directory or file or (dangling)
	# symlink, without a leading ':'
	if ( (-e $fn) || (-l $fn) ) {
	    if ($fn =~ /^[^:]+:/) { # a volume name like DataHD:*
		return $fn; # $fn is already an absolute path
	    }
	    else {
		$abs_name = $cdir . $fn;
		return $abs_name;
	    }
	}
	else { # argh!, $fn is not a valid directory/file
	     return undef;
	}
    }
}

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

    if ($Is_MacOS) {
	# $Name is the resolved symlink (always a full path on MacOS),
	# i.e. there's no need to call contract_name_Mac()
	$AbsName = $Name;

	# (simple) check for recursion
	if ( ( $Base =~ /^$AbsName/) && (-d $AbsName) ) { # recursion
	    return undef;
	}
    }
    else {
	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 && defined $DEV && $SLnkSeen{$DEV, $INO}++) {
	if ( ($follow_skip < 1) || ((-d _) && ($follow_skip < 2)) ) {
	    die "$AbsName encountered a second time";
	}
	else {
	    return undef;
	}
    }

    return $AbsName;
}

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

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

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

    # This function must local()ize everything because callbacks may
    # call find() or finddepth()

    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;

    my $cwd            = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::getcwd();
    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        = $^O eq 'MSWin32' ? 0 : $wanted->{follow};
    $follow            = $^O eq 'MSWin32' ? 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};

    # for compatibility reasons (find.pl, find2perl)
    local 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;

    my ($abs_dir, $Is_Dir);

    Proc_Top_Item:
    foreach my $TOP (@_) {
	my $top_item = $TOP;

	($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item;

	if ($Is_MacOS) {
	    $top_item = ":$top_item"
		if ( (-d _) && ( $top_item !~ /:/ ) );
	} elsif ($^O eq 'MSWin32') {
	    $top_item =~ s|/\z|| unless $top_item =~ m|\w:/$|;
	}
	else {
	    $top_item =~ s|/\z|| unless $top_item eq '/';
	}

	$Is_Dir= 0;

	if ($follow) {

	    if ($Is_MacOS) {
		$cwd = "$cwd:" unless ($cwd =~ /:$/); # for safety

		if ($top_item eq $File::Find::current_dir) {
		    $abs_dir = $cwd;
		}
		else {
		    $abs_dir = contract_name_Mac($cwd, $top_item);
		    unless (defined $abs_dir) {
			warnings::warnif "Can't determine absolute path for $top_item (No such file or directory)\n";
			next Proc_Top_Item;
		    }
		}

	    }
	    else {
		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  ../
		    $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;
	    }

	    if (-d _) {
		_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;
	    }
	}

	unless ($Is_Dir) {
	    unless (($_,$dir) = File::Basename::fileparse($abs_dir)) {
		if ($Is_MacOS) {
		    ($dir,$_) = (':', $top_item); # $File::Find::dir, $_
		}
		else {
		    ($dir,$_) = ('./', $top_item);
		}
	    }

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

	    unless ($no_chdir || chdir $abs_dir) {
		warnings::warnif "Couldn't chdir $abs_dir: $!\n";
		next Proc_Top_Item;
	    }

	    $name = $abs_dir . $_; # $File::Find::name
	    $_ = $name if $no_chdir;

	    { $wanted_callback->() }; # protect against wild "next"

	}

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

# 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;
    my $dir_rel = $File::Find::current_dir;
    my $tainted = 0;
    my $no_nlink;

    if ($Is_MacOS) {
	$dir_pref= ($p_dir =~ /:$/) ? $p_dir : "$p_dir:"; # preface
    } elsif ($^O eq 'MSWin32') {
	$dir_pref = ($p_dir =~ m|\w:/$| ? $p_dir : "$p_dir/" );
    }
    else {
	$dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" );
    }

    local ($dir, $name, $prune, *DIR);

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

    # push the starting directory
    push @Stack,[$CdLvl,$p_dir,$dir_rel,-1]  if  $bydepth;

    if ($Is_MacOS) {
	$p_dir = $dir_pref;  # ensure trailing ':'
    }

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

	# 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) {
			if ($Is_MacOS) {
			    die "directory ($p_dir) $dir_rel is still tainted";
			}
			else {
			    die "directory (" . ($p_dir ne '/' ? $p_dir : '') . "/) $dir_rel is still tainted";
			}
		    } else { # $untaint_skip == 1
			next;
		    }
		}
	    }
	    unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) {
		if ($Is_MacOS) {
		    warnings::warnif "Can't cd to ($p_dir) $udir: $!\n";
		}
		else {
		    warnings::warnif "Can't cd to (" .
			($p_dir ne '/' ? $p_dir : '') . "/) $udir: $!\n";
		}
		next;