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