| 1 | #!/import/bw/tools/local/perl-5.8.0/bin/perl |
| 2 | eval 'exec /import/bw/tools/local/perl-5.8.0/bin/perl -S $0 ${1+"$@"}' |
| 3 | if $running_under_some_shell; |
| 4 | (my $perlpath = <<'/../') =~ s/\s*\z//; |
| 5 | /import/bw/tools/local/perl-5.8.0/bin/perl |
| 6 | /../ |
| 7 | use strict; |
| 8 | use vars qw/$statdone/; |
| 9 | use File::Spec::Functions 'curdir'; |
| 10 | my $startperl = "#! $perlpath -w"; |
| 11 | |
| 12 | # |
| 13 | # Modified September 26, 1993 to provide proper handling of years after 1999 |
| 14 | # Tom Link <tml+@pitt.edu> |
| 15 | # University of Pittsburgh |
| 16 | # |
| 17 | # Modified April 7, 1998 with nasty hacks to implement the troublesome -follow |
| 18 | # Billy Constantine <wdconsta@cs.adelaide.edu.au> <billy@smug.adelaide.edu.au> |
| 19 | # University of Adelaide, Adelaide, South Australia |
| 20 | # |
| 21 | # Modified 1999-06-10, 1999-07-07 to migrate to cleaner perl5 usage |
| 22 | # Ken Pizzini <ken@halcyon.com> |
| 23 | # |
| 24 | # Modified 2000-01-28 to use the 'follow' option of File::Find |
| 25 | |
| 26 | sub tab (); |
| 27 | sub n ($$); |
| 28 | sub fileglob_to_re ($); |
| 29 | sub quote ($); |
| 30 | |
| 31 | my @roots = (); |
| 32 | while ($ARGV[0] =~ /^[^-!(]/) { |
| 33 | push(@roots, shift); |
| 34 | } |
| 35 | @roots = (curdir()) unless @roots; |
| 36 | for (@roots) { $_ = quote($_) } |
| 37 | my $roots = join(', ', @roots); |
| 38 | |
| 39 | my $find = "find"; |
| 40 | my $indent_depth = 1; |
| 41 | my $stat = 'lstat'; |
| 42 | my $decl = ''; |
| 43 | my $flushall = ''; |
| 44 | my $initfile = ''; |
| 45 | my $initnewer = ''; |
| 46 | my $out = ''; |
| 47 | my $declaresubs = "sub wanted;\n"; |
| 48 | my %init = (); |
| 49 | my ($follow_in_effect,$Skip_And) = (0,0); |
| 50 | |
| 51 | while (@ARGV) { |
| 52 | $_ = shift; |
| 53 | s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n"; |
| 54 | if ($_ eq '(') { |
| 55 | $out .= tab . "(\n"; |
| 56 | $indent_depth++; |
| 57 | next; |
| 58 | } elsif ($_ eq ')') { |
| 59 | --$indent_depth; |
| 60 | $out .= tab . ")"; |
| 61 | } elsif ($_ eq 'follow') { |
| 62 | $follow_in_effect= 1; |
| 63 | $stat = 'stat'; |
| 64 | $Skip_And= 1; |
| 65 | } elsif ($_ eq '!') { |
| 66 | $out .= tab . "!"; |
| 67 | next; |
| 68 | } elsif ($_ eq 'name') { |
| 69 | $out .= tab . '/' . fileglob_to_re(shift) . "/s"; |
| 70 | } elsif ($_ eq 'perm') { |
| 71 | my $onum = shift; |
| 72 | $onum =~ /^-?[0-7]+$/ |
| 73 | || die "Malformed -perm argument: $onum\n"; |
| 74 | $out .= tab; |
| 75 | if ($onum =~ s/^-//) { |
| 76 | $onum = sprintf("0%o", oct($onum) & 07777); |
| 77 | $out .= "((\$mode & $onum) == $onum)"; |
| 78 | } else { |
| 79 | $onum =~ s/^0*/0/; |
| 80 | $out .= "((\$mode & 0777) == $onum)"; |
| 81 | } |
| 82 | } elsif ($_ eq 'type') { |
| 83 | (my $filetest = shift) =~ tr/s/S/; |
| 84 | $out .= tab . "-$filetest _"; |
| 85 | } elsif ($_ eq 'print') { |
| 86 | $out .= tab . 'print("$name\n")'; |
| 87 | } elsif ($_ eq 'print0') { |
| 88 | $out .= tab . 'print("$name\0")'; |
| 89 | } elsif ($_ eq 'fstype') { |
| 90 | my $type = shift; |
| 91 | $out .= tab; |
| 92 | if ($type eq 'nfs') { |
| 93 | $out .= '($dev < 0)'; |
| 94 | } else { |
| 95 | $out .= '($dev >= 0)'; #XXX |
| 96 | } |
| 97 | } elsif ($_ eq 'user') { |
| 98 | my $uname = shift; |
| 99 | $out .= tab . "(\$uid == \$uid{'$uname'})"; |
| 100 | $init{user} = 1; |
| 101 | } elsif ($_ eq 'group') { |
| 102 | my $gname = shift; |
| 103 | $out .= tab . "(\$gid == \$gid{'$gname'})"; |
| 104 | $init{group} = 1; |
| 105 | } elsif ($_ eq 'nouser') { |
| 106 | $out .= tab . '!exists $uid{$uid}'; |
| 107 | $init{user} = 1; |
| 108 | } elsif ($_ eq 'nogroup') { |
| 109 | $out .= tab . '!exists $gid{$gid}'; |
| 110 | $init{group} = 1; |
| 111 | } elsif ($_ eq 'links') { |
| 112 | $out .= tab . n('$nlink', shift); |
| 113 | } elsif ($_ eq 'inum') { |
| 114 | $out .= tab . n('$ino', shift); |
| 115 | } elsif ($_ eq 'size') { |
| 116 | $_ = shift; |
| 117 | my $n = 'int(((-s _) + 511) / 512)'; |
| 118 | if (s/c\z//) { |
| 119 | $n = 'int(-s _)'; |
| 120 | } elsif (s/k\z//) { |
| 121 | $n = 'int(((-s _) + 1023) / 1024)'; |
| 122 | } |
| 123 | $out .= tab . n($n, $_); |
| 124 | } elsif ($_ eq 'atime') { |
| 125 | $out .= tab . n('int(-A _)', shift); |
| 126 | } elsif ($_ eq 'mtime') { |
| 127 | $out .= tab . n('int(-M _)', shift); |
| 128 | } elsif ($_ eq 'ctime') { |
| 129 | $out .= tab . n('int(-C _)', shift); |
| 130 | } elsif ($_ eq 'exec') { |
| 131 | my @cmd = (); |
| 132 | while (@ARGV && $ARGV[0] ne ';') |
| 133 | { push(@cmd, shift) } |
| 134 | shift; |
| 135 | $out .= tab; |
| 136 | if ($cmd[0] =~m#^(?:(?:/usr)?/bin/)?rm$# |
| 137 | && $cmd[$#cmd] eq '{}' |
| 138 | && (@cmd == 2 || (@cmd == 3 && $cmd[1] eq '-f'))) { |
| 139 | if (@cmd == 2) { |
| 140 | $out .= '(unlink($_) || warn "$name: $!\n")'; |
| 141 | } elsif (!@ARGV) { |
| 142 | $out .= 'unlink($_)'; |
| 143 | } else { |
| 144 | $out .= '(unlink($_) || 1)'; |
| 145 | } |
| 146 | } else { |
| 147 | for (@cmd) |
| 148 | { s/'/\\'/g } |
| 149 | { local $" = "','"; $out .= "doexec(0, '@cmd')"; } |
| 150 | $declaresubs .= "sub doexec (\$\@);\n"; |
| 151 | $init{doexec} = 1; |
| 152 | } |
| 153 | } elsif ($_ eq 'ok') { |
| 154 | my @cmd = (); |
| 155 | while (@ARGV && $ARGV[0] ne ';') |
| 156 | { push(@cmd, shift) } |
| 157 | shift; |
| 158 | $out .= tab; |
| 159 | for (@cmd) |
| 160 | { s/'/\\'/g } |
| 161 | { local $" = "','"; $out .= "doexec(0, '@cmd')"; } |
| 162 | $declaresubs .= "sub doexec (\$\@);\n"; |
| 163 | $init{doexec} = 1; |
| 164 | } elsif ($_ eq 'prune') { |
| 165 | $out .= tab . '($File::Find::prune = 1)'; |
| 166 | } elsif ($_ eq 'xdev') { |
| 167 | $out .= tab . '!($File::Find::prune |= ($dev != $File::Find::topdev))' |
| 168 | ; |
| 169 | } elsif ($_ eq 'newer') { |
| 170 | my $file = shift; |
| 171 | my $newername = 'AGE_OF' . $file; |
| 172 | $newername =~ s/\W/_/g; |
| 173 | $newername = '$' . $newername; |
| 174 | $out .= tab . "(-M _ < $newername)"; |
| 175 | $initnewer .= "my $newername = -M " . quote($file) . ";\n"; |
| 176 | } elsif ($_ eq 'eval') { |
| 177 | my $prog = shift; |
| 178 | $prog =~ s/'/\\'/g; |
| 179 | $out .= tab . "eval {$prog}"; |
| 180 | } elsif ($_ eq 'depth') { |
| 181 | $find = 'finddepth'; |
| 182 | next; |
| 183 | } elsif ($_ eq 'ls') { |
| 184 | $out .= tab . "ls"; |
| 185 | $declaresubs .= "sub ls ();\n"; |
| 186 | $init{ls} = 1; |
| 187 | } elsif ($_ eq 'tar') { |
| 188 | die "-tar must have a filename argument\n" unless @ARGV; |
| 189 | my $file = shift; |
| 190 | my $fh = 'FH' . $file; |
| 191 | $fh =~ s/\W/_/g; |
| 192 | $out .= tab . "tar(*$fh, \$name)"; |
| 193 | $flushall .= "tflushall;\n"; |
| 194 | $declaresubs .= "sub tar;\nsub tflushall ();\n"; |
| 195 | $initfile .= "open($fh, " . quote('> ' . $file) . |
| 196 | qq{) || die "Can't open $fh: \$!\\n";\n}; |
| 197 | $init{tar} = 1; |
| 198 | } elsif (/^(n?)cpio\z/) { |
| 199 | die "-$_ must have a filename argument\n" unless @ARGV; |
| 200 | my $file = shift; |
| 201 | my $fh = 'FH' . $file; |
| 202 | $fh =~ s/\W/_/g; |
| 203 | $out .= tab . "cpio(*$fh, \$name, '$1')"; |
| 204 | $find = 'finddepth'; |
| 205 | $flushall .= "cflushall;\n"; |
| 206 | $declaresubs .= "sub cpio;\nsub cflushall ();\n"; |
| 207 | $initfile .= "open($fh, " . quote('> ' . $file) . |
| 208 | qq{) || die "Can't open $fh: \$!\\n";\n}; |
| 209 | $init{cpio} = 1; |
| 210 | } else { |
| 211 | die "Unrecognized switch: -$_\n"; |
| 212 | } |
| 213 | |
| 214 | if (@ARGV) { |
| 215 | if ($ARGV[0] eq '-o') { |
| 216 | { local($statdone) = 1; $out .= "\n" . tab . "||\n"; } |
| 217 | $statdone = 0 if $indent_depth == 1 && exists $init{delayedstat}; |
| 218 | $init{saw_or} = 1; |
| 219 | shift; |
| 220 | } else { |
| 221 | $out .= " &&" unless $Skip_And || $ARGV[0] eq ')'; |
| 222 | $out .= "\n"; |
| 223 | shift if $ARGV[0] eq '-a'; |
| 224 | } |
| 225 | } |
| 226 | } |
| 227 | |
| 228 | |
| 229 | print <<"END"; |
| 230 | $startperl |
| 231 | eval 'exec $perlpath -S \$0 \${1+"\$@"}' |
| 232 | if 0; #\$running_under_some_shell |
| 233 | |
| 234 | use strict; |
| 235 | use File::Find (); |
| 236 | |
| 237 | # Set the variable \$File::Find::dont_use_nlink if you're using AFS, |
| 238 | # since AFS cheats. |
| 239 | |
| 240 | # for the convenience of &wanted calls, including -eval statements: |
| 241 | use vars qw/*name *dir *prune/; |
| 242 | *name = *File::Find::name; |
| 243 | *dir = *File::Find::dir; |
| 244 | *prune = *File::Find::prune; |
| 245 | |
| 246 | $declaresubs |
| 247 | |
| 248 | END |
| 249 | |
| 250 | if (exists $init{ls}) { |
| 251 | print <<'END'; |
| 252 | my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx); |
| 253 | my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); |
| 254 | |
| 255 | END |
| 256 | } |
| 257 | |
| 258 | if (exists $init{user} || exists $init{ls} || exists $init{tar}) { |
| 259 | print "my (%uid, %user);\n"; |
| 260 | print "while (my (\$name, \$pw, \$uid) = getpwent) {\n"; |
| 261 | print ' $uid{$name} = $uid{$uid} = $uid;', "\n" |
| 262 | if exists $init{user}; |
| 263 | print ' $user{$uid} = $name unless exists $user{$uid};', "\n" |
| 264 | if exists $init{ls} || exists $init{tar}; |
| 265 | print "}\n\n"; |
| 266 | } |
| 267 | |
| 268 | if (exists $init{group} || exists $init{ls} || exists $init{tar}) { |
| 269 | print "my (%gid, %group);\n"; |
| 270 | print "while (my (\$name, \$pw, \$gid) = getgrent) {\n"; |
| 271 | print ' $gid{$name} = $gid{$gid} = $gid;', "\n" |
| 272 | if exists $init{group}; |
| 273 | print ' $group{$gid} = $name unless exists $group{$gid};', "\n" |
| 274 | if exists $init{ls} || exists $init{tar}; |
| 275 | print "}\n\n"; |
| 276 | } |
| 277 | |
| 278 | print $initnewer, "\n" if $initnewer ne ''; |
| 279 | print $initfile, "\n" if $initfile ne ''; |
| 280 | $flushall .= "exit;\n"; |
| 281 | if (exists $init{declarestat}) { |
| 282 | $out = <<'END' . $out; |
| 283 | my ($dev,$ino,$mode,$nlink,$uid,$gid); |
| 284 | |
| 285 | END |
| 286 | } |
| 287 | |
| 288 | if ( $follow_in_effect ) { |
| 289 | $out =~ s/lstat\(\$_\)/lstat(_)/; |
| 290 | print <<"END"; |
| 291 | $decl |
| 292 | # Traverse desired filesystems |
| 293 | File::Find::$find( {wanted => \\&wanted, follow => 1}, $roots); |
| 294 | $flushall |
| 295 | |
| 296 | sub wanted { |
| 297 | $out; |
| 298 | } |
| 299 | |
| 300 | END |
| 301 | } else { |
| 302 | print <<"END"; |
| 303 | $decl |
| 304 | # Traverse desired filesystems |
| 305 | File::Find::$find({wanted => \\&wanted}, $roots); |
| 306 | $flushall |
| 307 | |
| 308 | sub wanted { |
| 309 | $out; |
| 310 | } |
| 311 | |
| 312 | END |
| 313 | } |
| 314 | |
| 315 | if (exists $init{doexec}) { |
| 316 | print <<'END'; |
| 317 | |
| 318 | use Cwd (); |
| 319 | my $cwd = Cwd::cwd(); |
| 320 | |
| 321 | sub doexec ($@) { |
| 322 | my $ok = shift; |
| 323 | my @command = @_; # copy so we don't try to s/// aliases to constants |
| 324 | for my $word (@command) |
| 325 | { $word =~ s#{}#$name#g } |
| 326 | if ($ok) { |
| 327 | my $old = select(STDOUT); |
| 328 | $| = 1; |
| 329 | print "@command"; |
| 330 | select($old); |
| 331 | return 0 unless <STDIN> =~ /^y/; |
| 332 | } |
| 333 | chdir $cwd; #sigh |
| 334 | system @command; |
| 335 | chdir $File::Find::dir; |
| 336 | return !$?; |
| 337 | } |
| 338 | |
| 339 | END |
| 340 | } |
| 341 | |
| 342 | if (exists $init{ls}) { |
| 343 | print <<'INTRO', <<"SUB", <<'END'; |
| 344 | |
| 345 | sub sizemm { |
| 346 | my $rdev = shift; |
| 347 | sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff); |
| 348 | } |
| 349 | |
| 350 | sub ls () { |
| 351 | my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, |
| 352 | INTRO |
| 353 | \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_); |
| 354 | SUB |
| 355 | my $pname = $name; |
| 356 | |
| 357 | $blocks |
| 358 | or $blocks = int(($size + 1023) / 1024); |
| 359 | |
| 360 | my $perms = $rwx[$mode & 7]; |
| 361 | $mode >>= 3; |
| 362 | $perms = $rwx[$mode & 7] . $perms; |
| 363 | $mode >>= 3; |
| 364 | $perms = $rwx[$mode & 7] . $perms; |
| 365 | substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _; |
| 366 | substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _; |
| 367 | substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _; |
| 368 | if (-f _) { $perms = '-' . $perms; } |
| 369 | elsif (-d _) { $perms = 'd' . $perms; } |
| 370 | elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); } |
| 371 | elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); } |
| 372 | elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); } |
| 373 | elsif (-p _) { $perms = 'p' . $perms; } |
| 374 | elsif (-S _) { $perms = 's' . $perms; } |
| 375 | else { $perms = '?' . $perms; } |
| 376 | |
| 377 | my $user = $user{$uid} || $uid; |
| 378 | my $group = $group{$gid} || $gid; |
| 379 | |
| 380 | my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime); |
| 381 | if (-M _ > 365.25 / 2) { |
| 382 | $timeyear += 1900; |
| 383 | } else { |
| 384 | $timeyear = sprintf("%02d:%02d", $hour, $min); |
| 385 | } |
| 386 | |
| 387 | printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n", |
| 388 | $ino, |
| 389 | $blocks, |
| 390 | $perms, |
| 391 | $nlink, |
| 392 | $user, |
| 393 | $group, |
| 394 | $size, |
| 395 | $moname[$mon], |
| 396 | $mday, |
| 397 | $timeyear, |
| 398 | $pname; |
| 399 | 1; |
| 400 | } |
| 401 | |
| 402 | END |
| 403 | } |
| 404 | |
| 405 | |
| 406 | if (exists $init{cpio} || exists $init{tar}) { |
| 407 | print <<'END'; |
| 408 | |
| 409 | my %blocks = (); |
| 410 | |
| 411 | sub flush { |
| 412 | my ($fh, $varref, $blksz) = @_; |
| 413 | |
| 414 | while (length($$varref) >= $blksz) { |
| 415 | no strict qw/refs/; |
| 416 | syswrite($fh, $$varref, $blksz); |
| 417 | substr($$varref, 0, $blksz) = ''; |
| 418 | ++$blocks{$fh}; |
| 419 | } |
| 420 | } |
| 421 | |
| 422 | END |
| 423 | } |
| 424 | |
| 425 | |
| 426 | if (exists $init{cpio}) { |
| 427 | print <<'INTRO', <<"SUB", <<'END'; |
| 428 | |
| 429 | my %cpout = (); |
| 430 | my %nc = (); |
| 431 | |
| 432 | sub cpio { |
| 433 | my ($fh, $fname, $nc) = @_; |
| 434 | my $text = ''; |
| 435 | my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, |
| 436 | $atime,$mtime,$ctime,$blksize,$blocks); |
| 437 | local (*IN); |
| 438 | |
| 439 | if ( ! defined $fname ) { |
| 440 | $fname = 'TRAILER!!!'; |
| 441 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, |
| 442 | $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13; |
| 443 | } else { |
| 444 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, |
| 445 | INTRO |
| 446 | \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_); |
| 447 | SUB |
| 448 | if (-f _) { |
| 449 | open(IN, "./$_\0") || do { |
| 450 | warn "Couldn't open $fname: $!\n"; |
| 451 | return; |
| 452 | } |
| 453 | } else { |
| 454 | $text = readlink($_); |
| 455 | $size = 0 unless defined $text; |
| 456 | } |
| 457 | } |
| 458 | |
| 459 | $fname =~ s#^\./##; |
| 460 | $nc{$fh} = $nc; |
| 461 | if ($nc eq 'n') { |
| 462 | $cpout{$fh} .= |
| 463 | sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0", |
| 464 | 070707, |
| 465 | $dev & 0777777, |
| 466 | $ino & 0777777, |
| 467 | $mode & 0777777, |
| 468 | $uid & 0777777, |
| 469 | $gid & 0777777, |
| 470 | $nlink & 0777777, |
| 471 | $rdev & 0177777, |
| 472 | $mtime, |
| 473 | length($fname)+1, |
| 474 | $size, |
| 475 | $fname); |
| 476 | } else { |
| 477 | $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1; |
| 478 | $cpout{$fh} .= pack("SSSSSSSSLSLa*", |
| 479 | 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime, |
| 480 | length($fname)+1, $size, |
| 481 | $fname . (length($fname) & 1 ? "\0" : "\0\0")); |
| 482 | } |
| 483 | |
| 484 | if ($text ne '') { |
| 485 | $cpout{$fh} .= $text; |
| 486 | } elsif ($size) { |
| 487 | my $l; |
| 488 | flush($fh, \$cpout{$fh}, 5120) |
| 489 | while ($l = length($cpout{$fh})) >= 5120; |
| 490 | while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) { |
| 491 | flush($fh, \$cpout{$fh}, 5120); |
| 492 | $l = length($cpout{$fh}); |
| 493 | } |
| 494 | close IN; |
| 495 | } |
| 496 | } |
| 497 | |
| 498 | sub cflushall () { |
| 499 | for my $fh (keys %cpout) { |
| 500 | cpio($fh, undef, $nc{$fh}); |
| 501 | $cpout{$fh} .= "0" x (5120 - length($cpout{$fh})); |
| 502 | flush($fh, \$cpout{$fh}, 5120); |
| 503 | print $blocks{$fh} * 10, " blocks\n"; |
| 504 | } |
| 505 | } |
| 506 | |
| 507 | END |
| 508 | } |
| 509 | |
| 510 | if (exists $init{tar}) { |
| 511 | print <<'INTRO', <<"SUB", <<'END'; |
| 512 | |
| 513 | my %tarout = (); |
| 514 | my %linkseen = (); |
| 515 | |
| 516 | sub tar { |
| 517 | my ($fh, $fname) = @_; |
| 518 | my $prefix = ''; |
| 519 | my $typeflag = '0'; |
| 520 | my $linkname; |
| 521 | my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, |
| 522 | INTRO |
| 523 | \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_); |
| 524 | SUB |
| 525 | local (*IN); |
| 526 | |
| 527 | if ($nlink > 1) { |
| 528 | if ($linkname = $linkseen{$fh, $dev, $ino}) { |
| 529 | if (length($linkname) > 100) { |
| 530 | warn "$0: omitting file with linkname ", |
| 531 | "too long for tar output: $linkname\n"; |
| 532 | return; |
| 533 | } |
| 534 | $typeflag = '1'; |
| 535 | $size = 0; |
| 536 | } else { |
| 537 | $linkseen{$fh, $dev, $ino} = $fname; |
| 538 | } |
| 539 | } |
| 540 | if ($typeflag eq '0') { |
| 541 | if (-f _) { |
| 542 | open(IN, "./$_\0") || do { |
| 543 | warn "Couldn't open $fname: $!\n"; |
| 544 | return; |
| 545 | } |
| 546 | } else { |
| 547 | $linkname = readlink($_); |
| 548 | if (defined $linkname) { $typeflag = '2' } |
| 549 | elsif (-c _) { $typeflag = '3' } |
| 550 | elsif (-b _) { $typeflag = '4' } |
| 551 | elsif (-d _) { $typeflag = '5' } |
| 552 | elsif (-p _) { $typeflag = '6' } |
| 553 | } |
| 554 | } |
| 555 | |
| 556 | if (length($fname) > 100) { |
| 557 | ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#); |
| 558 | if (!defined($fname) || length($prefix) > 155) { |
| 559 | warn "$0: omitting file with name too long for tar output: ", |
| 560 | $fname, "\n"; |
| 561 | return; |
| 562 | } |
| 563 | } |
| 564 | |
| 565 | $size = 0 if $typeflag ne '0'; |
| 566 | my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155", |
| 567 | $fname, |
| 568 | sprintf("%7o ", $mode & 0777), |
| 569 | sprintf("%7o ", $uid & 0777777), |
| 570 | sprintf("%7o ", $gid & 0777777), |
| 571 | sprintf("%11o ", $size), |
| 572 | sprintf("%11o ", $mtime), |
| 573 | ' 'x8, |
| 574 | $typeflag, |
| 575 | defined $linkname ? $linkname : '', |
| 576 | "ustar\0", |
| 577 | "00", |
| 578 | $user{$uid}, |
| 579 | $group{$gid}, |
| 580 | ($rdev >> 8) & 0xff, |
| 581 | $rdev & 0xff, |
| 582 | $prefix, |
| 583 | ); |
| 584 | substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header)); |
| 585 | my $l = length($header) % 512; |
| 586 | $tarout{$fh} .= $header; |
| 587 | $tarout{$fh} .= "\0" x (512 - $l) if $l; |
| 588 | |
| 589 | if ($size) { |
| 590 | flush($fh, \$tarout{$fh}, 10240) |
| 591 | while ($l = length($tarout{$fh})) >= 10240; |
| 592 | while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) { |
| 593 | my $slop = length($tarout{$fh}) % 512; |
| 594 | $tarout{$fh} .= "\0" x (512 - $slop) if $slop; |
| 595 | flush($fh, \$tarout{$fh}, 10240); |
| 596 | $l = length($tarout{$fh}); |
| 597 | } |
| 598 | close IN; |
| 599 | } |
| 600 | } |
| 601 | |
| 602 | sub tflushall () { |
| 603 | my $len; |
| 604 | for my $fh (keys %tarout) { |
| 605 | $len = 10240 - length($tarout{$fh}); |
| 606 | $len += 10240 if $len < 1024; |
| 607 | $tarout{$fh} .= "\0" x $len; |
| 608 | flush($fh, \$tarout{$fh}, 10240); |
| 609 | } |
| 610 | } |
| 611 | |
| 612 | END |
| 613 | } |
| 614 | |
| 615 | exit; |
| 616 | |
| 617 | ############################################################################ |
| 618 | |
| 619 | sub tab () { |
| 620 | my $tabstring; |
| 621 | |
| 622 | $tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4); |
| 623 | if (!$statdone) { |
| 624 | if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) { |
| 625 | $init{delayedstat} = 1; |
| 626 | } else { |
| 627 | my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = ' |
| 628 | . $stat . '($_))'; |
| 629 | if (exists $init{saw_or}) { |
| 630 | $tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring; |
| 631 | } else { |
| 632 | $tabstring .= "$statcall &&\n" . $tabstring; |
| 633 | } |
| 634 | $statdone = 1; |
| 635 | $init{declarestat} = 1; |
| 636 | } |
| 637 | } |
| 638 | $tabstring =~ s/^\s+/ / if $out =~ /!$/; |
| 639 | $tabstring; |
| 640 | } |
| 641 | |
| 642 | sub fileglob_to_re ($) { |
| 643 | my $x = shift; |
| 644 | $x =~ s#([./^\$()+])#\\$1#g; |
| 645 | $x =~ s#([?*])#.$1#g; |
| 646 | "^$x\\z"; |
| 647 | } |
| 648 | |
| 649 | sub n ($$) { |
| 650 | my ($pre, $n) = @_; |
| 651 | $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /; |
| 652 | $n =~ s/ 0*(\d)/ $1/; |
| 653 | "($pre $n)"; |
| 654 | } |
| 655 | |
| 656 | sub quote ($) { |
| 657 | my $string = shift; |
| 658 | $string =~ s/\\/\\\\/g; |
| 659 | $string =~ s/'/\\'/g; |
| 660 | "'$string'"; |
| 661 | } |
| 662 | |
| 663 | __END__ |
| 664 | |
| 665 | =head1 NAME |
| 666 | |
| 667 | find2perl - translate find command lines to Perl code |
| 668 | |
| 669 | =head1 SYNOPSIS |
| 670 | |
| 671 | find2perl [paths] [predicates] | perl |
| 672 | |
| 673 | =head1 DESCRIPTION |
| 674 | |
| 675 | find2perl is a little translator to convert find command lines to |
| 676 | equivalent Perl code. The resulting code is typically faster than |
| 677 | running find itself. |
| 678 | |
| 679 | "paths" are a set of paths where find2perl will start its searches and |
| 680 | "predicates" are taken from the following list. |
| 681 | |
| 682 | =over 4 |
| 683 | |
| 684 | =item C<! PREDICATE> |
| 685 | |
| 686 | Negate the sense of the following predicate. The C<!> must be passed as |
| 687 | a distinct argument, so it may need to be surrounded by whitespace and/or |
| 688 | quoted from interpretation by the shell using a backslash (just as with |
| 689 | using C<find(1)>). |
| 690 | |
| 691 | =item C<( PREDICATES )> |
| 692 | |
| 693 | Group the given PREDICATES. The parentheses must be passed as distinct |
| 694 | arguments, so they may need to be surrounded by whitespace and/or |
| 695 | quoted from interpretation by the shell using a backslash (just as with |
| 696 | using C<find(1)>). |
| 697 | |
| 698 | =item C<PREDICATE1 PREDICATE2> |
| 699 | |
| 700 | True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not |
| 701 | evaluated if PREDICATE1 is false. |
| 702 | |
| 703 | =item C<PREDICATE1 -o PREDICATE2> |
| 704 | |
| 705 | True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is |
| 706 | not evaluated if PREDICATE1 is true. |
| 707 | |
| 708 | =item C<-follow> |
| 709 | |
| 710 | Follow (dereference) symlinks. The checking of file attributes depends |
| 711 | on the position of the C<-follow> option. If it precedes the file |
| 712 | check option, an C<stat> is done which means the file check applies to the |
| 713 | file the symbolic link is pointing to. If C<-follow> option follows the |
| 714 | file check option, this now applies to the symbolic link itself, i.e. |
| 715 | an C<lstat> is done. |
| 716 | |
| 717 | =item C<-depth> |
| 718 | |
| 719 | Change directory traversal algorithm from breadth-first to depth-first. |
| 720 | |
| 721 | =item C<-prune> |
| 722 | |
| 723 | Do not descend into the directory currently matched. |
| 724 | |
| 725 | =item C<-xdev> |
| 726 | |
| 727 | Do not traverse mount points (prunes search at mount-point directories). |
| 728 | |
| 729 | =item C<-name GLOB> |
| 730 | |
| 731 | File name matches specified GLOB wildcard pattern. GLOB may need to be |
| 732 | quoted to avoid interpretation by the shell (just as with using |
| 733 | C<find(1)>). |
| 734 | |
| 735 | =item C<-perm PERM> |
| 736 | |
| 737 | Low-order 9 bits of permission match octal value PERM. |
| 738 | |
| 739 | =item C<-perm -PERM> |
| 740 | |
| 741 | The bits specified in PERM are all set in file's permissions. |
| 742 | |
| 743 | =item C<-type X> |
| 744 | |
| 745 | The file's type matches perl's C<-X> operator. |
| 746 | |
| 747 | =item C<-fstype TYPE> |
| 748 | |
| 749 | Filesystem of current path is of type TYPE (only NFS/non-NFS distinction |
| 750 | is implemented). |
| 751 | |
| 752 | =item C<-user USER> |
| 753 | |
| 754 | True if USER is owner of file. |
| 755 | |
| 756 | =item C<-group GROUP> |
| 757 | |
| 758 | True if file's group is GROUP. |
| 759 | |
| 760 | =item C<-nouser> |
| 761 | |
| 762 | True if file's owner is not in password database. |
| 763 | |
| 764 | =item C<-nogroup> |
| 765 | |
| 766 | True if file's group is not in group database. |
| 767 | |
| 768 | =item C<-inum INUM> |
| 769 | |
| 770 | True file's inode number is INUM. |
| 771 | |
| 772 | =item C<-links N> |
| 773 | |
| 774 | True if (hard) link count of file matches N (see below). |
| 775 | |
| 776 | =item C<-size N> |
| 777 | |
| 778 | True if file's size matches N (see below) N is normally counted in |
| 779 | 512-byte blocks, but a suffix of "c" specifies that size should be |
| 780 | counted in characters (bytes) and a suffix of "k" specifes that |
| 781 | size should be counted in 1024-byte blocks. |
| 782 | |
| 783 | =item C<-atime N> |
| 784 | |
| 785 | True if last-access time of file matches N (measured in days) (see |
| 786 | below). |
| 787 | |
| 788 | =item C<-ctime N> |
| 789 | |
| 790 | True if last-changed time of file's inode matches N (measured in days, |
| 791 | see below). |
| 792 | |
| 793 | =item C<-mtime N> |
| 794 | |
| 795 | True if last-modified time of file matches N (measured in days, see below). |
| 796 | |
| 797 | =item C<-newer FILE> |
| 798 | |
| 799 | True if last-modified time of file matches N. |
| 800 | |
| 801 | =item C<-print> |
| 802 | |
| 803 | Print out path of file (always true). |
| 804 | |
| 805 | =item C<-print0> |
| 806 | |
| 807 | Like -print, but terminates with \0 instead of \n. |
| 808 | |
| 809 | =item C<-exec OPTIONS ;> |
| 810 | |
| 811 | exec() the arguments in OPTIONS in a subprocess; any occurrence of {} in |
| 812 | OPTIONS will first be substituted with the path of the current |
| 813 | file. Note that the command "rm" has been special-cased to use perl's |
| 814 | unlink() function instead (as an optimization). The C<;> must be passed as |
| 815 | a distinct argument, so it may need to be surrounded by whitespace and/or |
| 816 | quoted from interpretation by the shell using a backslash (just as with |
| 817 | using C<find(1)>). |
| 818 | |
| 819 | =item C<-ok OPTIONS ;> |
| 820 | |
| 821 | Like -exec, but first prompts user; if user's response does not begin |
| 822 | with a y, skip the exec. The C<;> must be passed as |
| 823 | a distinct argument, so it may need to be surrounded by whitespace and/or |
| 824 | quoted from interpretation by the shell using a backslash (just as with |
| 825 | using C<find(1)>). |
| 826 | |
| 827 | =item C<-eval EXPR> |
| 828 | |
| 829 | Has the perl script eval() the EXPR. |
| 830 | |
| 831 | =item C<-ls> |
| 832 | |
| 833 | Simulates C<-exec ls -dils {} ;> |
| 834 | |
| 835 | =item C<-tar FILE> |
| 836 | |
| 837 | Adds current output to tar-format FILE. |
| 838 | |
| 839 | =item C<-cpio FILE> |
| 840 | |
| 841 | Adds current output to old-style cpio-format FILE. |
| 842 | |
| 843 | =item C<-ncpio FILE> |
| 844 | |
| 845 | Adds current output to "new"-style cpio-format FILE. |
| 846 | |
| 847 | =back |
| 848 | |
| 849 | Predicates which take a numeric argument N can come in three forms: |
| 850 | |
| 851 | * N is prefixed with a +: match values greater than N |
| 852 | * N is prefixed with a -: match values less than N |
| 853 | * N is not prefixed with either + or -: match only values equal to N |
| 854 | |
| 855 | =head1 SEE ALSO |
| 856 | |
| 857 | find |
| 858 | |
| 859 | =cut |