Path: utzoo!news-server.csri.toronto.edu!cs.utexas.edu!usc!elroy.jpl.nasa.gov!jpl-devvax!lwall
From: lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall)
Newsgroups: comp.lang.perl
Subject: Re: find2perl
Message-ID: <11709@jpl-devvax.JPL.NASA.GOV>
Date: 7 Mar 91 02:27:36 GMT
References: <11674@jpl-devvax.JPL.NASA.GOV> <40887@genrad.UUCP>
Reply-To: lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall)
Organization: Jet Propulsion Laboratory, Pasadena, CA
Lines: 675

In article <40887@genrad.UUCP> rep@thor.genrad.COM (Pete Peterson) writes:
: In article <11674@jpl-devvax.JPL.NASA.GOV> lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) writes:
:  >This is an alpha version of find2perl.  It spits out a perl script that
:  >does the same thing (hopefully) as the corresponding find command.
:  >
:  >Usage:
:  >
:  >	find2perl . -name '*.bak' -print | perl
:  >
:  >This isn't thoroughly tested.  It does do -print0 and -eval.  It doesn't
:  >do -ls or -cpio (yet).  It does try pretty hard to avoid unnecessary
:  >stats.
: 
: OK, I give up.  I'll ask the dumb question.  Why does it do:
: 	        $pat = "*$pat*" unless $pat =~ tr/?*[//;
: 
: thus changing "find2perl . -name 'core'" into "find2perl . -name '*core*'"? 

Not a dumb question at all.  I misread the man page, and got confused by
a feature that only applies to "fast find".

I've fixed that, and added -depth, -ls, -cpio, -ncpio and -tar.  So you
can call this a beta.

I didn't realize till now just how much random crap tar and cpio leave sitting
around in their output files...

BTW, Sun's find -cpio sets the inode number of a directory wrong, though
it's probable that no one actually looks at it.

Larry

#!/bin/sh
: make a subdirectory, cd to it, and run this through sh.
echo 'If this kit is complete, "End of kit" will echo at the end'
echo Extracting find2perl
sed >find2perl <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
Xwhile ($ARGV[0] =~ /^[^-(]/) {
X    push(@roots, shift);
X}
X@roots = ('.') unless @roots;
Xfor (@roots) { $_ = &quote($_); }
X$roots = join(',', @roots);
X
X$indent = 1;
X
Xwhile (@ARGV) {
X    $_ = shift;
X    if ($_ eq '(') {
X	$out .= &tab . "(\n";
X	$indent++;
X	next;
X    }
X    elsif ($_ eq ')') {
X	$indent--;
X	$out .= &tab . ")";
X    }
X    elsif ($_ eq '!') {
X	$out .= &tab . "!";
X	next;
X    }
X    else {
X	s/^-// || die "Unrecognized switch: $_\n";
X    }
X    if ($_ eq 'name') {
X	$out .= &tab;
X	$pat = &fileglob_to_re(shift);
X	$out .= '/' . $pat . "/";
X    }
X    elsif ($_ eq 'perm') {
X	$onum = shift;
X	die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/;
X	if ($onum =~ s/^-//) {
X	    $onum = '0' . sprintf("%o", oct($onum) & 017777);	# s/b 07777 ?
X	    $out .= &tab . "(\$mode & $onum) == $onum";
X	}
X	else {
X	    $onum = '0' . $onum unless $onum =~ /^0/;
X	    $out .= &tab . "(\$mode & 0777) == $onum";
X	}
X    }
X    elsif ($_ eq 'type') {
X	($filetest = shift) =~ tr/s/S/;
X	$out .= &tab . "-$filetest _";
X    }
X    elsif ($_ eq 'print') {
X	$out .= &tab . 'print("$name\n")';
X    }
X    elsif ($_ eq 'print0') {
X	$out .= &tab . 'print("$name\0")';
X    }
X    elsif ($_ eq 'fstype') {
X	$out .= &tab;
X	$type = shift;
X	if ($type eq 'nfs')
X	    { $out .= '$dev < 0'; }
X	else
X	    { $out .= '$dev >= 0'; }
X    }
X    elsif ($_ eq 'user') {
X	$uname = shift;
X	$out .= &tab . "\$uid == \$uid{'$uname'}";
X	$inituser++;
X    }
X    elsif ($_ eq 'group') {
X	$gname = shift;
X	$out .= &tab . "\$gid == \$gid('$gname')";
X	$initgroup++;
X    }
X    elsif ($_ eq 'nouser') {
X	$out .= &tab . '!defined $uid{$uid}';
X	$inituser++;
X    }
X    elsif ($_ eq 'nogroup') {
X	$out .= &tab . '!defined $gid{$gid}';
X	$initgroup++;
X    }
X    elsif ($_ eq 'links') {
X	$out .= &tab . '$nlink ' . &n(shift);
X    }
X    elsif ($_ eq 'inum') {
X	$out .= &tab . '$ino ' . &n(shift);
X    }
X    elsif ($_ eq 'size') {
X	$out .= &tab . 'int((-s _ + 511) / 512) ' . &n(shift);
X    }
X    elsif ($_ eq 'atime') {
X	$out .= &tab . 'int(-A _) ' . &n(shift);
X    }
X    elsif ($_ eq 'mtime') {
X	$out .= &tab . 'int(-M _) ' . &n(shift);
X    }
X    elsif ($_ eq 'ctime') {
X	$out .= &tab . 'int(-C _) ' . &n(shift);
X    }
X    elsif ($_ eq 'exec') {
X	for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
X	shift;
X	for (@cmd) { s/'/\\'/g; }
X	$" = "','";
X	$out .= &tab . "&exec(0, '@cmd')";
X	$" = ' ';
X	$initexec++;
X    }
X    elsif ($_ eq 'ok') {
X	for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
X	shift;
X	for (@cmd) { s/'/\\'/g; }
X	$" = "','";
X	$out .= &tab . "&exec(1, '@cmd')";
X	$" = ' ';
X	$initexec++;
X    }
X    elsif ($_ eq 'prune') {
X	$out .= &tab . '($prune = 1)';
X    }
X    elsif ($_ eq 'xdev') {
X	$out .= &tab . '(($prune |= ($dev != $topdev)),1)';
X    }
X    elsif ($_ eq 'newer') {
X	$out .= &tab;
X	$file = shift;
X	$newername = 'AGE_OF' . $file;
X	$newername =~ s/[^\w]/_/g;
X	$newername = '$' . $newername;
X	$out .= "-M _ < $newername";
X	$initnewer .= "$newername = -M " . &quote($file) . ";\n";
X    }
X    elsif ($_ eq 'eval') {
X	$prog = &quote(shift);
X	$out .= &tab . "eval $prog";
X    }
X    elsif ($_ eq 'depth') {
X	$depth++;
X	next;
X    }
X    elsif ($_ eq 'ls') {
X	$out .= &tab . "&ls";
X	$initls++;
X    }
X    elsif ($_ eq 'tar') {
X	$out .= &tab;
X	die "-tar must have a filename argument\n" unless @ARGV;
X	$file = shift;
X	$fh = 'FH' . $file;
X	$fh =~ s/[^\w]/_/g;
X	$out .= "&tar($fh)";
X	$file = '>' . $file;
X	$initfile .= "open($fh, " . &quote($file) .
X	  qq{) || die "Can't open $fh: \$!\\n";\n};
X	$inittar++;
X	$flushall = "\n&tflushall;\n";
X    }
X    elsif (/^n?cpio$/) {
X	$depth++;
X	$out .= &tab;
X	die "-$_ must have a filename argument\n" unless @ARGV;
X	$file = shift;
X	$fh = 'FH' . $file;
X	$fh =~ s/[^\w]/_/g;
X	$out .= "&cpio('" . substr($_,0,1) . "', $fh)";
X	$file = '>' . $file;
X	$initfile .= "open($fh, " . &quote($file) .
X	  qq{) || die "Can't open $fh: \$!\\n";\n};
X	$initcpio++;
X	$flushall = "\n&flushall;\n";
X    }
X    else {
X	die "Unrecognized switch: -$_\n";
X    }
X    if (@ARGV) {
X	if ($ARGV[0] eq '-o') {
X	    $out .= " ||\n";
X	    shift;
X	}
X	else {
X	    $out .= " &&" unless $ARGV[0] eq ')';
X	    $out .= "\n";
X	    shift if $ARGV[0] eq '-a';
X	}
X    }
X}
X
Xprint <<'END';
X#!/usr/bin/perl
X
XEND
X
Xif ($initls) {
X    print <<'END';
X@rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
X@moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
X
XEND
X}
X
Xif ($inituser || $initls) {
X    print 'while (($name, $pw, $uid) = getpwent) {', "\n";
X    print '    $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser;
X    print '    $user{$uid} = $name unless $user{$uid};', "\n" if $initls;
X    print "}\n\n";
X}
X
Xif ($initgroup || $initls) {
X    print 'while (($name, $pw, $gid) = getgrent) {', "\n";
X    print '    $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup;
X    print '    $group{$gid} = $name unless $group{$gid};', "\n" if $initls;
X    print "}\n\n";
X}
X
Xprint $initnewer, "\n" if $initnewer;
X
Xprint $initfile, "\n" if $initfile;
X
Xprint <<"END";
X# Traverse desired filesystems
X
X&dodirs($roots);
X$flushall
Xexit;
X
Xsub wanted {
X$out;
X}
X
XEND
X
Xprint <<'END';
Xsub dodirs {
X    chop($cwd = `pwd`);
X    foreach $topdir (@_) {
X	(($topdev,$topino,$topmode,$topnlink) = stat($topdir))
X	  || (warn("Can't stat $topdir: $!\n"), next);
X	if (-d _) {
X	    if (chdir($topdir)) {
XEND
Xif ($depth) {
X    print <<'END';
X		$topdir = '' if $topdir eq '/';
X		&dodir($topdir,$topnlink);
X		($dir,$_) = ($topdir,'.');
X		$name = $topdir;
X		&wanted;
XEND
X}
Xelse {
X    print <<'END';
X		($dir,$_) = ($topdir,'.');
X		$name = $topdir;
X		&wanted;
X		$topdir = '' if $topdir eq '/';
X		&dodir($topdir,$topnlink);
XEND
X}
Xprint <<'END';
X	    }
X	    else {
X		warn "Can't cd to $topdir: $!\n";
X	    }
X	}
X	else {
X	    unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
X		($dir,$_) = ('.', $topdir);
X	    }
X	    chdir $dir && &wanted;
X	}
X	chdir $cwd;
X    }
X}
X
Xsub dodir {
X    local($dir,$nlink) = @_;
X    local($dev,$ino,$mode,$subcount);
X    local($name);
X
X    # Get the list of files in the current directory.
X
X    opendir(DIR,'.') || warn "Can't open $dir: $!\n";
X    local(@filenames) = readdir(DIR);
X    closedir(DIR);
X
X    if ($nlink == 2) {        # This dir has no subdirectories.
X	for (@filenames) {
X	    next if $_ eq '.';
X	    next if $_ eq '..';
X	    $name = "$dir/$_";
X	    &wanted;
X	}
X    }
X    else {                    # This dir has subdirectories.
X	$subcount = $nlink - 2;
X	for (@filenames) {
X	    next if $_ eq '.';
X	    next if $_ eq '..';
X	    $nlink = $prune = 0;
X	    $name = "$dir/$_";
XEND
Xprint <<'END' unless $depth;
X	    &wanted;
XEND
Xprint <<'END';
X	    if ($subcount > 0) {    # Seen all the subdirs?
X
X		# Get link count and check for directoriness.
X
X		($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
X		
X		if (-d _) {
X
X		    # It really is a directory, so do it recursively.
X
X		    if (!$prune && chdir $_) {
X			&dodir($name,$nlink);
X			chdir '..';
X		    }
X		    --$subcount;
X		}
X	    }
XEND
Xprint <<'END' if $depth;
X	    &wanted;
XEND
Xprint <<'END';
X	}
X    }
X}
X
XEND
X
Xif ($initexec) {
X    print <<'END';
Xsub exec {
X    local($ok, @cmd) = @_;
X    foreach $word (@cmd) {
X	$word =~ s#{}#$name#g;
X    }
X    if ($ok) {
X	local($old) = select(STDOUT);
X	$| = 1;
X	print "@cmd";
X	select($old);
X	return 0 unless <STDIN> =~ /^y/;
X    }
X    chdir $cwd;		# sigh
X    system @cmd;
X    chdir $dir;
X    return !$?;
X}
X
XEND
X}
X
Xif ($initls) {
X    print <<'END';
Xsub ls {
X    ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
X      $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
X
X    $pname = $name;
X
X    if (defined $blocks) {
X	$blocks = int(($blocks + 1) / 2);
X    }
X    else {
X	$blocks = int(($size + 1023) / 1024);
X    }
X
X    if    (-f _) { $perms = '-'; }
X    elsif (-d _) { $perms = 'd'; }
X    elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
X    elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
X    elsif (-p _) { $perms = 'p'; }
X    elsif (-S _) { $perms = 's'; }
X    else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
X
X    $tmpmode = $mode;
X    $tmp = $rwx[$tmpmode & 7];
X    $tmpmode >>= 3;
X    $tmp = $rwx[$tmpmode & 7] . $tmp;
X    $tmpmode >>= 3;
X    $tmp = $rwx[$tmpmode & 7] . $tmp;
X    substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
X    substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
X    substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
X    $perms .= $tmp;
X
X    $user = $user{$uid} || $uid;
X    $group = $group{$gid} || $gid;
X
X    ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
X    $moname = $moname[$mon];
X    if (-M _ > 365.25 / 2) {
X	$timeyear = '19' . $year;
X    }
X    else {
X	$timeyear = sprintf("%02d:%02d", $hour, $min);
X    }
X
X    printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
X	    $ino,
X		 $blocks,
X		      $perms,
X			    $nlink,
X				$user,
X				     $group,
X					  $sizemm,
X					      $moname,
X						 $mday,
X						     $timeyear,
X							 $pname;
X    1;
X}
X
Xsub sizemm {
X    sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255);
X}
X
XEND
X}
X
Xif ($initcpio) {
Xprint <<'END';
Xsub cpio {
X    local($nc,$fh) = @_;
X    local($text);
X
X    if ($name eq 'TRAILER!!!') {
X	$text = '';
X	$size = 0;
X    }
X    else {
X	($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
X	  $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
X	if (-f _) {
X	    open(IN, $_) || do {
X		warn "Couldn't open $name: $!\n";
X		return;
X	    };
X	}
X	else {
X	    $text = readlink($_);
X	    $size = 0 unless defined $text;
X	}
X    }
X
X    ($nm = $name) =~ s#^\./##;
X    $nc{$fh} = $nc;
X    if ($nc eq 'n') {
X	$cpout{$fh} .=
X	  sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
X	    070707,
X	    $dev & 0777777,
X	    $ino & 0777777,
X	    $mode & 0777777,
X	    $uid & 0777777,
X	    $gid & 0777777,
X	    $nlink & 0777777,
X	    $rdev & 0177777,
X	    $mtime,
X	    length($nm)+1,
X	    $size,
X	    $nm);
X    }
X    else {
X	$cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
X	$cpout{$fh} .= pack("SSSSSSSSLSLa*",
X	    070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
X	    length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0"));
X    }
X    if ($text ne '') {
X	$cpout{$fh} .= $text;
X    }
X    elsif ($size) {
X	&flush($fh) while ($l = length($cpout{$fh})) >= 5120;
X	while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
X	    &flush($fh);
X	    $l = length($cpout{$fh});
X	}
X    }
X    close IN;
X}
X
Xsub flush {
X    local($fh) = @_;
X
X    while (length($cpout{$fh}) >= 5120) {
X	syswrite($fh,$cpout{$fh},5120);
X	++$blocks{$fh};
X	substr($cpout{$fh}, 0, 5120) = '';
X    }
X}
X
Xsub flushall {
X    $name = 'TRAILER!!!';
X    foreach $fh (keys %cpout) {
X	&cpio($nc{$fh},$fh);
X	$cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
X	&flush($fh);
X	print $blocks{$fh} * 10, " blocks\n";
X    }
X}
X
XEND
X}
X
Xif ($inittar) {
Xprint <<'END';
Xsub tar {
X    local($fh) = @_;
X    local($linkname,$header,$l,$slop);
X    local($linkflag) = "\0";
X
X    ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
X      $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
X    $nm = $name;
X    if ($nlink > 1) {
X	if ($linkname = $linkseen{$fh,$dev,$ino}) {
X	    $linkflag = 1;
X	}
X	else {
X	    $linkseen{$fh,$dev,$ino} = $nm;
X	}
X    }
X    if (-f _) {
X	open(IN, $_) || do {
X	    warn "Couldn't open $name: $!\n";
X	    return;
X	};
X	$size = 0 if $linkflag ne "\0";
X    }
X    else {
X	$linkname = readlink($_);
X	$linkflag = 2 if defined $linkname;
X	$nm .= '/' if -d _;
X	$size = 0;
X    }
X
X    $header = pack("a100a8a8a8a12a12a8a1a100",
X	$nm,
X	sprintf("%6o ", $mode & 0777),
X	sprintf("%6o ", $uid & 0777777),
X	sprintf("%6o ", $gid & 0777777),
X	sprintf("%11o ", $size),
X	sprintf("%11o ", $mtime),
X	"        ",
X	$linkflag,
X	$linkname);
X    $l = length($header) % 512;
X    substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header));
X    substr($header, 154, 1) = "\0";  # blech
X    $tarout{$fh} .= $header;
X    $tarout{$fh} .= "\0" x (512 - $l) if $l;
X    if ($size) {
X	&tflush($fh) while ($l = length($tarout{$fh})) >= 10240;
X	while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
X	    $slop = length($tarout{$fh}) % 512;
X	    $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
X	    &tflush($fh);
X	    $l = length($tarout{$fh});
X	}
X    }
X    close IN;
X}
X
Xsub tflush {
X    local($fh) = @_;
X
X    while (length($tarout{$fh}) >= 10240) {
X	syswrite($fh,$tarout{$fh},10240);
X	++$blocks{$fh};
X	substr($tarout{$fh}, 0, 10240) = '';
X    }
X}
X
Xsub tflushall {
X    local($len);
X
X    foreach $fh (keys %tarout) {
X	$len = 10240 - length($tarout{$fh});
X	$len += 10240 if $len < 1024;
X	$tarout{$fh} .= "\0" x $len;
X	&tflush($fh);
X    }
X}
X
XEND
X}
X
Xexit;
X
X############################################################################
X
Xsub tab {
X    local($tabstring);
X
X    $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4);
X    if ($_ !~ /^(name|print)/) {
X	if (!$statdone) {
X	    $tabstring .= <<'ENDOFSTAT' . $tabstring;
X(($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
XENDOFSTAT
X	    $statdone = 1;
X	}
X    }
X    $tabstring =~ s/^\s+/ / if $out =~ /!$/;
X    $tabstring;
X}
X
Xsub fileglob_to_re {
X    local($tmp) = @_;
X
X    $tmp =~ s/([.^\$()])/\\$1/g;
X    $tmp =~ s/([?*])/.$1/g;
X    "^$tmp$";
X}
X
Xsub n {
X    local($n) = @_;
X
X    $n =~ s/^-0*/< / || $n =~ s/^\+0*/> / || $n =~ s/^0*/== /;
X    $n;
X}
X
Xsub quote {
X    local($string) = @_;
X    $string =~ s/'/\\'/;
X    "'$string'";
X}
!STUFFY!FUNK!
echo ""
echo "End of kit"
: I do not append .signature, but someone might mail this.
exit