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