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, '.PL');
18 open OUT,">$file" or die "Can't create $file: $!";
20 print "Extracting $file (with variable substitutions)\n";
22 # In this section, perl variables will be expanded during extraction.
23 # You can use $Config{...} to use Configure variables.
25 print OUT <<"!GROK!THIS!";
27 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
28 if \$running_under_some_shell;
29 \$startperl = "$Config{startperl}";
30 \$perlpath = "$Config{perlpath}";
33 # In the following, perl variables are not expanded during extraction.
35 print OUT <<'!NO!SUBS!';
37 # $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $
43 s2p - Sed to Perl translator
47 B<s2p [options] filename>
51 I<S2p> takes a sed script specified on the command line (or from
52 standard input) and produces a comparable I<perl> script on the
61 =item B<-DE<lt>numberE<gt>>
67 specifies that this sed script was always invoked with a B<sed -n>.
68 Otherwise a switch parser is prepended to the front of the script.
72 specifies that this sed script was never invoked with a B<sed -n>.
73 Otherwise a switch parser is prepended to the front of the script.
79 The perl script produced looks very sed-ish, and there may very well
80 be better ways to express what you want to do in perl. For instance,
81 s2p does not make any use of the split operator, but you might want
84 The perl script you end up with may be either faster or slower than
85 the original sed script. If you're only interested in speed you'll
86 just have to try it both ways. Of course, if you want to do something
87 sed doesn't do, you have no choice. It's often possible to speed up
88 the perl script by various methods, such as deleting all references to
93 S2p uses no environment variables.
97 Larry Wall E<lt>F<larry@wall.org>E<gt>
103 perl The perl compiler/interpreter
105 a2p awk to perl translator
117 while ($ARGV[0] =~ /^-/) {
133 die "I don't recognize this switch: $_\n";
137 open(BODY,">/tmp/sperl$$") ||
138 &Die("Can't open temp file: $!\n");
141 if (!$assumen && !$assumep) {
142 print BODY &q(<<'EOT');
143 : while ($ARGV[0] =~ /^-/) {
150 : die "I don't recognize this switch: $_\\n";
156 print BODY &q(<<'EOT');
161 : $printit++ unless $nflag;
165 : $\ = "\n"; # automatically add newline on print
169 : while (chop($_ = <>)) {
180 # Wipe out surrounding whitespace.
184 # Perhaps it's a label/comment.
188 $label = &make_label($_);
191 if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
193 redo LINE; # Never referenced, so delete it if not a comment.
197 if ($lastlinewaslabel++) {
199 print BODY &tab, ";\n";
208 $lastlinewaslabel = '';
211 # Look for one or two address clauses
217 $addr1 = "\$. == $addr1" unless /^,/;
223 $addr1 = &fetchpat('/');
231 $addr2 = &fetchpat('/');
233 &Die("Invalid second address at line $.\n");
235 if ($addr2 =~ /^\d+$/) {
236 $addr1 .= "..$addr2";
239 $addr1 .= "...$addr2";
243 # Now we check for metacommands {, }, and ! and worry
247 # a { to keep vi happy
254 $else = "$r else $l\n";
259 if (s/^{//) { # a } to keep vi happy
266 if ($addr2 || $addr1) {
267 $space = ' ' x $shiftwidth;
271 $_ = &transmogrify();
274 # See if we can optimize to modifier form.
277 if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
278 $_ !~ / if / && $_ !~ / unless /) {
280 $_ = substr($_,$shiftwidth,1000);
282 $_ = "$if ($addr1) $l\n$change$_$rmaybe";
288 @lines = split(/\n/,$_);
290 unless (s/^ *<<--//) {
303 if ($lastlinewaslabel++) {
305 print BODY &tab, ";\n";
309 if ($appendseen || $tseen || !$assumen) {
310 $printit++ if $dseen || (!$assumen && !$assumep);
311 print BODY &q(<<'EOT');
319 : print if $printit++;
324 : { $printit++ unless $nflag; }
336 : if ($atext) { chop $atext; print $atext; $atext = ''; }
340 print BODY &q(<<'EOT');
348 open(HEAD,">/tmp/sperl2$$.c")
349 || &Die("Can't open temp file 2: $!\n");
350 print HEAD "#define PRINTIT\n" if $printit;
351 print HEAD "#define APPENDSEEN\n" if $appendseen;
352 print HEAD "#define TSEEN\n" if $tseen;
353 print HEAD "#define DSEEN\n" if $dseen;
354 print HEAD "#define ASSUMEN\n" if $assumen;
355 print HEAD "#define ASSUMEP\n" if $assumep;
356 print HEAD "#define TOPLABEL\n" if $toplabel;
357 print HEAD "#define SAWNEXT\n" if $sawnext;
358 if ($opens) {print HEAD "$opens\n";}
359 open(BODY,"/tmp/sperl$$")
360 || &Die("Can't reopen temp file: $!\n");
368 : eval 'exec $perlpath -S \$0 \${1+"\$@"}'
369 : if \$running_under_some_shell;
372 open(BODY,"cc -E /tmp/sperl2$$.c |") ||
373 &Die("Can't reopen temp file: $!\n");
387 unlink "sperl$$", "sperl2$$", "sperl2$$.c";
394 "\t" x ($indent / 8) . ' ' x ($indent % 8);
396 sub make_filehandle {
399 if (!$seen{$fname}) {
400 $_ = "FH_" . $_ if /^\d/;
405 for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
409 $opens .= &q(<<"EOT");
410 : open($_, '>$fname') || die "Can't create $fname: \$!";
419 $label =~ s/[^a-zA-Z0-9]/_/g;
420 if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
421 $label = substr($label,0,8);
423 # Could be a reserved word, so capitalize it.
424 substr($label,0,1) =~ y/a-z/A-Z/
425 if $label =~ /^[a-z]/;
434 chop($_ = &q(<<'EOT'));
445 chop($_ = &q(<<'EOT'));
449 : print if $printit++;
454 : { $printit++ unless $nflag; }
462 : <<--#ifdef APPENDSEEN
463 : if ($atext) {chop $atext; print $atext; $atext = '';}
476 $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
481 unless (s|\\$||) { $lastline = 1;}
482 s/^([ \t]*\n)/<><>$1/;
487 $_ = $command . "End_Of_Text";
492 if (/^c/) { $change = 1; }
493 $addr1 = 1 if $addr1 eq '';
494 $addr1 = '$iter = (' . $addr1 . ')';
496 " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
501 unless (s/\\$//) { $lastline = 1;}
503 s/^([ \t]*\n)/<><>$1/;
508 $_ = $command . "End_Of_Text";
512 chop($_ = &q(<<"EOT"));
514 : $space\$printit = 0;
524 $delim = substr($_,1,1);
528 for ($i = 2; $i < $len; $i++) {
529 $c = substr($_,$i,1);
532 substr($_, $i, 0) = '\\';
551 $_ = substr($_,0,--$len);
553 elsif (substr($_,$i,1) =~ /^[n]$/) {
557 substr($_,$i,1) =~ /^[(){}\w]$/) {
560 substr($_, $i, 1) = '';
563 substr($_,$i,1) =~ /^[<>]$/) {
564 substr($_,$i,1) = 'b';
566 elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
567 substr($_,$i-1,1) = '$';
570 elsif ($c eq '&' && $repl) {
571 substr($_, $i, 0) = '$';
575 elsif ($c eq '$' && $repl) {
576 substr($_, $i, 0) = '\\';
580 elsif ($c eq '[' && !$repl) {
581 $i++ if substr($_,$i,1) eq '^';
582 $i++ if substr($_,$i,1) eq ']';
589 substr($_, $i, 1) = '\\t';
593 elsif (!$repl && index("()+",$c) >= 0) {
594 substr($_, $i, 0) = '\\';
599 &Die("Malformed substitution at line $.\n")
601 $pat = substr($_, 0, $repl + 1);
602 $repl = substr($_, $repl+1, $end-$repl-1);
603 $end = substr($_, $end + 1, 1000);
606 $subst = "$pat$repl$delim";
609 if ($end =~ s/^g//) {
613 if ($end =~ s/^p//) {
614 $cmd .= ' && (print)';
617 if ($end =~ s/^w[ \t]*//) {
618 $fh = &make_filehandle($end);
619 $cmd .= " && (print $fh \$_)";
623 &Die("Unrecognized substitution command".
624 "($end) at line $.\n");
626 chop ($_ = &q(<<"EOT"));
628 : $subst && \$tflag++$cmd;
643 $fh = &make_filehandle($_);
644 $_ = "print $fh \$_;";
652 $_ = "\$atext .= `cat $file 2>/dev/null`;";
657 $_ = 'print $1 if /^(.*)/;';
662 chop($_ = &q(<<'EOT'));
672 chop($_ = &q(<<'EOT'));
676 : chop if $len1 < length;
690 $_ = '$hold .= "\n"; $hold .= $_;';
700 $_ = '$_ .= "\n"; $_ .= $hold;';
705 $_ = '($_, $hold) = ($hold, $_);';
717 $lab = &make_label($_);
718 if ($lab eq $toplabel) {
727 $_ = 'next LINE if $tflag;';
735 $lab = &make_label($_);
736 $_ = q/if ($tflag) {$tflag = 0; /;
737 if ($lab eq $toplabel) {
747 s/abcdefghijklmnopqrstuvwxyz/a-z/g;
748 s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
762 chop($_ = &q(<<'EOT'));
773 s/(\n)(.)/$1$space$2/g;
782 local($addr) = $outer;
784 local($prefix,$delim,$ch);
786 # Process pattern one potential delimiter at a time.
788 DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
791 if ($delim eq '\\') {
794 $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
795 $ch = 'b' if $ch =~ /^[<>]$/;
798 elsif ($delim eq '[') {
800 s/^\^// && ($delim .= '^');
801 s/^]// && ($delim .= ']');
803 elsif ($delim eq ']') {
806 elsif ($inbracket || $delim ne $outer) {
807 $delim = '\\' . $delim;
811 if ($delim eq $outer && !$inbracket) {
823 $string =~ s/^:\t?//g;
828 $_[0] =~ s/_a-za-z0-9/\\w/ig;
829 $_[0] =~ s/a-z_a-z0-9/\\w/ig;
830 $_[0] =~ s/a-za-z_0-9/\\w/ig;
831 $_[0] =~ s/a-za-z0-9_/\\w/ig;
832 $_[0] =~ s/_0-9a-za-z/\\w/ig;
833 $_[0] =~ s/0-9_a-za-z/\\w/ig;
834 $_[0] =~ s/0-9a-z_a-z/\\w/ig;
835 $_[0] =~ s/0-9a-za-z_/\\w/ig;
836 $_[0] =~ s/\[\\w\]/\\w/g;
837 $_[0] =~ s/\[^\\w\]/\\W/g;
838 $_[0] =~ s/\[0-9\]/\\d/g;
839 $_[0] =~ s/\[^0-9\]/\\D/g;
840 $_[0] =~ s/\\d\\d\*/\\d+/g;
841 $_[0] =~ s/\\D\\D\*/\\D+/g;
842 $_[0] =~ s/\\w\\w\*/\\w+/g;
843 $_[0] =~ s/\\t\\t\*/\\t+/g;
844 $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
845 $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
850 close OUT or die "Can't close $file: $!";
851 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
852 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';