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 ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
20 open OUT,">$file" or die "Can't create $file: $!";
22 print "Extracting $file (with variable substitutions)\n";
24 # In this section, perl variables will be expanded during extraction.
25 # You can use $Config{...} to use Configure variables.
27 print OUT <<"!GROK!THIS!";
29 eval 'exec perl -S \$0 "\$@"'
31 \$startperl = "$Config{startperl}";
34 # In the following, perl variables are not expanded during extraction.
36 print OUT <<'!NO!SUBS!';
38 # $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $
46 while ($ARGV[0] =~ /^-/) {
62 die "I don't recognize this switch: $_\n";
66 open(BODY,">/tmp/sperl$$") ||
67 &Die("Can't open temp file: $!\n");
70 if (!$assumen && !$assumep) {
71 print BODY &q(<<'EOT');
72 : while ($ARGV[0] =~ /^-/) {
79 : die "I don't recognize this switch: $_\\n";
85 print BODY &q(<<'EOT');
90 : $printit++ unless $nflag;
94 : $\ = "\n"; # automatically add newline on print
98 : while (chop($_ = <>)) {
109 # Wipe out surrounding whitespace.
113 # Perhaps it's a label/comment.
117 $label = &make_label($_);
120 if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
122 redo LINE; # Never referenced, so delete it if not a comment.
126 if ($lastlinewaslabel++) {
128 print BODY &tab, ";\n";
137 $lastlinewaslabel = '';
140 # Look for one or two address clauses
146 $addr1 = "\$. == $addr1" unless /^,/;
152 $addr1 = &fetchpat('/');
160 $addr2 = &fetchpat('/');
162 &Die("Invalid second address at line $.\n");
164 if ($addr2 =~ /^\d+$/) {
165 $addr1 .= "..$addr2";
168 $addr1 .= "...$addr2";
172 # Now we check for metacommands {, }, and ! and worry
176 # a { to keep vi happy
183 $else = "$r else $l\n";
188 if (s/^{//) { # a } to keep vi happy
195 if ($addr2 || $addr1) {
196 $space = ' ' x $shiftwidth;
200 $_ = &transmogrify();
203 # See if we can optimize to modifier form.
206 if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
207 $_ !~ / if / && $_ !~ / unless /) {
209 $_ = substr($_,$shiftwidth,1000);
211 $_ = "$if ($addr1) $l\n$change$_$rmaybe";
217 @lines = split(/\n/,$_);
219 unless (s/^ *<<--//) {
232 if ($lastlinewaslabel++) {
234 print BODY &tab, ";\n";
238 if ($appendseen || $tseen || !$assumen) {
239 $printit++ if $dseen || (!$assumen && !$assumep);
240 print BODY &q(<<'EOT');
248 : print if $printit++;
253 : { $printit++ unless $nflag; }
265 : if ($atext) { chop $atext; print $atext; $atext = ''; }
269 print BODY &q(<<'EOT');
277 open(HEAD,">/tmp/sperl2$$.c")
278 || &Die("Can't open temp file 2: $!\n");
279 print HEAD "#define PRINTIT\n" if $printit;
280 print HEAD "#define APPENDSEEN\n" if $appendseen;
281 print HEAD "#define TSEEN\n" if $tseen;
282 print HEAD "#define DSEEN\n" if $dseen;
283 print HEAD "#define ASSUMEN\n" if $assumen;
284 print HEAD "#define ASSUMEP\n" if $assumep;
285 print HEAD "#define TOPLABEL\n" if $toplabel;
286 print HEAD "#define SAWNEXT\n" if $sawnext;
287 if ($opens) {print HEAD "$opens\n";}
288 open(BODY,"/tmp/sperl$$")
289 || &Die("Can't reopen temp file: $!\n");
297 : eval 'exec perl -S \$0 \${1+"\$@"}'
298 : if \$running_under_some_shell;
301 open(BODY,"cc -E /tmp/sperl2$$.c |") ||
302 &Die("Can't reopen temp file: $!\n");
316 unlink "sperl$$", "sperl2$$", "sperl2$$.c";
323 "\t" x ($indent / 8) . ' ' x ($indent % 8);
325 sub make_filehandle {
328 if (!$seen{$fname}) {
329 $_ = "FH_" . $_ if /^\d/;
334 for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
338 $opens .= &q(<<"EOT");
339 : open($_, '>$fname') || die "Can't create $fname: \$!";
348 $label =~ s/[^a-zA-Z0-9]/_/g;
349 if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
350 $label = substr($label,0,8);
352 # Could be a reserved word, so capitalize it.
353 substr($label,0,1) =~ y/a-z/A-Z/
354 if $label =~ /^[a-z]/;
363 chop($_ = &q(<<'EOT'));
374 chop($_ = &q(<<'EOT'));
378 : print if $printit++;
383 : { $printit++ unless $nflag; }
391 : <<--#ifdef APPENDSEEN
392 : if ($atext) {chop $atext; print $atext; $atext = '';}
405 $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
410 unless (s|\\$||) { $lastline = 1;}
411 s/^([ \t]*\n)/<><>$1/;
416 $_ = $command . "End_Of_Text";
421 if (/^c/) { $change = 1; }
422 $addr1 = 1 if $addr1 eq '';
423 $addr1 = '$iter = (' . $addr1 . ')';
425 " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
430 unless (s/\\$//) { $lastline = 1;}
432 s/^([ \t]*\n)/<><>$1/;
437 $_ = $command . "End_Of_Text";
441 chop($_ = &q(<<"EOT"));
443 : $space\$printit = 0;
453 $delim = substr($_,1,1);
457 for ($i = 2; $i < $len; $i++) {
458 $c = substr($_,$i,1);
461 substr($_, $i, 0) = '\\';
480 $_ = substr($_,0,--$len);
482 elsif (substr($_,$i,1) =~ /^[n]$/) {
486 substr($_,$i,1) =~ /^[(){}\w]$/) {
489 substr($_, $i, 1) = '';
492 substr($_,$i,1) =~ /^[<>]$/) {
493 substr($_,$i,1) = 'b';
495 elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
496 substr($_,$i-1,1) = '$';
499 elsif ($c eq '&' && $repl) {
500 substr($_, $i, 0) = '$';
504 elsif ($c eq '$' && $repl) {
505 substr($_, $i, 0) = '\\';
509 elsif ($c eq '[' && !$repl) {
510 $i++ if substr($_,$i,1) eq '^';
511 $i++ if substr($_,$i,1) eq ']';
518 substr($_, $i, 1) = '\\t';
522 elsif (!$repl && index("()+",$c) >= 0) {
523 substr($_, $i, 0) = '\\';
528 &Die("Malformed substitution at line $.\n")
530 $pat = substr($_, 0, $repl + 1);
531 $repl = substr($_, $repl+1, $end-$repl-1);
532 $end = substr($_, $end + 1, 1000);
535 $subst = "$pat$repl$delim";
538 if ($end =~ s/^g//) {
542 if ($end =~ s/^p//) {
543 $cmd .= ' && (print)';
546 if ($end =~ s/^w[ \t]*//) {
547 $fh = &make_filehandle($end);
548 $cmd .= " && (print $fh \$_)";
552 &Die("Unrecognized substitution command".
553 "($end) at line $.\n");
555 chop ($_ = &q(<<"EOT"));
557 : $subst && \$tflag++$cmd;
572 $fh = &make_filehandle($_);
573 $_ = "print $fh \$_;";
581 $_ = "\$atext .= `cat $file 2>/dev/null`;";
586 $_ = 'print $1 if /^(.*)/;';
591 chop($_ = &q(<<'EOT'));
601 chop($_ = &q(<<'EOT'));
605 : chop if $len1 < length;
619 $_ = '$hold .= "\n"; $hold .= $_;';
629 $_ = '$_ .= "\n"; $_ .= $hold;';
634 $_ = '($_, $hold) = ($hold, $_);';
646 $lab = &make_label($_);
647 if ($lab eq $toplabel) {
656 $_ = 'next LINE if $tflag;';
664 $lab = &make_label($_);
665 $_ = q/if ($tflag) {$tflag = 0; /;
666 if ($lab eq $toplabel) {
676 s/abcdefghijklmnopqrstuvwxyz/a-z/g;
677 s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
691 chop($_ = &q(<<'EOT'));
702 s/(\n)(.)/$1$space$2/g;
711 local($addr) = $outer;
713 local($prefix,$delim,$ch);
715 # Process pattern one potential delimiter at a time.
717 DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
720 if ($delim eq '\\') {
723 $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
724 $ch = 'b' if $ch =~ /^[<>]$/;
727 elsif ($delim eq '[') {
729 s/^\^// && ($delim .= '^');
730 s/^]// && ($delim .= ']');
732 elsif ($delim eq ']') {
735 elsif ($inbracket || $delim ne $outer) {
736 $delim = '\\' . $delim;
740 if ($delim eq $outer && !$inbracket) {
752 $string =~ s/^:\t?//g;
757 $_[0] =~ s/_a-za-z0-9/\\w/ig;
758 $_[0] =~ s/a-z_a-z0-9/\\w/ig;
759 $_[0] =~ s/a-za-z_0-9/\\w/ig;
760 $_[0] =~ s/a-za-z0-9_/\\w/ig;
761 $_[0] =~ s/_0-9a-za-z/\\w/ig;
762 $_[0] =~ s/0-9_a-za-z/\\w/ig;
763 $_[0] =~ s/0-9a-z_a-z/\\w/ig;
764 $_[0] =~ s/0-9a-za-z_/\\w/ig;
765 $_[0] =~ s/\[\\w\]/\\w/g;
766 $_[0] =~ s/\[^\\w\]/\\W/g;
767 $_[0] =~ s/\[0-9\]/\\d/g;
768 $_[0] =~ s/\[^0-9\]/\\D/g;
769 $_[0] =~ s/\\d\\d\*/\\d+/g;
770 $_[0] =~ s/\\D\\D\*/\\D+/g;
771 $_[0] =~ s/\\w\\w\*/\\w+/g;
772 $_[0] =~ s/\\t\\t\*/\\t+/g;
773 $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
774 $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
779 close OUT or die "Can't close $file: $!";
780 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
781 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';