x2p/find2perl.PL

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