X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=x2p%2Ffind2perl.PL;h=5add931397aa4741b1e0e3f3180523506c2a66f6;hb=756c5c2b691752248a1635194088c45476f496bb;hp=c23fc923a8f0894304178d20f59343428b6abe5d;hpb=774d564bb7dd1ed64ca0d7e534aa67e93f991f02;p=p5sagit%2Fp5-mst-13.2.git diff --git a/x2p/find2perl.PL b/x2p/find2perl.PL index c23fc92..5add931 100644 --- a/x2p/find2perl.PL +++ b/x2p/find2perl.PL @@ -2,6 +2,7 @@ use Config; use File::Basename qw(&basename &dirname); +use Cwd; # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you @@ -12,6 +13,7 @@ use File::Basename qw(&basename &dirname); # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. +$origdir = cwd; chdir dirname($0); $file = basename($0, '.PL'); $file .= '.com' if $^O eq 'VMS'; @@ -26,521 +28,637 @@ print "Extracting $file (with variable substitutions)\n"; print OUT <<"!GROK!THIS!"; $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' - if \$running_under_some_shell; -\$startperl = "$Config{startperl}"; -\$perlpath = "$Config{perlpath}"; + if \$running_under_some_shell; +(my \$perlpath = <<'/../') =~ s/\\s*\\z//; +$Config{perlpath} +/../ !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; -# +use strict; +use vars qw/$statdone/; +use File::Spec::Functions 'curdir'; +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 +# +# Modified 2000-01-28 to use the 'follow' option of File::Find + +sub tab (); +sub n ($$); +sub fileglob_to_re ($); +sub quote ($); + +my @roots = (); while ($ARGV[0] =~ /^[^-!(]/) { push(@roots, shift); } -@roots = ('.') unless @roots; -for (@roots) { $_ = "e($_); } -$roots = join(',', @roots); - -$indent = 1; +@roots = (curdir()) unless @roots; +for (@roots) { $_ = quote($_) } +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 $declaresubs = "sub wanted;\n"; +my %init = (); +my ($follow_in_effect,$Skip_And) = (0,0); +my $print_needed = 1; while (@ARGV) { $_ = shift; s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n"; if ($_ eq '(') { - $out .= &tab . "(\n"; - $indent++; - next; - } - elsif ($_ eq ')') { - $indent--; - $out .= &tab . ")"; - } - 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') { - $out .= &tab . '(int(((-s _) + 511) / 512) ' . &n(shift); - } - 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') { + $follow_in_effect= 1; + $stat = 'stat'; + $Skip_And= 1; + } elsif ($_ eq '!') { + $out .= tab . "!"; + next; + } elsif (/^(i)?name$/) { + $out .= tab . '/' . fileglob_to_re(shift) . "/s$1"; + } elsif (/^(i)?path$/) { + $out .= tab . '$File::Find::name =~ /' . fileglob_to_re(shift) . "/s$1"; + } 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")'; + $print_needed = 0; + } elsif ($_ eq 'print0') { + $out .= tab . 'print("$name\0")'; + $print_needed = 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\z//) { + $n = 'int(-s _)'; + } elsif (s/k\z//) { + $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')"; } + $declaresubs .= "sub doexec (\$\@);\n"; + $init{doexec} = 1; + } + $print_needed = 0; + } elsif ($_ eq 'ok') { + my @cmd = (); + while (@ARGV && $ARGV[0] ne ';') + { push(@cmd, shift) } + shift; + $out .= tab; + for (@cmd) + { s/'/\\'/g } + { local $" = "','"; $out .= "doexec(1, '@cmd')"; } + $declaresubs .= "sub doexec (\$\@);\n"; + $init{doexec} = 1; + $print_needed = 0; + } 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 " . quote($file) . ";\n"; + } elsif ($_ eq 'eval') { + my $prog = shift; + $prog =~ s/'/\\'/g; + $out .= tab . "eval {$prog}"; + $print_needed = 0; + } elsif ($_ eq 'depth') { + $find = 'finddepth'; + next; + } elsif ($_ eq 'ls') { + $out .= tab . "ls"; + $declaresubs .= "sub ls ();\n"; + $init{ls} = 1; + $print_needed = 0; + } 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"; + $declaresubs .= "sub tar;\nsub tflushall ();\n"; + $initfile .= "open($fh, " . quote('> ' . $file) . + qq{) || die "Can't open $fh: \$!\\n";\n}; + $init{tar} = 1; + } elsif (/^(n?)cpio\z/) { + 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"; + $declaresubs .= "sub cpio;\nsub cflushall ();\n"; + $initfile .= "open($fh, " . quote('> ' . $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 $Skip_And || $ARGV[0] eq ')'; + $out .= "\n"; + shift if $ARGV[0] eq '-a'; + } } } +if ($print_needed) { + my $t = tab; + if ($t !~ /&&\s*$/) { $t .= '&& ' } + $out .= "\n" . $t . 'print("$name\n")'; +} + + 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; + +$declaresubs + +END + +if (exists $init{doexec}) { + print <<'END'; +use Cwd (); +my $cwd = Cwd::cwd(); 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"; +if ( $follow_in_effect ) { +$out =~ s/lstat\(\$_\)/lstat(_)/; print <<"END"; -require "$find.pl"; - +$decl # Traverse desired filesystems +File::Find::$find( {wanted => \\&wanted, follow => 1}, $roots); +$flushall + +sub wanted { +$out; +} -&$find($roots); +END +} else { +print <<"END"; +$decl +# Traverse desired filesystems +File::Find::$find({wanted => \\&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; - } + +sub doexec ($@) { + my $ok = shift; + my @command = @_; # copy so we don't try to s/// aliases to constants + for my $word (@command) + { $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 "@command"; + select($old); + return 0 unless =~ /^y/; + } + chdir $cwd; #sigh + system @command; + chdir $File::Find::dir; return !$?; } END } -if ($initls) { - print <<'END'; -sub ls { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm, - $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); - - $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 ($initcpio) { + +if (exists $init{cpio} || exists $init{tar}) { print <<'END'; -sub cpio { - local($nc,$fh) = @_; - local($text); - if ($name eq 'TRAILER!!!') { - $text = ''; - $size = 0; - } - else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); - if (-f _) { - open(IN, "./$_\0") || do { - warn "Couldn't open $name: $!\n"; - return; - }; - } - else { - $text = readlink($_); - $size = 0 unless defined $text; - } +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 +} + - ($nm = $name) =~ s#^\./##; +if (exists $init{cpio}) { + print <<'INTRO', <<"SUB", <<'END'; + +my %cpout = (); +my %nc = (); + +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); + $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")); } - 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}); - } - } - 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 <<'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"; + 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); - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); - $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; - } - - $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 ($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); +sub tflushall () { + 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); } } @@ -551,55 +669,264 @@ exit; ############################################################################ -sub tab { - local($tabstring); +sub tab () { + 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) = lstat($_))) && -ENDOFSTAT - } - else { - $tabstring .= <<'ENDOFSTAT' . $tabstring; -(($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && -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\$"; +sub fileglob_to_re ($) { + my $x = shift; + $x =~ s#([./^\$()+])#\\$1#g; + $x =~ s#([?*])#.$1#g; + "^$x\\z"; } -sub n { - local($n) = @_; - +sub n ($$) { + my ($pre, $n) = @_; $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /; $n =~ s/ 0*(\d)/ $1/; - $n . ')'; + "($pre $n)"; } -sub quote { - local($string) = @_; - $string =~ s/'/\\'/; +sub quote ($) { + my $string = shift; + $string =~ s/\\/\\\\/g; + $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. The checking of file attributes depends +on the position of the C<-follow> option. If it precedes the file +check option, an C is done which means the file check applies to the +file the symbolic link is pointing to. If C<-follow> option follows the +file check option, this now applies to the symbolic link itself, i.e. +an C is done. + +=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<-iname GLOB> + +Like C<-name>, but the match is case insensitive. + +=item C<-path GLOB> + +Path name matches specified GLOB wildcard pattern. + +=item C<-ipath GLOB> + +Like C<-path>, but the match is case insensitive. + +=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" specifies 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). If none of C<-exec>, C<-ls>, +C<-print0>, or C<-ok> is specified, then C<-print> will be added +implicitly. + +=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 occurrence 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. + +=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 SEE ALSO + +find + +=cut !NO!SUBS! close OUT or die "Can't close $file: $!"; chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir;