Path: utzoo!attcan!telly!lethe!yunexus!ists!helios.physics.utoronto.ca!news-server.csri.toronto.edu!cs.utexas.edu!uunet!shelby!agate!ucbvax!iwarp.intel.com!news
From: merlyn@iwarp.intel.com (Randal L. Schwartz)
Newsgroups: comp.lang.perl
Subject: ftw.pl (was Re: perl find)
Message-ID: <1991Feb21.174657.3357@iwarp.intel.com>
Date: 21 Feb 91 17:46:57 GMT
References: <1991Feb21.133315.25700@uvaarpa.Virginia.EDU>
Sender: news@iwarp.intel.com
Reply-To: merlyn@iwarp.intel.com (Randal L. Schwartz)
Organization: Stonehenge; netaccess via Intel, Beaverton, Oregon, USA
Lines: 222
In-Reply-To: frech@mwraaa.army.mil (Norman R. Frech CPLS)

In article <1991Feb21.133315.25700@uvaarpa.Virginia.EDU>, frech@mwraaa (Norman R. Frech CPLS) writes:
| Has anyone written a perl version of find?  I have rewritten my backup
| to tape routines in perl and use multiple finds to generate the
| catalog.  I have started working on the find subroutines and I thought
| if someone already has this code I could save some time and effort.

I'm using ftw.pl from below every day, and beta-testing ftw2.pl.  I'd
recommend ftw2.pl if it works, but can't vouch for its robustness yet.

