From: Gurusamy Sarathy Date: Sat, 17 Jul 1999 17:34:38 +0000 (+0000) Subject: a modernized version of find2perl from Ken Pizzini ; X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=431613ddf056b228a6eff5370d76e0753ca33da6;p=p5sagit%2Fp5-mst-13.2.git a modernized version of find2perl from Ken Pizzini ; converted Ken's documentation outline into pod p4raw-id: //depot/perl@3677 --- diff --git a/x2p/find2perl.PL b/x2p/find2perl.PL index cbb32fd..da94dc9 100644 --- a/x2p/find2perl.PL +++ b/x2p/find2perl.PL @@ -29,544 +29,586 @@ print OUT <<"!GROK!THIS!"; $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' if \$running_under_some_shell; -\$startperl = "$Config{startperl}"; -\$perlpath = "$Config{perlpath}"; +my \$perlpath = "$Config{perlpath}"; !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; +use strict; +use vars qw/$statdone/; +my $startperl = "#! $perlpath -w"; -# +# # Modified September 26, 1993 to provide proper handling of years after 1999 # Tom Link # University of Pittsburgh -# +# # Modified April 7, 1998 with nasty hacks to implement the troublesome -follow # Billy Constantine # University of Adelaide, Adelaide, South Australia -# +# +# Modified 1999-06-10, 1999-07-07 to migrate to cleaner perl5 usage +# Ken Pizzini +my @roots = (); while ($ARGV[0] =~ /^[^-!(]/) { push(@roots, shift); } @roots = ('.') unless @roots; -for (@roots) { $_ = "e($_); } -$roots = join(',', @roots); - -$indent = 1; -$stat = 'lstat'; -$decl = ''; +for (@roots) { $_ = "e($_) } +my $roots = join(', ', @roots); + +my $find = "find"; +my $indent_depth = 1; +my $stat = 'lstat'; +my $decl = ''; +my $flushall = ''; +my $initfile = ''; +my $initnewer = ''; +my $out = ''; +my %init = (); while (@ARGV) { $_ = shift; s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n"; if ($_ eq '(') { - $out .= &tab . "(\n"; - $indent++; - next; - } - elsif ($_ eq ')') { - $indent--; - $out .= &tab . ")"; - } - elsif ($_ eq 'follow') { - $stat = 'stat'; - $decl = '%already_seen = ();'; - $out .= &tab . '(not $already_seen{"$dev,$ino"}) &&'; - $out .= "\n" . &tab . '(($already_seen{"$dev,$ino"} = !(-d _)) || 1)'; - } - elsif ($_ eq '!') { - $out .= &tab . "!"; - next; - } - elsif ($_ eq 'name') { - $out .= &tab; - $pat = &fileglob_to_re(shift); - $out .= '/' . $pat . "/"; - } - elsif ($_ eq 'perm') { - $onum = shift; - die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/; - if ($onum =~ s/^-//) { - $onum = '0' . sprintf("%o", oct($onum) & 017777); # s/b 07777 ? - $out .= &tab . "((\$mode & $onum) == $onum)"; - } - else { - $onum = '0' . $onum unless $onum =~ /^0/; - $out .= &tab . "((\$mode & 0777) == $onum)"; - } - } - elsif ($_ eq 'type') { - ($filetest = shift) =~ tr/s/S/; - $out .= &tab . "-$filetest _"; - } - elsif ($_ eq 'print') { - $out .= &tab . 'print("$name\n")'; - } - elsif ($_ eq 'print0') { - $out .= &tab . 'print("$name\0")'; - } - elsif ($_ eq 'fstype') { - $out .= &tab; - $type = shift; - if ($type eq 'nfs') - { $out .= '($dev < 0)'; } - else - { $out .= '($dev >= 0)'; } - } - elsif ($_ eq 'user') { - $uname = shift; - $out .= &tab . "(\$uid == \$uid{'$uname'})"; - $inituser++; - } - elsif ($_ eq 'group') { - $gname = shift; - $out .= &tab . "(\$gid == \$gid{'$gname'})"; - $initgroup++; - } - elsif ($_ eq 'nouser') { - $out .= &tab . '!defined $uid{$uid}'; - $inituser++; - } - elsif ($_ eq 'nogroup') { - $out .= &tab . '!defined $gid{$gid}'; - $initgroup++; - } - elsif ($_ eq 'links') { - $out .= &tab . '($nlink ' . &n(shift); - } - elsif ($_ eq 'inum') { - $out .= &tab . '($ino ' . &n(shift); - } - elsif ($_ eq 'size') { - $_ = shift; - if (s/c$//) { - $out .= &tab . '(int(-s _) ' . &n($_); - } else { - $out .= &tab . '(int(((-s _) + 511) / 512) ' . &n($_); - } - } - elsif ($_ eq 'atime') { - $out .= &tab . '(int(-A _) ' . &n(shift); - } - elsif ($_ eq 'mtime') { - $out .= &tab . '(int(-M _) ' . &n(shift); - } - elsif ($_ eq 'ctime') { - $out .= &tab . '(int(-C _) ' . &n(shift); - } - elsif ($_ eq 'exec') { - for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { } - shift; - $_ = "@cmd"; - if (m#^(/bin/)?rm -f {}$#) { - if (!@ARGV) { - $out .= &tab . 'unlink($_)'; - } - else { - $out .= &tab . '(unlink($_) || 1)'; - } - } - elsif (m#^(/bin/)?rm {}$#) { - $out .= &tab . '(unlink($_) || warn "$name: $!\n")'; - } - else { - for (@cmd) { s/'/\\'/g; } - $" = "','"; - $out .= &tab . "&exec(0, '@cmd')"; - $" = ' '; - $initexec++; - } - } - elsif ($_ eq 'ok') { - for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { } - shift; - for (@cmd) { s/'/\\'/g; } - $" = "','"; - $out .= &tab . "&exec(1, '@cmd')"; - $" = ' '; - $initexec++; - } - elsif ($_ eq 'prune') { - $out .= &tab . '($prune = 1)'; - } - elsif ($_ eq 'xdev') { - $out .= &tab . '!($prune |= ($dev != $topdev))'; - } - elsif ($_ eq 'newer') { - $out .= &tab; - $file = shift; - $newername = 'AGE_OF' . $file; - $newername =~ s/[^\w]/_/g; - $newername = "\$$newername"; - $out .= "(-M _ < $newername)"; - $initnewer .= "$newername = -M " . "e($file) . ";\n"; - } - elsif ($_ eq 'eval') { - $prog = "e(shift); - $out .= &tab . "eval $prog"; - } - elsif ($_ eq 'depth') { - $depth++; - next; - } - elsif ($_ eq 'ls') { - $out .= &tab . "&ls"; - $initls++; - } - elsif ($_ eq 'tar') { - $out .= &tab; - die "-tar must have a filename argument\n" unless @ARGV; - $file = shift; - $fh = 'FH' . $file; - $fh =~ s/[^\w]/_/g; - $out .= "&tar($fh)"; - $file = '>' . $file; - $initfile .= "open($fh, " . "e($file) . - qq{) || die "Can't open $fh: \$!\\n";\n}; - $inittar++; - $flushall = "\n&tflushall;\n"; - } - elsif (/^n?cpio$/) { - $depth++; - $out .= &tab; - die "-$_ must have a filename argument\n" unless @ARGV; - $file = shift; - $fh = 'FH' . $file; - $fh =~ s/[^\w]/_/g; - $out .= "&cpio('" . substr($_,0,1) . "', $fh)"; - $file = '>' . $file; - $initfile .= "open($fh, " . "e($file) . - qq{) || die "Can't open $fh: \$!\\n";\n}; - $initcpio++; - $flushall = "\n&flushall;\n"; - } - else { - die "Unrecognized switch: -$_\n"; + $out .= &tab . "(\n"; + $indent_depth++; + next; + } elsif ($_ eq ')') { + --$indent_depth; + $out .= &tab . ")"; + } elsif ($_ eq 'follow') { + $stat = 'stat'; + $decl = "\nmy %already_seen = ();\n"; + $out .= &tab . '(not $already_seen{"$dev,$ino"}) &&' . "\n"; + $out .= &tab . '(($already_seen{"$dev,$ino"} = !(-d _)) || 1)'; + } elsif ($_ eq '!') { + $out .= &tab . "!"; + next; + } elsif ($_ eq 'name') { + $out .= &tab . '/' . &fileglob_to_re(shift) . "/"; + } elsif ($_ eq 'perm') { + my $onum = shift; + $onum =~ /^-?[0-7]+$/ + || die "Malformed -perm argument: $onum\n"; + $out .= &tab; + if ($onum =~ s/^-//) { + $onum = sprintf("0%o", oct($onum) & 07777); + $out .= "((\$mode & $onum) == $onum)"; + } else { + $onum =~ s/^0*/0/; + $out .= "((\$mode & 0777) == $onum)"; + } + } elsif ($_ eq 'type') { + (my $filetest = shift) =~ tr/s/S/; + $out .= &tab . "-$filetest _"; + } elsif ($_ eq 'print') { + $out .= &tab . 'print("$name\n")'; + } elsif ($_ eq 'print0') { + $out .= &tab . 'print("$name\0")'; + } elsif ($_ eq 'fstype') { + my $type = shift; + $out .= &tab; + if ($type eq 'nfs') { + $out .= '($dev < 0)'; + } else { + $out .= '($dev >= 0)'; #XXX + } + } elsif ($_ eq 'user') { + my $uname = shift; + $out .= &tab . "(\$uid == \$uid{'$uname'})"; + $init{user} = 1; + } elsif ($_ eq 'group') { + my $gname = shift; + $out .= &tab . "(\$gid == \$gid{'$gname'})"; + $init{group} = 1; + } elsif ($_ eq 'nouser') { + $out .= &tab . '!exists $uid{$uid}'; + $init{user} = 1; + } elsif ($_ eq 'nogroup') { + $out .= &tab . '!exists $gid{$gid}'; + $init{group} = 1; + } elsif ($_ eq 'links') { + $out .= &tab . &n('$nlink', shift); + } elsif ($_ eq 'inum') { + $out .= &tab . &n('$ino', shift); + } elsif ($_ eq 'size') { + $_ = shift; + my $n = 'int(((-s _) + 511) / 512)'; + if (s/c$//) { + $n = 'int(-s _)'; + } elsif (s/k$//) { + $n = 'int(((-s _) + 1023) / 1024)'; + } + $out .= &tab . &n($n, $_); + } elsif ($_ eq 'atime') { + $out .= &tab . &n('int(-A _)', shift); + } elsif ($_ eq 'mtime') { + $out .= &tab . &n('int(-M _)', shift); + } elsif ($_ eq 'ctime') { + $out .= &tab . &n('int(-C _)', shift); + } elsif ($_ eq 'exec') { + my @cmd = (); + while (@ARGV && $ARGV[0] ne ';') + { push(@cmd, shift) } + shift; + $out .= &tab; + if ($cmd[0] =~m#^(?:(?:/usr)?/bin/)?rm$# + && $cmd[$#cmd] eq '{}' + && (@cmd == 2 || (@cmd == 3 && $cmd[1] eq '-f'))) { + if (@cmd == 2) { + $out .= '(unlink($_) || warn "$name: $!\n")'; + } elsif (!@ARGV) { + $out .= 'unlink($_)'; + } else { + $out .= '(unlink($_) || 1)'; + } + } else { + for (@cmd) + { s/'/\\'/g } + { local $" = "','"; $out .= "&doexec(0, '@cmd')"; } + $init{doexec} = 1; + } + } elsif ($_ eq 'ok') { + my @cmd = (); + while (@ARGV && $ARGV[0] ne ';') + { push(@cmd, shift) } + shift; + $out .= &tab; + for (@cmd) + { s/'/\\'/g } + { local $" = "','"; $out .= "&doexec(0, '@cmd')"; } + $init{doexec} = 1; + } elsif ($_ eq 'prune') { + $out .= &tab . '($File::Find::prune = 1)'; + } elsif ($_ eq 'xdev') { + $out .= &tab . '!($File::Find::prune |= ($dev != $File::Find::topdev))' +; + } elsif ($_ eq 'newer') { + my $file = shift; + my $newername = 'AGE_OF' . $file; + $newername =~ s/\W/_/g; + $newername = '$' . $newername; + $out .= &tab . "(-M _ < $newername)"; + $initnewer .= "my $newername = -M " . "e($file) . ";\n"; + } elsif ($_ eq 'eval') { + my $prog = shift; + $prog =~ s/'/\\'/g; + $out .= &tab . "eval {$prog}"; + } elsif ($_ eq 'depth') { + $find = 'finddepth'; + next; + } elsif ($_ eq 'ls') { + $out .= &tab . "&ls"; + $init{ls} = 1; + } elsif ($_ eq 'tar') { + die "-tar must have a filename argument\n" unless @ARGV; + my $file = shift; + my $fh = 'FH' . $file; + $fh =~ s/\W/_/g; + $out .= &tab . "&tar(*$fh, \$name)"; + $flushall .= "&tflushall;\n"; + $initfile .= "open($fh, " . "e('> ' . $file) . + qq{) || die "Can't open $fh: \$!\\n";\n}; + $init{tar} = 1; + } elsif (/^(n?)cpio$/) { + die "-$_ must have a filename argument\n" unless @ARGV; + my $file = shift; + my $fh = 'FH' . $file; + $fh =~ s/\W/_/g; + $out .= &tab . "&cpio(*$fh, \$name, '$1')"; + $find = 'finddepth'; + $flushall .= "&cflushall;\n"; + $initfile .= "open($fh, " . "e('> ' . $file) . + qq{) || die "Can't open $fh: \$!\\n";\n}; + $init{cpio} = 1; + } else { + die "Unrecognized switch: -$_\n"; } + if (@ARGV) { - if ($ARGV[0] eq '-o') { - { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; } - $statdone = 0 if $indent == 1 && $delayedstat; - $saw_or++; - shift; - } - else { - $out .= " &&" unless $ARGV[0] eq ')'; - $out .= "\n"; - shift if $ARGV[0] eq '-a'; - } + if ($ARGV[0] eq '-o') { + { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; } + $statdone = 0 if $indent_depth == 1 && exists $init{delayedstat}; + $init{saw_or} = 1; + shift; + } else { + $out .= " &&" unless $ARGV[0] eq ')'; + $out .= "\n"; + shift if $ARGV[0] eq '-a'; + } } } + print <<"END"; $startperl eval 'exec $perlpath -S \$0 \${1+"\$@"}' - if \$running_under_some_shell; + if 0; #\$running_under_some_shell + +use strict; +use File::Find (); + +# Set the variable \$File::Find::dont_use_nlink if you're using AFS, +# since AFS cheats. + +# for the convenience of &wanted calls, including -eval statements: +use vars qw/*name *dir *prune/; +*name = *File::Find::name; +*dir = *File::Find::dir; +*prune = *File::Find::prune; END -if ($initls) { + +if (exists $init{ls}) { print <<'END'; -@rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx'); -@moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec); +my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx); +my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); END } -if ($inituser || $initls) { - print 'while (($name, $pw, $uid) = getpwent) {', "\n"; - print ' $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser; - print ' $user{$uid} = $name unless $user{$uid};', "\n" if $initls; +if (exists $init{user} || exists $init{ls} || exists $init{tar}) { + print "my (%uid, %user);\n"; + print "while (my (\$name, \$pw, \$uid) = getpwent) {\n"; + print ' $uid{$name} = $uid{$uid} = $uid;', "\n" + if exists $init{user}; + print ' $user{$uid} = $name unless exists $user{$uid};', "\n" + if exists $init{ls} || exists $init{tar}; print "}\n\n"; } -if ($initgroup || $initls) { - print 'while (($name, $pw, $gid) = getgrent) {', "\n"; - print ' $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup; - print ' $group{$gid} = $name unless $group{$gid};', "\n" if $initls; +if (exists $init{group} || exists $init{ls} || exists $init{tar}) { + print "my (%gid, %group);\n"; + print "while (my (\$name, \$pw, \$gid) = getgrent) {\n"; + print ' $gid{$name} = $gid{$gid} = $gid;', "\n" + if exists $init{group}; + print ' $group{$gid} = $name unless exists $group{$gid};', "\n" + if exists $init{ls} || exists $init{tar}; print "}\n\n"; } -print $initnewer, "\n" if $initnewer; +print $initnewer, "\n" if $initnewer ne ''; +print $initfile, "\n" if $initfile ne ''; +$flushall .= "exit;\n"; +if (exists $init{declarestat}) { + $out = <<'END' . $out; + my ($dev,$ino,$mode,$nlink,$uid,$gid); -print $initfile, "\n" if $initfile; +END +} -$find = $depth ? "finddepth" : "find"; print <<"END"; -require "$find.pl"; - -# Traverse desired filesystems - $decl -&$find($roots); +# Traverse desired filesystems +File::Find::$find(\\&wanted, $roots); $flushall -exit; + sub wanted { $out; } END -if ($initexec) { + +if (exists $init{doexec}) { print <<'END'; -sub exec { - local($ok, @cmd) = @_; - foreach $word (@cmd) { - $word =~ s#{}#$name#g; - } + +BEGIN { + require Cwd; + my $cwd = Cwd::cwd(); +} + +sub doexec { + my $ok = shift; + for my $word (@_) + { $word =~ s#{}#$name#g } if ($ok) { - local($old) = select(STDOUT); - $| = 1; - print "@cmd"; - select($old); - return 0 unless =~ /^y/; - } - chdir $cwd; # sigh - system @cmd; - chdir $dir; + my $old = select(STDOUT); + $| = 1; + print "@_"; + select($old); + return 0 unless =~ /^y/; + } + chdir $cwd; #sigh + system @_; + chdir $File::Find::dir; return !$?; } END } -if ($initls) { - print <<"INTERP", <<'END'; -sub ls { - (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$sizemm, - \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\); -INTERP - - $pname = $name; +if (exists $init{ls}) { + print <<'INTRO', <<"SUB", <<'END'; - if (defined $blocks) { - $blocks = int(($blocks + 1) / 2); - } - else { - $blocks = int(($size + 1023) / 1024); - } +sub sizemm { + my $rdev = shift; + sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff); +} - if (-f _) { $perms = '-'; } - elsif (-d _) { $perms = 'd'; } - elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; } - elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; } - elsif (-p _) { $perms = 'p'; } - elsif (-S _) { $perms = 's'; } - else { $perms = 'l'; $pname .= ' -> ' . readlink($_); } - - $tmpmode = $mode; - $tmp = $rwx[$tmpmode & 7]; - $tmpmode >>= 3; - $tmp = $rwx[$tmpmode & 7] . $tmp; - $tmpmode >>= 3; - $tmp = $rwx[$tmpmode & 7] . $tmp; - substr($tmp,2,1) =~ tr/-x/Ss/ if -u _; - substr($tmp,5,1) =~ tr/-x/Ss/ if -g _; - substr($tmp,8,1) =~ tr/-x/Tt/ if -k _; - $perms .= $tmp; - - $user = $user{$uid} || $uid; - $group = $group{$gid} || $gid; - - ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime); - $moname = $moname[$mon]; +sub ls { + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, +INTRO + \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_); +SUB + my $pname = $name; + + $blocks + or $blocks = int(($size + 1023) / 1024); + + my $perms = $rwx[$mode & 7]; + $mode >>= 3; + $perms = $rwx[$mode & 7] . $perms; + $mode >>= 3; + $perms = $rwx[$mode & 7] . $perms; + substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _; + substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _; + substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _; + if (-f _) { $perms = '-' . $perms; } + elsif (-d _) { $perms = 'd' . $perms; } + elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); } + elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); } + elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); } + elsif (-p _) { $perms = 'p' . $perms; } + elsif (-S _) { $perms = 's' . $perms; } + else { $perms = '?' . $perms; } + + my $user = $user{$uid} || $uid; + my $group = $group{$gid} || $gid; + + my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime); if (-M _ > 365.25 / 2) { - $timeyear = $year + 1900; - } - else { - $timeyear = sprintf("%02d:%02d", $hour, $min); - } - - printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n", - $ino, - $blocks, - $perms, - $nlink, - $user, - $group, - $sizemm, - $moname, - $mday, - $timeyear, - $pname; + $timeyear += 1900; + } else { + $timeyear = sprintf("%02d:%02d", $hour, $min); + } + + printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n", + $ino, + $blocks, + $perms, + $nlink, + $user, + $group, + $size, + $moname[$mon], + $mday, + $timeyear, + $pname; 1; } -sub sizemm { - sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255); +END +} + + +if (exists $init{cpio} || exists $init{tar}) { +print <<'END'; + +my %blocks = (); + +sub flush { + my ($fh, $varref, $blksz) = @_; + + while (length($$varref) >= $blksz) { + no strict qw/refs/; + syswrite($fh, $$varref, $blksz); + substr($$varref, 0, $blksz) = ''; + ++$blocks{$fh}; + } } END } -if ($initcpio) { -print <<'START', <<"INTERP", <<'END'; -sub cpio { - local($nc,$fh) = @_; - local($text); - if ($name eq 'TRAILER!!!') { - $text = ''; - $size = 0; - } - else { -START - (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$size, - \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\); -INTERP - if (-f _) { - open(IN, "./$_\0") || do { - warn "Couldn't open $name: $!\n"; - return; - }; - } - else { - $text = readlink($_); - $size = 0 unless defined $text; - } - } +if (exists $init{cpio}) { + print <<'INTRO', <<"SUB", <<'END'; + +my %cpout = (); +my %nc = (); - ($nm = $name) =~ s#^\./##; +sub cpio { + my ($fh, $fname, $nc) = @_; + my $text = ''; + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks); + local (*IN); + + if ( ! defined $fname ) { + $fname = 'TRAILER!!!'; + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13; + } else { + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, +INTRO + \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_); +SUB + if (-f _) { + open(IN, "./$_\0") || do { + warn "Couldn't open $fname: $!\n"; + return; + } + } else { + $text = readlink($_); + $size = 0 unless defined $text; + } + } + + $fname =~ s#^\./##; $nc{$fh} = $nc; if ($nc eq 'n') { - $cpout{$fh} .= - sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0", - 070707, - $dev & 0777777, - $ino & 0777777, - $mode & 0777777, - $uid & 0777777, - $gid & 0777777, - $nlink & 0777777, - $rdev & 0177777, - $mtime, - length($nm)+1, - $size, - $nm); - } - else { - $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1; - $cpout{$fh} .= pack("SSSSSSSSLSLa*", - 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime, - length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0")); - } - if ($text ne '') { - $cpout{$fh} .= $text; - } - elsif ($size) { - &flush($fh) while ($l = length($cpout{$fh})) >= 5120; - while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) { - &flush($fh); - $l = length($cpout{$fh}); - } + $cpout{$fh} .= + sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0", + 070707, + $dev & 0777777, + $ino & 0777777, + $mode & 0777777, + $uid & 0777777, + $gid & 0777777, + $nlink & 0777777, + $rdev & 0177777, + $mtime, + length($fname)+1, + $size, + $fname); + } else { + $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1; + $cpout{$fh} .= pack("SSSSSSSSLSLa*", + 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime, + length($fname)+1, $size, + $fname . (length($fname) & 1 ? "\0" : "\0\0")); } - close IN; -} - -sub flush { - local($fh) = @_; - while (length($cpout{$fh}) >= 5120) { - syswrite($fh,$cpout{$fh},5120); - ++$blocks{$fh}; - substr($cpout{$fh}, 0, 5120) = ''; + if ($text ne '') { + $cpout{$fh} .= $text; + } elsif ($size) { + my $l; + flush($fh, \$cpout{$fh}, 5120) + while ($l = length($cpout{$fh})) >= 5120; + while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) { + flush($fh, \$cpout{$fh}, 5120); + $l = length($cpout{$fh}); + } + close IN; } } -sub flushall { - $name = 'TRAILER!!!'; - foreach $fh (keys %cpout) { - &cpio($nc{$fh},$fh); - $cpout{$fh} .= "0" x (5120 - length($cpout{$fh})); - &flush($fh); - print $blocks{$fh} * 10, " blocks\n"; +sub cflushall { + for my $fh (keys %cpout) { + &cpio($fh, undef, $nc{$fh}); + $cpout{$fh} .= "0" x (5120 - length($cpout{$fh})); + flush($fh, \$cpout{$fh}, 5120); + print $blocks{$fh} * 10, " blocks\n"; } } END } -if ($inittar) { -print <<'START', <<"INTERP", <<'END'; +if (exists $init{tar}) { + print <<'INTRO', <<"SUB", <<'END'; + +my %tarout = (); +my %linkseen = (); + sub tar { - local($fh) = @_; - local($linkname,$header,$l,$slop); - local($linkflag) = "\0"; - -START - (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$size, - \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\); -INTERP - $nm = $name; - if ($nlink > 1) { - if ($linkname = $linkseen{$fh,$dev,$ino}) { - $linkflag = 1; - } - else { - $linkseen{$fh,$dev,$ino} = $nm; - } - } - if (-f _) { - open(IN, "./$_\0") || do { - warn "Couldn't open $name: $!\n"; - return; - }; - $size = 0 if $linkflag ne "\0"; - } - else { - $linkname = readlink($_); - $linkflag = 2 if defined $linkname; - $nm .= '/' if -d _; - $size = 0; - } + my ($fh, $fname) = @_; + my $prefix = ''; + my $typeflag = '0'; + my $linkname; + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, +INTRO + \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_); +SUB + local (*IN); - $header = pack("a100a8a8a8a12a12a8a1a100", - $nm, - sprintf("%6o ", $mode & 0777), - sprintf("%6o ", $uid & 0777777), - sprintf("%6o ", $gid & 0777777), - sprintf("%11o ", $size), - sprintf("%11o ", $mtime), - " ", - $linkflag, - $linkname); - $l = length($header) % 512; - substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header)); - substr($header, 154, 1) = "\0"; # blech + if ($nlink > 1) { + if ($linkname = $linkseen{$fh, $dev, $ino}) { + if (length($linkname) > 100) { + warn "$0: omitting file with linkname ", + "too long for tar output: $linkname\n"; + return; + } + $typeflag = '1'; + $size = 0; + } else { + $linkseen{$fh, $dev, $ino} = $fname; + } + } + if ($typeflag eq '0') { + if (-f _) { + open(IN, "./$_\0") || do { + warn "Couldn't open $fname: $!\n"; + return; + } + } else { + $linkname = readlink($_); + if (defined $linkname) { $typeflag = '2' } + elsif (-c _) { $typeflag = '3' } + elsif (-b _) { $typeflag = '4' } + elsif (-d _) { $typeflag = '5' } + elsif (-p _) { $typeflag = '6' } + } + } + + if (length($fname) > 100) { + ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#); + if (!defined($fname) || length($prefix) > 155) { + warn "$0: omitting file with name too long for tar output: ", + $fname, "\n"; + return; + } + } + + $size = 0 if $typeflag ne '0'; + my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155", + $fname, + sprintf("%7o ", $mode & 0777), + sprintf("%7o ", $uid & 0777777), + sprintf("%7o ", $gid & 0777777), + sprintf("%11o ", $size), + sprintf("%11o ", $mtime), + ' 'x8, + $typeflag, + defined $linkname ? $linkname : '', + "ustar\0", + "00", + $user{$uid}, + $group{$gid}, + ($rdev >> 8) & 0xff, + $rdev & 0xff, + $prefix, + ); + substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header)); + my $l = length($header) % 512; $tarout{$fh} .= $header; $tarout{$fh} .= "\0" x (512 - $l) if $l; - if ($size) { - &tflush($fh) while ($l = length($tarout{$fh})) >= 10240; - while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) { - $slop = length($tarout{$fh}) % 512; - $tarout{$fh} .= "\0" x (512 - $slop) if $slop; - &tflush($fh); - $l = length($tarout{$fh}); - } - } - close IN; -} -sub tflush { - local($fh) = @_; - - while (length($tarout{$fh}) >= 10240) { - syswrite($fh,$tarout{$fh},10240); - ++$blocks{$fh}; - substr($tarout{$fh}, 0, 10240) = ''; + if ($size) { + flush($fh, \$tarout{$fh}, 10240) + while ($l = length($tarout{$fh})) >= 10240; + while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) { + my $slop = length($tarout{$fh}) % 512; + $tarout{$fh} .= "\0" x (512 - $slop) if $slop; + flush($fh, \$tarout{$fh}, 10240); + $l = length($tarout{$fh}); + } + close IN; } } sub tflushall { - local($len); - - foreach $fh (keys %tarout) { - $len = 10240 - length($tarout{$fh}); - $len += 10240 if $len < 1024; - $tarout{$fh} .= "\0" x $len; - &tflush($fh); + my $len; + for my $fh (keys %tarout) { + $len = 10240 - length($tarout{$fh}); + $len += 10240 if $len < 1024; + $tarout{$fh} .= "\0" x $len; + flush($fh, \$tarout{$fh}, 10240); } } @@ -578,52 +620,248 @@ exit; ############################################################################ sub tab { - local($tabstring); + my $tabstring; - $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4); + $tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4); if (!$statdone) { - if ($_ =~ /^(name|print|prune|exec|ok|\(|\))/) { - $delayedstat++; - } - else { - if ($saw_or) { - $tabstring .= <<"ENDOFSTAT" . $tabstring; -(\$nlink || ((\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid) = $stat\(\$_\))) && -ENDOFSTAT - } - else { - $tabstring .= <<"ENDOFSTAT" . $tabstring; -((\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid) = $stat\(\$_\)) && -ENDOFSTAT - } - $statdone = 1; - } + if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) { + $init{delayedstat} = 1; + } else { + my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = ' + . $stat . '($_))'; + if (exists $init{saw_or}) { + $tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring; + } else { + $tabstring .= "$statcall &&\n" . $tabstring; + } + $statdone = 1; + $init{declarestat} = 1; + } } $tabstring =~ s/^\s+/ / if $out =~ /!$/; $tabstring; } sub fileglob_to_re { - local($tmp) = @_; - - $tmp =~ s#([./^\$()])#\\$1#g; - $tmp =~ s/([?*])/.$1/g; - "^$tmp\$"; + my $x = shift; + $x =~ s#([./^\$()])#\\$1#g; + $x =~ s#([?*])#.$1#g; + "^$x\$"; } sub n { - local($n) = @_; - + my ($pre, $n) = @_; $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /; $n =~ s/ 0*(\d)/ $1/; - $n . ')'; + "($pre $n)"; } sub quote { - local($string) = @_; - $string =~ s/'/\\'/; + my $string = shift; + $string =~ s/'/\\'/g; "'$string'"; } + +__END__ + +=head1 NAME + +find2perl - translate find command lines to Perl code + +=head1 SYNOPSIS + + find2perl [paths] [predicates] | perl + +=head1 DESCRIPTION + +find2perl is a little translator to convert find command lines to +equivalent Perl code. The resulting code is typically faster than +running find itself. + +"paths" are a set of paths where find2perl will start its searches and +"predicates" are taken from the following list. + +=over 4 + +=item C + +Negate the sense of the following predicate. The C must be passed as +a distinct argument, so it may need to be surrounded by whitespace and/or +quoted from interpretation by the shell using a backslash (just as with +using C). + +=item C<( PREDICATES )> + +Group the given PREDICATES. The parentheses must be passed as distinct +arguments, so they may need to be surrounded by whitespace and/or +quoted from interpretation by the shell using a backslash (just as with +using C). + +=item C + +True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not +evaluated if PREDICATE1 is false. + +=item C + +True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is +not evaluated if PREDICATE1 is true. + +=item C<-follow> + +Follow (dereference) symlinks. [XXX doesn't work fully, see L] + +=item C<-depth> + +Change directory traversal algorithm from breadth-first to depth-first. + +=item C<-prune> + +Do not descend into the directory currently matched. + +=item C<-xdev> + +Do not traverse mount points (prunes search at mount-point directories). + +=item C<-name GLOB> + +File name matches specified GLOB wildcard pattern. GLOB may need to be +quoted to avoid interpretation by the shell (just as with using +C). + +=item C<-perm PERM> + +Low-order 9 bits of permission match octal value PERM. + +=item C<-perm -PERM> + +The bits specified in PERM are all set in file's permissions. + +=item C<-type X> + +The file's type matches perl's C<-X> operator. + +=item C<-fstype TYPE> + +Filesystem of current path is of type TYPE (only NFS/non-NFS distinction +is implemented). + +=item C<-user USER> + +True if USER is owner of file. + +=item C<-group GROUP> + +True if file's group is GROUP. + +=item C<-nouser> + +True if file's owner is not in password database. + +=item C<-nogroup> + +True if file's group is not in group database. + +=item C<-inum INUM> + +True file's inode number is INUM. + +=item C<-links N> + +True if (hard) link count of file matches N (see below). + +=item C<-size N> + +True if file's size matches N (see below) N is normally counted in +512-byte blocks, but a suffix of "c" specifies that size should be +counted in characters (bytes) and a suffix of "k" specifes that +size should be counted in 1024-byte blocks. + +=item C<-atime N> + +True if last-access time of file matches N (measured in days) (see +below). + +=item C<-ctime N> + +True if last-changed time of file's inode matches N (measured in days, +see below). + +=item C<-mtime N> + +True if last-modified time of file matches N (measured in days, see below). + +=item C<-newer FILE> + +True if last-modified time of file matches N. + +=item C<-print> + +Print out path of file (always true). + +=item C<-print0> + +Like -print, but terminates with \0 instead of \n. + +=item C<-exec OPTIONS ;> + +exec() the arguments in OPTIONS in a subprocess; any occurence of {} in +OPTIONS will first be substituted with the path of the current +file. Note that the command "rm" has been special-cased to use perl's +unlink() function instead (as an optimization). The C<;> must be passed as +a distinct argument, so it may need to be surrounded by whitespace and/or +quoted from interpretation by the shell using a backslash (just as with +using C). + +=item C<-ok OPTIONS ;> + +Like -exec, but first prompts user; if user's response does not begin +with a y, skip the exec. The C<;> must be passed as +a distinct argument, so it may need to be surrounded by whitespace and/or +quoted from interpretation by the shell using a backslash (just as with +using C). + +=item C<-eval EXPR ;> + +Has the perl script eval() the EXPR. The C<;> must be passed as +a distinct argument, so it may need to be surrounded by whitespace and/or +quoted from interpretation by the shell using a backslash (just as with +using C). + +=item C<-ls> + +Simulates C<-exec ls -dils {} ;> + +=item C<-tar FILE> + +Adds current output to tar-format FILE. + +=item C<-cpio FILE> + +Adds current output to old-style cpio-format FILE. + +=item C<-ncpio FILE> + +Adds current output to "new"-style cpio-format FILE. + +=back + +Predicates which take a numeric argument N can come in three forms: + + * N is prefixed with a +: match values greater than N + * N is prefixed with a -: match values less than N + * N is not prefixed with either + or -: match only values equal to N + +=head1 BUGS + +The -follow option doesn't really work yet, because File::Find doesn't +support following symlinks. + +=head1 SEE ALSO + +find + +=cut !NO!SUBS! close OUT or die "Can't close $file: $!";