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