4 use File::Basename qw(&basename &dirname);
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
11 # to ensure Configure will look for $Config{startperl}.
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.
16 ($file = basename($0)) =~ s/\.PL$//;
18 if ($Config{'osname'} eq 'VMS' or
19 $Config{'osname'} eq 'OS2'); # "case-forgiving"
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 perl -S \$0 "\$@"'
32 \$startperl = "$Config{startperl}";
35 # In the following, perl variables are not expanded during extraction.
37 print OUT <<'!NO!SUBS!';
39 # $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $
47 while ($ARGV[0] =~ /^-/) {
63 die "I don't recognize this switch: $_\n";
67 open(BODY,">/tmp/sperl$$") ||
68 &Die("Can't open temp file: $!\n");
71 if (!$assumen && !$assumep) {
72 print BODY &q(<<'EOT');
73 : while ($ARGV[0] =~ /^-/) {
80 : die "I don't recognize this switch: $_\\n";
86 print BODY &q(<<'EOT');
91 : $printit++ unless $nflag;
95 : $\ = "\n"; # automatically add newline on print
99 : while (chop($_ = <>)) {
110 # Wipe out surrounding whitespace.
114 # Perhaps it's a label/comment.
118 $label = &make_label($_);
121 if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
123 redo LINE; # Never referenced, so delete it if not a comment.
127 if ($lastlinewaslabel++) {
129 print BODY &tab, ";\n";
138 $lastlinewaslabel = '';
141 # Look for one or two address clauses
147 $addr1 = "\$. == $addr1" unless /^,/;
153 $addr1 = &fetchpat('/');
161 $addr2 = &fetchpat('/');
163 &Die("Invalid second address at line $.\n");
165 if ($addr2 =~ /^\d+$/) {
166 $addr1 .= "..$addr2";
169 $addr1 .= "...$addr2";
173 # Now we check for metacommands {, }, and ! and worry
177 # a { to keep vi happy
184 $else = "$r else $l\n";
189 if (s/^{//) { # a } to keep vi happy
196 if ($addr2 || $addr1) {
197 $space = ' ' x $shiftwidth;
201 $_ = &transmogrify();
204 # See if we can optimize to modifier form.
207 if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
208 $_ !~ / if / && $_ !~ / unless /) {
210 $_ = substr($_,$shiftwidth,1000);
212 $_ = "$if ($addr1) $l\n$change$_$rmaybe";
218 @lines = split(/\n/,$_);
220 unless (s/^ *<<--//) {
233 if ($lastlinewaslabel++) {
235 print BODY &tab, ";\n";
239 if ($appendseen || $tseen || !$assumen) {
240 $printit++ if $dseen || (!$assumen && !$assumep);
241 print BODY &q(<<'EOT');
249 : print if $printit++;
254 : { $printit++ unless $nflag; }
266 : if ($atext) { chop $atext; print $atext; $atext = ''; }
270 print BODY &q(<<'EOT');
278 open(HEAD,">/tmp/sperl2$$.c")
279 || &Die("Can't open temp file 2: $!\n");
280 print HEAD "#define PRINTIT\n" if $printit;
281 print HEAD "#define APPENDSEEN\n" if $appendseen;
282 print HEAD "#define TSEEN\n" if $tseen;
283 print HEAD "#define DSEEN\n" if $dseen;
284 print HEAD "#define ASSUMEN\n" if $assumen;
285 print HEAD "#define ASSUMEP\n" if $assumep;
286 print HEAD "#define TOPLABEL\n" if $toplabel;
287 print HEAD "#define SAWNEXT\n" if $sawnext;
288 if ($opens) {print HEAD "$opens\n";}
289 open(BODY,"/tmp/sperl$$")
290 || &Die("Can't reopen temp file: $!\n");
298 : eval 'exec perl -S \$0 \${1+"\$@"}'
299 : if \$running_under_some_shell;
302 open(BODY,"cc -E /tmp/sperl2$$.c |") ||
303 &Die("Can't reopen temp file: $!\n");
317 unlink "sperl$$", "sperl2$$", "sperl2$$.c";
324 "\t" x ($indent / 8) . ' ' x ($indent % 8);
326 sub make_filehandle {
329 if (!$seen{$fname}) {
330 $_ = "FH_" . $_ if /^\d/;
335 for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
339 $opens .= &q(<<"EOT");
340 : open($_, '>$fname') || die "Can't create $fname: \$!";
349 $label =~ s/[^a-zA-Z0-9]/_/g;
350 if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
351 $label = substr($label,0,8);
353 # Could be a reserved word, so capitalize it.
354 substr($label,0,1) =~ y/a-z/A-Z/
355 if $label =~ /^[a-z]/;
364 chop($_ = &q(<<'EOT'));
375 chop($_ = &q(<<'EOT'));
379 : print if $printit++;
384 : { $printit++ unless $nflag; }
392 : <<--#ifdef APPENDSEEN
393 : if ($atext) {chop $atext; print $atext; $atext = '';}
406 $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
411 unless (s|\\$||) { $lastline = 1;}
412 s/^([ \t]*\n)/<><>$1/;
417 $_ = $command . "End_Of_Text";
422 if (/^c/) { $change = 1; }
423 $addr1 = 1 if $addr1 eq '';
424 $addr1 = '$iter = (' . $addr1 . ')';
426 " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
431 unless (s/\\$//) { $lastline = 1;}
433 s/^([ \t]*\n)/<><>$1/;
438 $_ = $command . "End_Of_Text";
442 chop($_ = &q(<<"EOT"));
444 : $space\$printit = 0;
454 $delim = substr($_,1,1);
458 for ($i = 2; $i < $len; $i++) {
459 $c = substr($_,$i,1);
462 substr($_, $i, 0) = '\\';
481 $_ = substr($_,0,--$len);
483 elsif (substr($_,$i,1) =~ /^[n]$/) {
487 substr($_,$i,1) =~ /^[(){}\w]$/) {
490 substr($_, $i, 1) = '';
493 substr($_,$i,1) =~ /^[<>]$/) {
494 substr($_,$i,1) = 'b';
496 elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
497 substr($_,$i-1,1) = '$';
500 elsif ($c eq '&' && $repl) {
501 substr($_, $i, 0) = '$';
505 elsif ($c eq '$' && $repl) {
506 substr($_, $i, 0) = '\\';
510 elsif ($c eq '[' && !$repl) {
511 $i++ if substr($_,$i,1) eq '^';
512 $i++ if substr($_,$i,1) eq ']';
519 substr($_, $i, 1) = '\\t';
523 elsif (!$repl && index("()+",$c) >= 0) {
524 substr($_, $i, 0) = '\\';
529 &Die("Malformed substitution at line $.\n")
531 $pat = substr($_, 0, $repl + 1);
532 $repl = substr($_, $repl+1, $end-$repl-1);
533 $end = substr($_, $end + 1, 1000);
536 $subst = "$pat$repl$delim";
539 if ($end =~ s/^g//) {
543 if ($end =~ s/^p//) {
544 $cmd .= ' && (print)';
547 if ($end =~ s/^w[ \t]*//) {
548 $fh = &make_filehandle($end);
549 $cmd .= " && (print $fh \$_)";
553 &Die("Unrecognized substitution command".
554 "($end) at line $.\n");
556 chop ($_ = &q(<<"EOT"));
558 : $subst && \$tflag++$cmd;
573 $fh = &make_filehandle($_);
574 $_ = "print $fh \$_;";
582 $_ = "\$atext .= `cat $file 2>/dev/null`;";
587 $_ = 'print $1 if /^(.*)/;';
592 chop($_ = &q(<<'EOT'));
602 chop($_ = &q(<<'EOT'));
606 : chop if $len1 < length;
620 $_ = '$hold .= "\n"; $hold .= $_;';
630 $_ = '$_ .= "\n"; $_ .= $hold;';
635 $_ = '($_, $hold) = ($hold, $_);';
647 $lab = &make_label($_);
648 if ($lab eq $toplabel) {
657 $_ = 'next LINE if $tflag;';
665 $lab = &make_label($_);
666 $_ = q/if ($tflag) {$tflag = 0; /;
667 if ($lab eq $toplabel) {
677 s/abcdefghijklmnopqrstuvwxyz/a-z/g;
678 s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
692 chop($_ = &q(<<'EOT'));
703 s/(\n)(.)/$1$space$2/g;
712 local($addr) = $outer;
714 local($prefix,$delim,$ch);
716 # Process pattern one potential delimiter at a time.
718 DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
721 if ($delim eq '\\') {
724 $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
725 $ch = 'b' if $ch =~ /^[<>]$/;
728 elsif ($delim eq '[') {
730 s/^\^// && ($delim .= '^');
731 s/^]// && ($delim .= ']');
733 elsif ($delim eq ']') {
736 elsif ($inbracket || $delim ne $outer) {
737 $delim = '\\' . $delim;
741 if ($delim eq $outer && !$inbracket) {
753 $string =~ s/^:\t?//g;
758 $_[0] =~ s/_a-za-z0-9/\\w/ig;
759 $_[0] =~ s/a-z_a-z0-9/\\w/ig;
760 $_[0] =~ s/a-za-z_0-9/\\w/ig;
761 $_[0] =~ s/a-za-z0-9_/\\w/ig;
762 $_[0] =~ s/_0-9a-za-z/\\w/ig;
763 $_[0] =~ s/0-9_a-za-z/\\w/ig;
764 $_[0] =~ s/0-9a-z_a-z/\\w/ig;
765 $_[0] =~ s/0-9a-za-z_/\\w/ig;
766 $_[0] =~ s/\[\\w\]/\\w/g;
767 $_[0] =~ s/\[^\\w\]/\\W/g;
768 $_[0] =~ s/\[0-9\]/\\d/g;
769 $_[0] =~ s/\[^0-9\]/\\D/g;
770 $_[0] =~ s/\\d\\d\*/\\d+/g;
771 $_[0] =~ s/\\D\\D\*/\\D+/g;
772 $_[0] =~ s/\\w\\w\*/\\w+/g;
773 $_[0] =~ s/\\t\\t\*/\\t+/g;
774 $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
775 $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
780 close OUT or die "Can't close $file: $!";
781 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
782 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';