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 $file .= '.com' if $^O eq 'VMS';
  18
  19 open OUT,">$file" or die "Can't create $file: $!";
  20
  21 print "Extracting $file (with variable substitutions)\n";
  22
  23 # In this section, perl variables will be expanded during extraction.
  24 # You can use $Config{...} to use Configure variables.
  25
  26 print OUT <<"!GROK!THIS!";
  27 $Config{startperl}
  28     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
  29         if \$running_under_some_shell;
  30 \$startperl = "$Config{startperl}";
  31 \$perlpath = "$Config{perlpath}";
  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) { $_ = &quote($_); }
  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 " . &quote($file) . ";\n";
 184     }
 185     elsif ($_ eq 'eval') {
 186         $prog = &quote(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, " . &quote($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, " . &quote($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     eval 'exec $perlpath -S \$0 \${1+"\$@"}'
 245         if \$running_under_some_shell;
 246
 247 END
 248
 249 if ($initls) {
 250     print <<'END';
 251 @rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
 252 @moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
 253
 254 END
 255 }
 256
 257 if ($inituser || $initls) {
 258     print 'while (($name, $pw, $uid) = getpwent) {', "\n";
 259     print '    $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser;
 260     print '    $user{$uid} = $name unless $user{$uid};', "\n" if $initls;
 261     print "}\n\n";
 262 }
 263
 264 if ($initgroup || $initls) {
 265     print 'while (($name, $pw, $gid) = getgrent) {', "\n";
 266     print '    $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup;
 267     print '    $group{$gid} = $name unless $group{$gid};', "\n" if $initls;
 268     print "}\n\n";
 269 }
 270
 271 print $initnewer, "\n" if $initnewer;
 272
 273 print $initfile, "\n" if $initfile;
 274
 275 $find = $depth ? "finddepth" : "find";
 276 print <<"END";
 277 require "$find.pl";
 278
 279 # Traverse desired filesystems
 280
 281 &$find($roots);
 282 $flushall
 283 exit;
 284
 285 sub wanted {
 286 $out;
 287 }
 288
 289 END
 290
 291 if ($initexec) {
 292     print <<'END';
 293 sub exec {
 294     local($ok, @cmd) = @_;
 295     foreach $word (@cmd) {
 296         $word =~ s#{}#$name#g;
 297     }
 298     if ($ok) {
 299         local($old) = select(STDOUT);
 300         $| = 1;
 301         print "@cmd";
 302         select($old);
 303         return 0 unless <STDIN> =~ /^y/;
 304     }
 305     chdir $cwd;         # sigh
 306     system @cmd;
 307     chdir $dir;
 308     return !$?;
 309 }
 310
 311 END
 312 }
 313
 314 if ($initls) {
 315     print <<'END';
 316 sub ls {
 317     ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
 318       $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
 319
 320     $pname = $name;
 321
 322     if (defined $blocks) {
 323         $blocks = int(($blocks + 1) / 2);
 324     }
 325     else {
 326         $blocks = int(($size + 1023) / 1024);
 327     }
 328
 329     if    (-f _) { $perms = '-'; }
 330     elsif (-d _) { $perms = 'd'; }
 331     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
 332     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
 333     elsif (-p _) { $perms = 'p'; }
 334     elsif (-S _) { $perms = 's'; }
 335     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
 336
 337     $tmpmode = $mode;
 338     $tmp = $rwx[$tmpmode & 7];
 339     $tmpmode >>= 3;
 340     $tmp = $rwx[$tmpmode & 7] . $tmp;
 341     $tmpmode >>= 3;
 342     $tmp = $rwx[$tmpmode & 7] . $tmp;
 343     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
 344     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
 345     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
 346     $perms .= $tmp;
 347
 348     $user = $user{$uid} || $uid;
 349     $group = $group{$gid} || $gid;
 350
 351     ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
 352     $moname = $moname[$mon];
 353     if (-M _ > 365.25 / 2) {
 354         $timeyear = $year + 1900;
 355     }
 356     else {
 357         $timeyear = sprintf("%02d:%02d", $hour, $min);
 358     }
 359
 360     printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
 361             $ino,
 362                  $blocks,
 363                       $perms,
 364                             $nlink,
 365                                 $user,
 366                                      $group,
 367                                           $sizemm,
 368                                               $moname,
 369                                                  $mday,
 370                                                      $timeyear,
 371                                                          $pname;
 372     1;
 373 }
 374
 375 sub sizemm {
 376     sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255);
 377 }
 378
 379 END
 380 }
 381
 382 if ($initcpio) {
 383 print <<'END';
 384 sub cpio {
 385     local($nc,$fh) = @_;
 386     local($text);
 387
 388     if ($name eq 'TRAILER!!!') {
 389         $text = '';
 390         $size = 0;
 391     }
 392     else {
 393         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
 394           $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
 395         if (-f _) {
 396             open(IN, "./$_\0") || do {
 397                 warn "Couldn't open $name: $!\n";
 398                 return;
 399             };
 400         }
 401         else {
 402             $text = readlink($_);
 403             $size = 0 unless defined $text;
 404         }
 405     }
 406
 407     ($nm = $name) =~ s#^\./##;
 408     $nc{$fh} = $nc;
 409     if ($nc eq 'n') {
 410         $cpout{$fh} .=
 411           sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
 412             070707,
 413             $dev & 0777777,
 414             $ino & 0777777,
 415             $mode & 0777777,
 416             $uid & 0777777,
 417             $gid & 0777777,
 418             $nlink & 0777777,
 419             $rdev & 0177777,
 420             $mtime,
 421             length($nm)+1,
 422             $size,
 423             $nm);
 424     }
 425     else {
 426         $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
 427         $cpout{$fh} .= pack("SSSSSSSSLSLa*",
 428             070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
 429             length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0"));
 430     }
 431     if ($text ne '') {
 432         $cpout{$fh} .= $text;
 433     }
 434     elsif ($size) {
 435         &flush($fh) while ($l = length($cpout{$fh})) >= 5120;
 436         while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
 437             &flush($fh);
 438             $l = length($cpout{$fh});
 439         }
 440     }
 441     close IN;
 442 }
 443
 444 sub flush {
 445     local($fh) = @_;
 446
 447     while (length($cpout{$fh}) >= 5120) {
 448         syswrite($fh,$cpout{$fh},5120);
 449         ++$blocks{$fh};
 450         substr($cpout{$fh}, 0, 5120) = '';
 451     }
 452 }
 453
 454 sub flushall {
 455     $name = 'TRAILER!!!';
 456     foreach $fh (keys %cpout) {
 457         &cpio($nc{$fh},$fh);
 458         $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
 459         &flush($fh);
 460         print $blocks{$fh} * 10, " blocks\n";
 461     }
 462 }
 463
 464 END
 465 }
 466
 467 if ($inittar) {
 468 print <<'END';
 469 sub tar {
 470     local($fh) = @_;
 471     local($linkname,$header,$l,$slop);
 472     local($linkflag) = "\0";
 473
 474     ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
 475       $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
 476     $nm = $name;
 477     if ($nlink > 1) {
 478         if ($linkname = $linkseen{$fh,$dev,$ino}) {
 479             $linkflag = 1;
 480         }
 481         else {
 482             $linkseen{$fh,$dev,$ino} = $nm;
 483         }
 484     }
 485     if (-f _) {
 486         open(IN, "./$_\0") || do {
 487             warn "Couldn't open $name: $!\n";
 488             return;
 489         };
 490         $size = 0 if $linkflag ne "\0";
 491     }
 492     else {
 493         $linkname = readlink($_);
 494         $linkflag = 2 if defined $linkname;
 495         $nm .= '/' if -d _;
 496         $size = 0;
 497     }
 498
 499     $header = pack("a100a8a8a8a12a12a8a1a100",
 500         $nm,
 501         sprintf("%6o ", $mode & 0777),
 502         sprintf("%6o ", $uid & 0777777),
 503         sprintf("%6o ", $gid & 0777777),
 504         sprintf("%11o ", $size),
 505         sprintf("%11o ", $mtime),
 506         "        ",
 507         $linkflag,
 508         $linkname);
 509     $l = length($header) % 512;
 510     substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header));
 511     substr($header, 154, 1) = "\0";  # blech
 512     $tarout{$fh} .= $header;
 513     $tarout{$fh} .= "\0" x (512 - $l) if $l;
 514     if ($size) {
 515         &tflush($fh) while ($l = length($tarout{$fh})) >= 10240;
 516         while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
 517             $slop = length($tarout{$fh}) % 512;
 518             $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
 519             &tflush($fh);
 520             $l = length($tarout{$fh});
 521         }
 522     }
 523     close IN;
 524 }
 525
 526 sub tflush {
 527     local($fh) = @_;
 528
 529     while (length($tarout{$fh}) >= 10240) {
 530         syswrite($fh,$tarout{$fh},10240);
 531         ++$blocks{$fh};
 532         substr($tarout{$fh}, 0, 10240) = '';
 533     }
 534 }
 535
 536 sub tflushall {
 537     local($len);
 538
 539     foreach $fh (keys %tarout) {
 540         $len = 10240 - length($tarout{$fh});
 541         $len += 10240 if $len < 1024;
 542         $tarout{$fh} .= "\0" x $len;
 543         &tflush($fh);
 544     }
 545 }
 546
 547 END
 548 }
 549
 550 exit;
 551
 552 ############################################################################
 553
 554 sub tab {
 555     local($tabstring);
 556
 557     $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4);
 558     if (!$statdone) {
 559         if ($_ =~ /^(name|print|prune|exec|ok|\(|\))/) {
 560             $delayedstat++;
 561         }
 562         else {
 563             if ($saw_or) {
 564                 $tabstring .= <<'ENDOFSTAT' . $tabstring;
 565 ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
 566 ENDOFSTAT
 567             }
 568             else {
 569                 $tabstring .= <<'ENDOFSTAT' . $tabstring;
 570 (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
 571 ENDOFSTAT
 572             }
 573             $statdone = 1;
 574         }
 575     }
 576     $tabstring =~ s/^\s+/ / if $out =~ /!$/;
 577     $tabstring;
 578 }
 579
 580 sub fileglob_to_re {
 581     local($tmp) = @_;
 582
 583     $tmp =~ s#([./^\$()])#\\$1#g;
 584     $tmp =~ s/([?*])/.$1/g;
 585     "^$tmp\$";
 586 }
 587
 588 sub n {
 589     local($n) = @_;
 590
 591     $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
 592     $n =~ s/ 0*(\d)/ $1/;
 593     $n . ')';
 594 }
 595
 596 sub quote {
 597     local($string) = @_;
 598     $string =~ s/'/\\'/;
 599     "'$string'";
 600 }
 601 !NO!SUBS!
 602
 603 close OUT or die "Can't close $file: $!";
 604 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 605 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';