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