lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) (03/05/91)
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.
(There ought to be a switch that spits out a package instead of a program,
but that's not done yet either. All you need to do is slap a package
declaration on the front and avoid calling &dodirs when the package is
required. Well, actually, only the &wanted subroutine really needs to
be in the package--the others could be global...)
Feel free to play with it and/or send/post any additions or comments.
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}
Xfor (@roots) { $_ = "e($_); }
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 = shift;
X $pat = "*$pat*" unless $pat =~ tr/?*[//;
X $pat = &fileglob_to_re($pat);
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("$dir/$_\n")';
X }
X elsif ($_ eq 'print0') {
X $out .= &tab . 'print("$dir/$_\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 " . "e($file) . ";\n";
X }
X elsif ($_ eq 'eval') {
X $prog = "e(shift);
X $out .= &tab . "eval $prog";
X }
X elsif ($_ eq 'cpio') {
X die "-cpio not implemented\n";
X }
X elsif ($_ eq 'ls') {
X die "-ls not implemented\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 ($inituser) {
X print <<'END';
Xwhile (($name, $pw, $uid) = getpwent) { $uid{$name} = $uid{$uid} = $uid; }
X
XEND
X}
X
Xif ($initgroup) {
X print <<'END';
Xwhile (($name, $pw, $gid) = getgrent) { $gid{$name} = $gid{$gid} = $gid; }
X
XEND
X}
X
Xprint $initnewer, "\n" if $initnewer;
X
Xprint <<"END";
X# Traverse desired filesystems
X
X&dodirs($roots);
X
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)) {
X $topdir = '' if $topdir eq '/';
X &dodir($topdir,$topnlink);
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
X # Get the list of files in the current directory.
X
X opendir(DIR,'.') || die "Can't open $dir";
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 &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 &wanted;
X next 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 next unless -d _;
X next if $prune;
X
X # It really is a directory, so do it recursively.
X
X if (chdir $_) {
X &dodir("$dir/$_",$nlink);
X chdir '..';
X }
X --$subcount;
X }
X }
X}
X
XEND
X
Xif ($initexec) {
X print <<'END';
Xsub exec {
X local($ok, @cmd) = @_;
X foreach $word (@cmd) {
X $word =~ s#{}#$dir/$_#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
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.
exitrep@genrad.com (Pete Peterson) (03/05/91)
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*'"?
lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) (03/07/91)
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) { $_ = "e($_); } 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 " . "e($file) . ";\n"; X } X elsif ($_ eq 'eval') { X $prog = "e(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, " . "e($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, " . "e($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
rep@genrad.com (Pete Peterson) (03/07/91)
In article <11709@jpl-devvax.JPL.NASA.GOV> lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) writes: > >I've fixed that, and added -depth, -ls, -cpio, -ncpio and -tar. So you >can call this a beta. > Running the new version, I get, (sparc 1 -- SunOS 4.0.3): thor% find2perl / -name vmunix -print | perl yacc stack overflow in file find2perl at line 166, next 2 tokens ". substr" Execution of find2perl aborted due to compilation errors. . . . This is perl, version 3.0 $Header: perly.c,v 3.0.1.10 91/01/11 18:22:48 lwall Locked $ Patch level: 44 ---------------------------------------------------------------------- Being a hardware person, I have enough trouble understanding my own yacc grammars without trying to understand Larry's. Here are the final death throes, as produced by perl -D1023 (because I was too lazy to look up which bit I really wanted) in case they are helpful. ---------------------------------------------------------------------- state 4, char 037777777777 reduce 11 state 237, char 037777777777 Tokener at Tokener at Tokener at $out .= "&cpio('" . substr($_,0,1) . "', $fh)"; Tokener at $out .= "&cpio('" . substr($_,0,1) . "', $fh)"; reduce 39 state 6, char 0462 state 40, char 037777777777 Tokener at .= "&cpio('" . substr($_,0,1) . "', $fh)"; Tokener at .= "&cpio('" . substr($_,0,1) . "', $fh)"; reduce 95 0x7d188: (02113) malloc 24 bytes state 29, char 0456 reduce 77 state 27, char 0456 state 109, char 037777777777 Tokener at = "&cpio('" . substr($_,0,1) . "', $fh)"; state 217, char 037777777777 Tokener at "&cpio('" . substr($_,0,1) . "', $fh)"; Tokener at "&cpio('" . substr($_,0,1) . "', $fh)"; 0x7d548: (02114) malloc 24 bytes 0x7d588: (02115) malloc 32 bytes 0x61008: (02116) malloc 81 bytes 0x61008: (02117) rfree 0x7a408: (02118) realloc 8 bytes state 46, char 037777777777 reduce 106 state 29, char 037777777777 Tokener at . substr($_,0,1) . "', $fh)"; Tokener at . substr($_,0,1) . "', $fh)"; reduce 77 state 292, char 0456 state 109, char 037777777777 Tokener at substr($_,0,1) . "', $fh)"; Tokener at substr($_,0,1) . "', $fh)"; state 71, char 037777777777 yacc stack overflow in file find2perl at line 166, next 2 tokens ". substr" Execution of find2perl aborted due to compilation errors.
les@chinet.chi.il.us (Leslie Mikesell) (03/09/91)
In article <11709@jpl-devvax.JPL.NASA.GOV> lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) writes: >I've fixed that, and added -depth, -ls, -cpio, -ncpio and -tar. So you >can call this a beta. With pl44 on AT&T's SysVr3, I just get a yacc stack overflow. Is this yet another arbitrary AT&T restriction or did I do something wrong? Les Mikesell les@chinet.chi.il.us
ndjc@mendip.UUCP (Nick Crossley) (03/11/91)
In article <11709@jpl-devvax.JPL.NASA.GOV> lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) writes: >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... There is also the problem that tar and cpio are not as standard as one would like. There are a surprising number of differences in the exact formats (mainly caused by design and implementation bugs in cpio, various extensions of tar, POSIX changes, etc.). V.4 has a new cpio (in fact, a merge of cpio and tar, with support for most of the old formats plus at least two new ones). With all this confusion, I'm not sure it's a good idea to build in yet another cpio/tar encoding. It was a mistake for find to include a copy of the cpio code in the first place, and in V.4 those options are marked as obsolete and due to be withdrawn. Of course, you could argue that the perl version is an attempt to impose a portable cpio, but then the old cpio format with its header fields too small for 32 bit numbers is a poor design to begin with, and not something that one would want to perpetuate. -- <<< standard disclaimers >>> Nick Crossley, ICL NA, 9801 Muirlands, Irvine, CA 92718-2521, USA 714-458-7282 uunet!ccicpg!ndjc / ndjc@irv.icl.com