contrib/perl5/x2p/find2perl.PL

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