By the way, I'm definitely interested in bug reports.  I might get
ftw2 into 4.0 (nudging Larry) if I get on it fast enough. :-)

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#		"End of shell archive."
# Contents:  ftw.pl ftw2.pl
# Wrapped by merlyn@iwarpse on Thu Feb 21 09:43:04 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'ftw.pl' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'ftw.pl'\"
else
echo shar: Extracting \"'ftw.pl'\" \(2183 characters\)
sed "s/^X//" >'ftw.pl' <<'END_OF_FILE'
X## ftw.pl rev 3.0
X
X# &ftw("path","function-name")
X# calls &function-name("path/file") for each name returned by the
X# equivalent of "find path -xdev -print"
X
Xsub ftw {
X	local($path, $fn) = @_;
X	local(*CHILD);
X	local($preslash) = $/;
X	local($/);
X	local($_);
X	# flushing STDOUT:
X	local($preselect) = select(STDOUT);
X	local($prepipe) = $|;
X	$| = 1;
X	print "";
X	$| = $prepipe;
X	select($preselect);
X	# end flushing STDOUT
X	$CHILD = open(CHILD,'-|');
X	die "ftw: Cannot fork ($!)" unless defined $CHILD;
X	unless ($CHILD) { # I am the child
X		$| = 1; # don't buffer stdout
X		chdir $path || die "Cannot cd to $path ($!)";
X		&ftw'helper($path);
X		exit 0;
X	}
X	# I am the parent
X	$/ = "\000";
X	while (<CHILD>) {
X		chop;
X		{
X		 	local($/) = $preslash;
X			do $fn("".$_);
X		}
X	}
X	close(CHILD);
X}
X
Xsub ftw'helper {
X	# expects to be cd'ed to $DIR
X	local(*DIR); ($DIR) = @_;
X	$DIR = "" if $DIR eq "/"; # no "//..."!
X	local($dev, $ino, $mode, $nlink) = stat('.');
X	local($_,$name);
X
X	opendir(DIR,'.') || die "Cannot open $DIR ($!)";
X	local(@filenames) = sort readdir(DIR);
X	closedir(DIR);
X
X	if ($nlink == 2) {
X		print grep(!/^\.\.?$/ && s#[^\000]+#$DIR/$&\000#, @filenames);
X	} else {
X		for (@filenames) {
X			next if /^\.\.?$/;
X			$name = "$DIR/$_";
X			print $name,"\000";
X			next unless ! -l $_ && -d _ && -r _ && -x _;
X			next if $dev != (stat(_))[$[+0]; # "-xdev"
X			unless (chdir $_) {
X				warn "Cannot chdir to $name ($!)";
X				next;
X			}
X			&ftw'helper($name);
X			chdir '..';
X		}
X	}
X}
X
X# &ftw_root("function-name")
X# calls &function-name("/file",stat("/file")) for each name
X# returned by the equivalent of "find / -fstype nfs -prune -o -print"
X# note that stat buffer _ is correct during the call (unlike &ftw() above)
X
Xsub ftw_root {
X	local($ftw_root'fn) = @_;
X	local(@ftw_root'devlist) = ('/');
X	local($_);
X	while ($_ = shift @ftw_root'devlist) {
X		&ftw($_,"ftw_root'helper");
X	}
X}
X
Xsub ftw_root'helper {
X	local($file) = @_;
X	local(@s) = lstat($file);
X	return unless @s;
X	local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
X		$atime,$mtime,$ctime,$blksize,$blocks) = @s;
X	if (($ino == 2) && ($dev > 0) && ($dev < 16384)) {
X		push(@ftw_root'devlist,$file);
X	}
X	do $ftw_root'fn("".$file);
X}
X
X1;
END_OF_FILE
if test 2183 -ne `wc -c <'ftw.pl'`; then
    echo shar: \"'ftw.pl'\" unpacked with wrong size!
fi
# end of 'ftw.pl'
fi
if test -f 'ftw2.pl' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'ftw2.pl'\"
else
echo shar: Extracting \"'ftw2.pl'\" \(1590 characters\)
sed "s/^X//" >'ftw2.pl' <<'END_OF_FILE'
X## ftw.pl rev 4.0alpha
X
Xpackage ftw;
X
X# &ftw("path","function-name")
X# calls &function-name("path/file") for each name returned by the
X# equivalent of "find path -xdev -print"
X
Xsub main'ftw {
X	local($path, $fn) = @_;
X
X	$fn =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
X	if (-d $path) {
X		&helper($path);
X	} elsif (-e $path) {
X		do $fn("$path");
X	}
X}
X
Xsub helper {
X	local($path) = @_;
X
X	local($dev, $ino, $mode, $nlink) = stat($path);
X	local($_,*DIR);
X	opendir(DIR,$path) || die "Cannot open $DIR ($!)";
X	local(@filenames) = sort grep(!/^\.\.?$/, readdir(DIR));
X	closedir(DIR);
X
X	if ($nlink == 2) {
X		for (@filenames) {
X			do $fn("$path/$_");
X		}
X	} else {
X		for (@filenames) {
X			$_ = "$path/$_";
X			do $fn("$_"); # cannot pass $_ as lvalue
X			next unless ! -l $_ && -d _ && -r _ && -x _;
X			next if $dev != (stat(_))[$[+0]; # "-xdev"
X			&helper("$_"); # recurse if directory
X		}
X	}
X}
X
Xpackage ftw_root;
X
X# &ftw_root("function-name")
X# calls &function-name("/file",stat("/file")) for each name
X# returned by the equivalent of "find / -fstype nfs -prune -o -print"
X# note that stat buffer _ is correct during the call (unlike &ftw() above)
X
Xsub main'ftw_root {
X	local($fn) = @_;
X	local($devlist) = ('/');
X	local($_);
X	while ($_ = shift @devlist) {
X		&ftw($_,"root_helper");
X	}
X}
X
Xsub root_helper {
X	local($file) = @_;
X	local(@s) = lstat($file);
X	return unless @s;
X	local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
X		$atime,$mtime,$ctime,$blksize,$blocks) = @s;
X	if (($ino == 2) && ($dev > 0) && ($dev < 16384)) {
X		push(@devlist,$file);
X	}
X	do $fn("$file"); # don't pass $file as an lvalue
X}
X
X1;
END_OF_FILE
if test 1590 -ne `wc -c <'ftw2.pl'`; then
    echo shar: \"'ftw2.pl'\" unpacked with wrong size!
fi
# end of 'ftw2.pl'
fi
echo shar: End of shell archive.
exit 0

print "Just another Perl hacker," # OK, so I'm unimaginative. :-)
-- 
/=Randal L. Schwartz, Stonehenge Consulting Services (503)777-0095 ==========\
| on contract to Intel's iWarp project, Beaverton, Oregon, USA, Sol III      |
| merlyn@iwarp.intel.com ...!any-MX-mailer-like-uunet!iwarp.intel.com!merlyn |
\=Cute Quote: "Intel: putting the 'backward' in 'backward compatible'..."====/