home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / perl-5.003-base.tgz / perl-5.003-base.tar / fsf / perl / x2p / find2perl.PL < prev    next >
Perl Script  |  1996-03-25  |  13KB  |  607 lines
  1. #!/usr/local/bin/perl
  2.  
  3. use Config;
  4. use File::Basename qw(&basename &dirname);
  5.  
  6. # List explicitly here the variables you want Configure to
  7. # generate.  Metaconfig only looks for shell variables, so you
  8. # have to mention them as if they were shell variables, not
  9. # %Config entries.  Thus you write
  10. #  $startperl
  11. # to ensure Configure will look for $Config{startperl}.
  12.  
  13. # This forces PL files to create target in same directory as PL file.
  14. # This is so that make depend always knows where to find PL derivatives.
  15. chdir(dirname($0));
  16. ($file = basename($0)) =~ s/\.PL$//;
  17. $file =~ s/\.pl$//
  18.     if ($^O eq 'VMS' or $^O eq 'os2');  # "case-forgiving"
  19.  
  20. open OUT,">$file" or die "Can't create $file: $!";
  21.  
  22. print "Extracting $file (with variable substitutions)\n";
  23.  
  24. # In this section, perl variables will be expanded during extraction.
  25. # You can use $Config{...} to use Configure variables.
  26.  
  27. print OUT <<"!GROK!THIS!";
  28. $Config{'startperl'}
  29.     eval 'exec perl -S \$0 "\$@"'
  30.     if 0;
  31. \$startperl = "$Config{startperl}";
  32. !GROK!THIS!
  33.  
  34. # In the following, perl variables are not expanded during extraction.
  35.  
  36. print OUT <<'!NO!SUBS!';
  37. # 
  38. # Modified September 26, 1993 to provide proper handling of years after 1999
  39. #   Tom Link <tml+@pitt.edu>
  40. #   University of Pittsburgh
  41.  
  42. while ($ARGV[0] =~ /^[^-!(]/) {
  43.     push(@roots, shift);
  44. }
  45. @roots = ('.') unless @roots;
  46. for (@roots) { $_ = "e($_); }
  47. $roots = join(',', @roots);
  48.  
  49. $indent = 1;
  50.  
  51. while (@ARGV) {
  52.     $_ = shift;
  53.     s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
  54.     if ($_ eq '(') {
  55.     $out .= &tab . "(\n";
  56.     $indent++;
  57.     next;
  58.     }
  59.     elsif ($_ eq ')') {
  60.     $indent--;
  61.     $out .= &tab . ")";
  62.     }
  63.     elsif ($_ eq '!') {
  64.     $out .= &tab . "!";
  65.     next;
  66.     }
  67.     elsif ($_ eq 'name') {
  68.     $out .= &tab;
  69.     $pat = &fileglob_to_re(shift);
  70.     $out .= '/' . $pat . "/";
  71.     }
  72.     elsif ($_ eq 'perm') {
  73.     $onum = shift;
  74.     die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/;
  75.     if ($onum =~ s/^-//) {
  76.         $onum = '0' . sprintf("%o", oct($onum) & 017777);    # s/b 07777 ?
  77.         $out .= &tab . "((\$mode & $onum) == $onum)";
  78.     }
  79.     else {
  80.         $onum = '0' . $onum unless $onum =~ /^0/;
  81.         $out .= &tab . "((\$mode & 0777) == $onum)";
  82.     }
  83.     }
  84.     elsif ($_ eq 'type') {
  85.     ($filetest = shift) =~ tr/s/S/;
  86.     $out .= &tab . "-$filetest _";
  87.     }
  88.     elsif ($_ eq 'print') {
  89.     $out .= &tab . 'print("$name\n")';
  90.     }
  91.     elsif ($_ eq 'print0') {
  92.     $out .= &tab . 'print("$name\0")';
  93.     }
  94.     elsif ($_ eq 'fstype') {
  95.     $out .= &tab;
  96.     $type = shift;
  97.     if ($type eq 'nfs')
  98.         { $out .= '($dev < 0)'; }
  99.     else
  100.         { $out .= '($dev >= 0)'; }
  101.     }
  102.     elsif ($_ eq 'user') {
  103.     $uname = shift;
  104.     $out .= &tab . "(\$uid == \$uid{'$uname'})";
  105.     $inituser++;
  106.     }
  107.     elsif ($_ eq 'group') {
  108.     $gname = shift;
  109.     $out .= &tab . "(\$gid == \$gid{'$gname'})";
  110.     $initgroup++;
  111.     }
  112.     elsif ($_ eq 'nouser') {
  113.     $out .= &tab . '!defined $uid{$uid}';
  114.     $inituser++;
  115.     }
  116.     elsif ($_ eq 'nogroup') {
  117.     $out .= &tab . '!defined $gid{$gid}';
  118.     $initgroup++;
  119.     }
  120.     elsif ($_ eq 'links') {
  121.     $out .= &tab . '($nlink ' . &n(shift);
  122.     }
  123.     elsif ($_ eq 'inum') {
  124.     $out .= &tab . '($ino ' . &n(shift);
  125.     }
  126.     elsif ($_ eq 'size') {
  127.     $out .= &tab . '(int(((-s _) + 511) / 512) ' . &n(shift);
  128.     }
  129.     elsif ($_ eq 'atime') {
  130.     $out .= &tab . '(int(-A _) ' . &n(shift);
  131.     }
  132.     elsif ($_ eq 'mtime') {
  133.     $out .= &tab . '(int(-M _) ' . &n(shift);
  134.     }
  135.     elsif ($_ eq 'ctime') {
  136.     $out .= &tab . '(int(-C _) ' . &n(shift);
  137.     }
  138.     elsif ($_ eq 'exec') {
  139.     for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
  140.     shift;
  141.     $_ = "@cmd";
  142.     if (m#^(/bin/)?rm -f {}$#) {
  143.         if (!@ARGV) {
  144.         $out .= &tab . 'unlink($_)';
  145.         }
  146.         else {
  147.         $out .= &tab . '(unlink($_) || 1)';
  148.         }
  149.     }
  150.     elsif (m#^(/bin/)?rm {}$#) {
  151.         $out .= &tab . '(unlink($_) || warn "$name: $!\n")';
  152.     }
  153.     else {
  154.         for (@cmd) { s/'/\\'/g; }
  155.         $" = "','";
  156.         $out .= &tab . "&exec(0, '@cmd')";
  157.         $" = ' ';
  158.         $initexec++;
  159.     }
  160.     }
  161.     elsif ($_ eq 'ok') {
  162.     for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
  163.     shift;
  164.     for (@cmd) { s/'/\\'/g; }
  165.     $" = "','";
  166.     $out .= &tab . "&exec(1, '@cmd')";
  167.     $" = ' ';
  168.     $initexec++;
  169.     }
  170.     elsif ($_ eq 'prune') {
  171.     $out .= &tab . '($prune = 1)';
  172.     }
  173.     elsif ($_ eq 'xdev') {
  174.     $out .= &tab . '!($prune |= ($dev != $topdev))';
  175.     }
  176.     elsif ($_ eq 'newer') {
  177.     $out .= &tab;
  178.     $file = shift;
  179.     $newername = 'AGE_OF' . $file;
  180.     $newername =~ s/[^\w]/_/g;
  181.     $newername = '$' . $newername;
  182.     $out .= "(-M _ < $newername)";
  183.     $initnewer .= "$newername = -M " . "e($file) . ";\n";
  184.     }
  185.     elsif ($_ eq 'eval') {
  186.     $prog = "e(shift);
  187.     $out .= &tab . "eval $prog";
  188.     }
  189.     elsif ($_ eq 'depth') {
  190.     $depth++;
  191.     next;
  192.     }
  193.     elsif ($_ eq 'ls') {
  194.     $out .= &tab . "&ls";
  195.     $initls++;
  196.     }
  197.     elsif ($_ eq 'tar') {
  198.     $out .= &tab;
  199.     die "-tar must have a filename argument\n" unless @ARGV;
  200.     $file = shift;
  201.     $fh = 'FH' . $file;
  202.     $fh =~ s/[^\w]/_/g;
  203.     $out .= "&tar($fh)";
  204.     $file = '>' . $file;
  205.     $initfile .= "open($fh, " . "e($file) .
  206.       qq{) || die "Can't open $fh: \$!\\n";\n};
  207.     $inittar++;
  208.     $flushall = "\n&tflushall;\n";
  209.     }
  210.     elsif (/^n?cpio$/) {
  211.     $depth++;
  212.     $out .= &tab;
  213.     die "-$_ must have a filename argument\n" unless @ARGV;
  214.     $file = shift;
  215.     $fh = 'FH' . $file;
  216.     $fh =~ s/[^\w]/_/g;
  217.     $out .= "&cpio('" . substr($_,0,1) . "', $fh)";
  218.     $file = '>' . $file;
  219.     $initfile .= "open($fh, " . "e($file) .
  220.       qq{) || die "Can't open $fh: \$!\\n";\n};
  221.     $initcpio++;
  222.     $flushall = "\n&flushall;\n";
  223.     }
  224.     else {
  225.     die "Unrecognized switch: -$_\n";
  226.     }
  227.     if (@ARGV) {
  228.     if ($ARGV[0] eq '-o') {
  229.         { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; }
  230.         $statdone = 0 if $indent == 1 && $delayedstat;
  231.         $saw_or++;
  232.         shift;
  233.     }
  234.     else {
  235.         $out .= " &&" unless $ARGV[0] eq ')';
  236.         $out .= "\n";
  237.         shift if $ARGV[0] eq '-a';
  238.     }
  239.     }
  240. }
  241.  
  242. print <<"END";
  243. $startperl
  244.  
  245. eval 'exec perl -S \$0 \${1+"\$@"}'
  246.     if \$running_under_some_shell;
  247.  
  248. END
  249.  
  250. if ($initls) {
  251.     print <<'END';
  252. @rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
  253. @moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
  254.  
  255. END
  256. }
  257.  
  258. if ($inituser || $initls) {
  259.     print 'while (($name, $pw, $uid) = getpwent) {', "\n";
  260.     print '    $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser;
  261.     print '    $user{$uid} = $name unless $user{$uid};', "\n" if $initls;
  262.     print "}\n\n";
  263. }
  264.  
  265. if ($initgroup || $initls) {
  266.     print 'while (($name, $pw, $gid) = getgrent) {', "\n";
  267.     print '    $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup;
  268.     print '    $group{$gid} = $name unless $group{$gid};', "\n" if $initls;
  269.     print "}\n\n";
  270. }
  271.  
  272. print $initnewer, "\n" if $initnewer;
  273.  
  274. print $initfile, "\n" if $initfile;
  275.  
  276. $find = $depth ? "finddepth" : "find";
  277. print <<"END";
  278. require "$find.pl";
  279.  
  280. # Traverse desired filesystems
  281.  
  282. &$find($roots);
  283. $flushall
  284. exit;
  285.  
  286. sub wanted {
  287. $out;
  288. }
  289.  
  290. END
  291.  
  292. if ($initexec) {
  293.     print <<'END';
  294. sub exec {
  295.     local($ok, @cmd) = @_;
  296.     foreach $word (@cmd) {
  297.     $word =~ s#{}#$name#g;
  298.     }
  299.     if ($ok) {
  300.     local($old) = select(STDOUT);
  301.     $| = 1;
  302.     print "@cmd";
  303.     select($old);
  304.     return 0 unless <STDIN> =~ /^y/;
  305.     }
  306.     chdir $cwd;        # sigh
  307.     system @cmd;
  308.     chdir $dir;
  309.     return !$?;
  310. }
  311.  
  312. END
  313. }
  314.  
  315. if ($initls) {
  316.     print <<'END';
  317. sub ls {
  318.     ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
  319.       $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
  320.  
  321.     $pname = $name;
  322.  
  323.     if (defined $blocks) {
  324.     $blocks = int(($blocks + 1) / 2);
  325.     }
  326.     else {
  327.     $blocks = int(($size + 1023) / 1024);
  328.     }
  329.  
  330.     if    (-f _) { $perms = '-'; }
  331.     elsif (-d _) { $perms = 'd'; }
  332.     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
  333.     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
  334.     elsif (-p _) { $perms = 'p'; }
  335.     elsif (-S _) { $perms = 's'; }
  336.     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
  337.  
  338.     $tmpmode = $mode;
  339.     $tmp = $rwx[$tmpmode & 7];
  340.     $tmpmode >>= 3;
  341.     $tmp = $rwx[$tmpmode & 7] . $tmp;
  342.     $tmpmode >>= 3;
  343.     $tmp = $rwx[$tmpmode & 7] . $tmp;
  344.     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
  345.     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
  346.     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
  347.     $perms .= $tmp;
  348.  
  349.     $user = $user{$uid} || $uid;
  350.     $group = $group{$gid} || $gid;
  351.  
  352.     ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
  353.     $moname = $moname[$mon];
  354.     if (-M _ > 365.25 / 2) {
  355.     $timeyear = $year + 1900;
  356.     }
  357.     else {
  358.     $timeyear = sprintf("%02d:%02d", $hour, $min);
  359.     }
  360.  
  361.     printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
  362.         $ino,
  363.          $blocks,
  364.               $perms,
  365.                 $nlink,
  366.                 $user,
  367.                      $group,
  368.                       $sizemm,
  369.                           $moname,
  370.                          $mday,
  371.                              $timeyear,
  372.                              $pname;
  373.     1;
  374. }
  375.  
  376. sub sizemm {
  377.     sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255);
  378. }
  379.  
  380. END
  381. }
  382.  
  383. if ($initcpio) {
  384. print <<'END';
  385. sub cpio {
  386.     local($nc,$fh) = @_;
  387.     local($text);
  388.  
  389.     if ($name eq 'TRAILER!!!') {
  390.     $text = '';
  391.     $size = 0;
  392.     }
  393.     else {
  394.     ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  395.       $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
  396.     if (-f _) {
  397.         open(IN, "./$_\0") || do {
  398.         warn "Couldn't open $name: $!\n";
  399.         return;
  400.         };
  401.     }
  402.     else {
  403.         $text = readlink($_);
  404.         $size = 0 unless defined $text;
  405.     }
  406.     }
  407.  
  408.     ($nm = $name) =~ s#^\./##;
  409.     $nc{$fh} = $nc;
  410.     if ($nc eq 'n') {
  411.     $cpout{$fh} .=
  412.       sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
  413.         070707,
  414.         $dev & 0777777,
  415.         $ino & 0777777,
  416.         $mode & 0777777,
  417.         $uid & 0777777,
  418.         $gid & 0777777,
  419.         $nlink & 0777777,
  420.         $rdev & 0177777,
  421.         $mtime,
  422.         length($nm)+1,
  423.         $size,
  424.         $nm);
  425.     }
  426.     else {
  427.     $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
  428.     $cpout{$fh} .= pack("SSSSSSSSLSLa*",
  429.         070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
  430.         length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0"));
  431.     }
  432.     if ($text ne '') {
  433.     $cpout{$fh} .= $text;
  434.     }
  435.     elsif ($size) {
  436.     &flush($fh) while ($l = length($cpout{$fh})) >= 5120;
  437.     while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
  438.         &flush($fh);
  439.         $l = length($cpout{$fh});
  440.     }
  441.     }
  442.     close IN;
  443. }
  444.  
  445. sub flush {
  446.     local($fh) = @_;
  447.  
  448.     while (length($cpout{$fh}) >= 5120) {
  449.     syswrite($fh,$cpout{$fh},5120);
  450.     ++$blocks{$fh};
  451.     substr($cpout{$fh}, 0, 5120) = '';
  452.     }
  453. }
  454.  
  455. sub flushall {
  456.     $name = 'TRAILER!!!';
  457.     foreach $fh (keys %cpout) {
  458.     &cpio($nc{$fh},$fh);
  459.     $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
  460.     &flush($fh);
  461.     print $blocks{$fh} * 10, " blocks\n";
  462.     }
  463. }
  464.  
  465. END
  466. }
  467.  
  468. if ($inittar) {
  469. print <<'END';
  470. sub tar {
  471.     local($fh) = @_;
  472.     local($linkname,$header,$l,$slop);
  473.     local($linkflag) = "\0";
  474.  
  475.     ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  476.       $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
  477.     $nm = $name;
  478.     if ($nlink > 1) {
  479.     if ($linkname = $linkseen{$fh,$dev,$ino}) {
  480.         $linkflag = 1;
  481.     }
  482.     else {
  483.         $linkseen{$fh,$dev,$ino} = $nm;
  484.     }
  485.     }
  486.     if (-f _) {
  487.     open(IN, "./$_\0") || do {
  488.         warn "Couldn't open $name: $!\n";
  489.         return;
  490.     };
  491.     $size = 0 if $linkflag ne "\0";
  492.     }
  493.     else {
  494.     $linkname = readlink($_);
  495.     $linkflag = 2 if defined $linkname;
  496.     $nm .= '/' if -d _;
  497.     $size = 0;
  498.     }
  499.  
  500.     $header = pack("a100a8a8a8a12a12a8a1a100",
  501.     $nm,
  502.     sprintf("%6o ", $mode & 0777),
  503.     sprintf("%6o ", $uid & 0777777),
  504.     sprintf("%6o ", $gid & 0777777),
  505.     sprintf("%11o ", $size),
  506.     sprintf("%11o ", $mtime),
  507.     "        ",
  508.     $linkflag,
  509.     $linkname);
  510.     $l = length($header) % 512;
  511.     substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header));
  512.     substr($header, 154, 1) = "\0";  # blech
  513.     $tarout{$fh} .= $header;
  514.     $tarout{$fh} .= "\0" x (512 - $l) if $l;
  515.     if ($size) {
  516.     &tflush($fh) while ($l = length($tarout{$fh})) >= 10240;
  517.     while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
  518.         $slop = length($tarout{$fh}) % 512;
  519.         $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
  520.         &tflush($fh);
  521.         $l = length($tarout{$fh});
  522.     }
  523.     }
  524.     close IN;
  525. }
  526.  
  527. sub tflush {
  528.     local($fh) = @_;
  529.  
  530.     while (length($tarout{$fh}) >= 10240) {
  531.     syswrite($fh,$tarout{$fh},10240);
  532.     ++$blocks{$fh};
  533.     substr($tarout{$fh}, 0, 10240) = '';
  534.     }
  535. }
  536.  
  537. sub tflushall {
  538.     local($len);
  539.  
  540.     foreach $fh (keys %tarout) {
  541.     $len = 10240 - length($tarout{$fh});
  542.     $len += 10240 if $len < 1024;
  543.     $tarout{$fh} .= "\0" x $len;
  544.     &tflush($fh);
  545.     }
  546. }
  547.  
  548. END
  549. }
  550.  
  551. exit;
  552.  
  553. ############################################################################
  554.  
  555. sub tab {
  556.     local($tabstring);
  557.  
  558.     $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4);
  559.     if (!$statdone) {
  560.     if ($_ =~ /^(name|print|prune|exec|ok|\(|\))/) {
  561.         $delayedstat++;
  562.     }
  563.     else {
  564.         if ($saw_or) {
  565.         $tabstring .= <<'ENDOFSTAT' . $tabstring;
  566. ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
  567. ENDOFSTAT
  568.         }
  569.         else {
  570.         $tabstring .= <<'ENDOFSTAT' . $tabstring;
  571. (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
  572. ENDOFSTAT
  573.         }
  574.         $statdone = 1;
  575.     }
  576.     }
  577.     $tabstring =~ s/^\s+/ / if $out =~ /!$/;
  578.     $tabstring;
  579. }
  580.  
  581. sub fileglob_to_re {
  582.     local($tmp) = @_;
  583.  
  584.     $tmp =~ s#([./^\$()])#\\$1#g;
  585.     $tmp =~ s/([?*])/.$1/g;
  586.     "^$tmp\$";
  587. }
  588.  
  589. sub n {
  590.     local($n) = @_;
  591.  
  592.     $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
  593.     $n =~ s/ 0*(\d)/ $1/;
  594.     $n . ')';
  595. }
  596.  
  597. sub quote {
  598.     local($string) = @_;
  599.     $string =~ s/'/\\'/;
  600.     "'$string'";
  601. }
  602. !NO!SUBS!
  603.  
  604. close OUT or die "Can't close $file: $!";
  605. chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
  606. exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
  607.