4 use File::Basename qw(&basename &dirname);
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
12 # to ensure Configure will look for $Config{startperl}.
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.
18 $file = basename($0, '.PL');
19 $file .= '.com' if $^O eq 'VMS';
21 open OUT,">$file" or die "Can't create $file: $!";
23 print "Extracting $file (with variable substitutions)\n";
25 # In this section, perl variables will be expanded during extraction.
26 # You can use $Config{...} to use Configure variables.
28 print OUT <<"!GROK!THIS!";
30 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
31 if \$running_under_some_shell;
32 \$startperl = "$Config{startperl}";
33 \$perlpath = "$Config{perlpath}";
36 # In the following, perl variables are not expanded during extraction.
38 print OUT <<'!NO!SUBS!';
41 # Modified September 26, 1993 to provide proper handling of years after 1999
42 # Tom Link <tml+@pitt.edu>
43 # University of Pittsburgh
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
50 while ($ARGV[0] =~ /^[^-!(]/) {
53 @roots = ('.') unless @roots;
54 for (@roots) { $_ = "e($_); }
55 $roots = join(',', @roots);
63 s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
73 elsif ($_ eq 'follow') {
75 $decl = '%already_seen = ();';
76 $out .= &tab . '(not $already_seen{"$dev,$ino"}) &&';
77 $out .= "\n" . &tab . '(($already_seen{"$dev,$ino"} = !(-d _)) || 1)';
83 elsif ($_ eq 'name') {
85 $pat = &fileglob_to_re(shift);
86 $out .= '/' . $pat . "/";
88 elsif ($_ eq 'perm') {
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)";
96 $onum = '0' . $onum unless $onum =~ /^0/;
97 $out .= &tab . "((\$mode & 0777) == $onum)";
100 elsif ($_ eq 'type') {
101 ($filetest = shift) =~ tr/s/S/;
102 $out .= &tab . "-$filetest _";
104 elsif ($_ eq 'print') {
105 $out .= &tab . 'print("$name\n")';
107 elsif ($_ eq 'print0') {
108 $out .= &tab . 'print("$name\0")';
110 elsif ($_ eq 'fstype') {
114 { $out .= '($dev < 0)'; }
116 { $out .= '($dev >= 0)'; }
118 elsif ($_ eq 'user') {
120 $out .= &tab . "(\$uid == \$uid{'$uname'})";
123 elsif ($_ eq 'group') {
125 $out .= &tab . "(\$gid == \$gid{'$gname'})";
128 elsif ($_ eq 'nouser') {
129 $out .= &tab . '!defined $uid{$uid}';
132 elsif ($_ eq 'nogroup') {
133 $out .= &tab . '!defined $gid{$gid}';
136 elsif ($_ eq 'links') {
137 $out .= &tab . '($nlink ' . &n(shift);
139 elsif ($_ eq 'inum') {
140 $out .= &tab . '($ino ' . &n(shift);
142 elsif ($_ eq 'size') {
145 $out .= &tab . '(int(-s _) ' . &n($_);
147 $out .= &tab . '(int(((-s _) + 511) / 512) ' . &n($_);
150 elsif ($_ eq 'atime') {
151 $out .= &tab . '(int(-A _) ' . &n(shift);
153 elsif ($_ eq 'mtime') {
154 $out .= &tab . '(int(-M _) ' . &n(shift);
156 elsif ($_ eq 'ctime') {
157 $out .= &tab . '(int(-C _) ' . &n(shift);
159 elsif ($_ eq 'exec') {
160 for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
163 if (m#^(/bin/)?rm -f {}$#) {
165 $out .= &tab . 'unlink($_)';
168 $out .= &tab . '(unlink($_) || 1)';
171 elsif (m#^(/bin/)?rm {}$#) {
172 $out .= &tab . '(unlink($_) || warn "$name: $!\n")';
175 for (@cmd) { s/'/\\'/g; }
177 $out .= &tab . "&exec(0, '@cmd')";
183 for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
185 for (@cmd) { s/'/\\'/g; }
187 $out .= &tab . "&exec(1, '@cmd')";
191 elsif ($_ eq 'prune') {
192 $out .= &tab . '($prune = 1)';
194 elsif ($_ eq 'xdev') {
195 $out .= &tab . '!($prune |= ($dev != $topdev))';
197 elsif ($_ eq 'newer') {
200 $newername = 'AGE_OF' . $file;
201 $newername =~ s/[^\w]/_/g;
202 $newername = "\$$newername";
203 $out .= "(-M _ < $newername)";
204 $initnewer .= "$newername = -M " . "e($file) . ";\n";
206 elsif ($_ eq 'eval') {
207 $prog = "e(shift);
208 $out .= &tab . "eval $prog";
210 elsif ($_ eq 'depth') {
215 $out .= &tab . "&ls";
218 elsif ($_ eq 'tar') {
220 die "-tar must have a filename argument\n" unless @ARGV;
226 $initfile .= "open($fh, " . "e($file) .
227 qq{) || die "Can't open $fh: \$!\\n";\n};
229 $flushall = "\n&tflushall;\n";
234 die "-$_ must have a filename argument\n" unless @ARGV;
238 $out .= "&cpio('" . substr($_,0,1) . "', $fh)";
240 $initfile .= "open($fh, " . "e($file) .
241 qq{) || die "Can't open $fh: \$!\\n";\n};
243 $flushall = "\n&flushall;\n";
246 die "Unrecognized switch: -$_\n";
249 if ($ARGV[0] eq '-o') {
250 { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; }
251 $statdone = 0 if $indent == 1 && $delayedstat;
256 $out .= " &&" unless $ARGV[0] eq ')';
258 shift if $ARGV[0] eq '-a';
265 eval 'exec $perlpath -S \$0 \${1+"\$@"}'
266 if \$running_under_some_shell;
272 @rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
273 @moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
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;
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;
292 print $initnewer, "\n" if $initnewer;
294 print $initfile, "\n" if $initfile;
296 $find = $depth ? "finddepth" : "find";
300 # Traverse desired filesystems
315 local($ok, @cmd) = @_;
316 foreach $word (@cmd) {
317 $word =~ s#{}#$name#g;
320 local($old) = select(STDOUT);
324 return 0 unless <STDIN> =~ /^y/;
336 print <<"INTERP", <<'END';
338 (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$sizemm,
339 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\);
344 if (defined $blocks) {
345 $blocks = int(($blocks + 1) / 2);
348 $blocks = int(($size + 1023) / 1024);
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($_); }
360 $tmp = $rwx[$tmpmode & 7];
362 $tmp = $rwx[$tmpmode & 7] . $tmp;
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 _;
370 $user = $user{$uid} || $uid;
371 $group = $group{$gid} || $gid;
373 ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
374 $moname = $moname[$mon];
375 if (-M _ > 365.25 / 2) {
376 $timeyear = $year + 1900;
379 $timeyear = sprintf("%02d:%02d", $hour, $min);
382 printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
398 sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255);
405 print <<'START', <<"INTERP", <<'END';
410 if ($name eq 'TRAILER!!!') {
416 (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$size,
417 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\);
420 open(IN, "./$_\0") || do {
421 warn "Couldn't open $name: $!\n";
426 $text = readlink($_);
427 $size = 0 unless defined $text;
431 ($nm = $name) =~ s#^\./##;
435 sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
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"));
456 $cpout{$fh} .= $text;
459 &flush($fh) while ($l = length($cpout{$fh})) >= 5120;
460 while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
462 $l = length($cpout{$fh});
471 while (length($cpout{$fh}) >= 5120) {
472 syswrite($fh,$cpout{$fh},5120);
474 substr($cpout{$fh}, 0, 5120) = '';
479 $name = 'TRAILER!!!';
480 foreach $fh (keys %cpout) {
482 $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
484 print $blocks{$fh} * 10, " blocks\n";
492 print <<'START', <<"INTERP", <<'END';
495 local($linkname,$header,$l,$slop);
496 local($linkflag) = "\0";
499 (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$size,
500 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\);
504 if ($linkname = $linkseen{$fh,$dev,$ino}) {
508 $linkseen{$fh,$dev,$ino} = $nm;
512 open(IN, "./$_\0") || do {
513 warn "Couldn't open $name: $!\n";
516 $size = 0 if $linkflag ne "\0";
519 $linkname = readlink($_);
520 $linkflag = 2 if defined $linkname;
525 $header = pack("a100a8a8a8a12a12a8a1a100",
527 sprintf("%6o ", $mode & 0777),
528 sprintf("%6o ", $uid & 0777777),
529 sprintf("%6o ", $gid & 0777777),
530 sprintf("%11o ", $size),
531 sprintf("%11o ", $mtime),
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;
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;
546 $l = length($tarout{$fh});
555 while (length($tarout{$fh}) >= 10240) {
556 syswrite($fh,$tarout{$fh},10240);
558 substr($tarout{$fh}, 0, 10240) = '';
565 foreach $fh (keys %tarout) {
566 $len = 10240 - length($tarout{$fh});
567 $len += 10240 if $len < 1024;
568 $tarout{$fh} .= "\0" x $len;
578 ############################################################################
583 $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4);
585 if ($_ =~ /^(name|print|prune|exec|ok|\(|\))/) {
590 $tabstring .= <<"ENDOFSTAT" . $tabstring;
591 (\$nlink || ((\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid) = $stat\(\$_\))) &&
595 $tabstring .= <<"ENDOFSTAT" . $tabstring;
596 ((\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid) = $stat\(\$_\)) &&
602 $tabstring =~ s/^\s+/ / if $out =~ /!$/;
609 $tmp =~ s#([./^\$()])#\\$1#g;
610 $tmp =~ s/([?*])/.$1/g;
617 $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
618 $n =~ s/ 0*(\d)/ $1/;
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 ':';