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');
17 $file .= '.com' if $^O eq 'VMS';
19 open OUT,">$file" or die "Can't create $file: $!";
21 print "Extracting $file (with variable substitutions)\n";
23 # In this section, perl variables will be expanded during extraction.
24 # You can use $Config{...} to use Configure variables.
26 print OUT <<"!GROK!THIS!";
28 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
29 if \$running_under_some_shell;
30 \$startperl = "$Config{startperl}";
31 \$perlpath = "$Config{perlpath}";
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 $
44 s2p - Sed to Perl translator
48 B<s2p [options] filename>
52 I<S2p> takes a sed script specified on the command line (or from
53 standard input) and produces a comparable I<perl> script on the
62 =item B<-DE<lt>numberE<gt>>
68 specifies that this sed script was always invoked with a B<sed -n>.
69 Otherwise a switch parser is prepended to the front of the script.
73 specifies that this sed script was never invoked with a B<sed -n>.
74 Otherwise a switch parser is prepended to the front of the script.
80 The perl script produced looks very sed-ish, and there may very well
81 be better ways to express what you want to do in perl. For instance,
82 s2p does not make any use of the split operator, but you might want
85 The perl script you end up with may be either faster or slower than
86 the original sed script. If you're only interested in speed you'll
87 just have to try it both ways. Of course, if you want to do something
88 sed doesn't do, you have no choice. It's often possible to speed up
89 the perl script by various methods, such as deleting all references to
94 S2p uses no environment variables.
98 Larry Wall E<lt>F<larry@wall.org>E<gt>
104 perl The perl compiler/interpreter
106 a2p awk to perl translator
118 while ($ARGV[0] =~ /^-/) {
134 die "I don't recognize this switch: $_\n";
138 open(BODY,">/tmp/sperl$$") ||
139 &Die("Can't open temp file: $!\n");
142 if (!$assumen && !$assumep) {
143 print BODY &q(<<'EOT');
144 : while ($ARGV[0] =~ /^-/) {
151 : die "I don't recognize this switch: $_\\n";
157 print BODY &q(<<'EOT');
162 : $printit++ unless $nflag;
166 : $\ = "\n"; # automatically add newline on print
170 : while (chop($_ = <>)) {
181 # Wipe out surrounding whitespace.
185 # Perhaps it's a label/comment.
189 $label = &make_label($_);
192 if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
194 redo LINE; # Never referenced, so delete it if not a comment.
198 if ($lastlinewaslabel++) {
200 print BODY &tab, ";\n";
209 $lastlinewaslabel = '';
212 # Look for one or two address clauses
218 $addr1 = "\$. == $addr1" unless /^,/;
224 $addr1 = &fetchpat('/');
232 $addr2 = &fetchpat('/');
234 &Die("Invalid second address at line $.\n");
236 if ($addr2 =~ /^\d+$/) {
237 $addr1 .= "..$addr2";
240 $addr1 .= "...$addr2";
244 # Now we check for metacommands {, }, and ! and worry
248 # a { to keep vi happy
255 $else = "$r else $l\n";
260 if (s/^{//) { # a } to keep vi happy
267 if ($addr2 || $addr1) {
268 $space = ' ' x $shiftwidth;
272 $_ = &transmogrify();
275 # See if we can optimize to modifier form.
278 if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
279 $_ !~ / if / && $_ !~ / unless /) {
281 $_ = substr($_,$shiftwidth,1000);
283 $_ = "$if ($addr1) $l\n$change$_$rmaybe";
289 @lines = split(/\n/,$_);
291 unless (s/^ *<<--//) {
304 if ($lastlinewaslabel++) {
306 print BODY &tab, ";\n";
310 if ($appendseen || $tseen || !$assumen) {
311 $printit++ if $dseen || (!$assumen && !$assumep);
312 print BODY &q(<<'EOT');
320 : print if $printit++;
325 : { $printit++ unless $nflag; }
337 : if ($atext) { chop $atext; print $atext; $atext = ''; }
341 print BODY &q(<<'EOT');
349 open(HEAD,">/tmp/sperl2$$.c")
350 || &Die("Can't open temp file 2: $!\n");
351 print HEAD "#define PRINTIT\n" if $printit;
352 print HEAD "#define APPENDSEEN\n" if $appendseen;
353 print HEAD "#define TSEEN\n" if $tseen;
354 print HEAD "#define DSEEN\n" if $dseen;
355 print HEAD "#define ASSUMEN\n" if $assumen;
356 print HEAD "#define ASSUMEP\n" if $assumep;
357 print HEAD "#define TOPLABEL\n" if $toplabel;
358 print HEAD "#define SAWNEXT\n" if $sawnext;
359 if ($opens) {print HEAD "$opens\n";}
360 open(BODY,"/tmp/sperl$$")
361 || &Die("Can't reopen temp file: $!\n");
369 : eval 'exec $perlpath -S \$0 \${1+"\$@"}'
370 : if \$running_under_some_shell;
373 open(BODY,"cc -E /tmp/sperl2$$.c |") ||
374 &Die("Can't reopen temp file: $!\n");
388 unlink "sperl$$", "sperl2$$", "sperl2$$.c";
395 "\t" x ($indent / 8) . ' ' x ($indent % 8);
397 sub make_filehandle {
400 if (!$seen{$fname}) {
401 $_ = "FH_" . $_ if /^\d/;
406 for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
410 $opens .= &q(<<"EOT");
411 : open($_, '>$fname') || die "Can't create $fname: \$!";
420 $label =~ s/[^a-zA-Z0-9]/_/g;
421 if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
422 $label = substr($label,0,8);
424 # Could be a reserved word, so capitalize it.
425 substr($label,0,1) =~ y/a-z/A-Z/
426 if $label =~ /^[a-z]/;
435 chop($_ = &q(<<'EOT'));
446 chop($_ = &q(<<'EOT'));
450 : print if $printit++;
455 : { $printit++ unless $nflag; }
463 : <<--#ifdef APPENDSEEN
464 : if ($atext) {chop $atext; print $atext; $atext = '';}
477 $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
482 unless (s|\\$||) { $lastline = 1;}
483 s/^([ \t]*\n)/<><>$1/;
488 $_ = $command . "End_Of_Text";
493 if (/^c/) { $change = 1; }
494 $addr1 = 1 if $addr1 eq '';
495 $addr1 = '$iter = (' . $addr1 . ')';
497 " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
502 unless (s/\\$//) { $lastline = 1;}
504 s/^([ \t]*\n)/<><>$1/;
509 $_ = $command . "End_Of_Text";
513 chop($_ = &q(<<"EOT"));
515 : $space\$printit = 0;
525 $delim = substr($_,1,1);
529 for ($i = 2; $i < $len; $i++) {
530 $c = substr($_,$i,1);
533 substr($_, $i, 0) = '\\';
552 $_ = substr($_,0,--$len);
554 elsif (substr($_,$i,1) =~ /^[n]$/) {
558 substr($_,$i,1) =~ /^[(){}\w]$/) {
561 substr($_, $i, 1) = '';
564 substr($_,$i,1) =~ /^[<>]$/) {
565 substr($_,$i,1) = 'b';
567 elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
568 substr($_,$i-1,1) = '$';
571 elsif ($c eq '&' && $repl) {
572 substr($_, $i, 0) = '$';
576 elsif ($c eq '$' && $repl) {
577 substr($_, $i, 0) = '\\';
581 elsif ($c eq '[' && !$repl) {
582 $i++ if substr($_,$i,1) eq '^';
583 $i++ if substr($_,$i,1) eq ']';
590 substr($_, $i, 1) = '\\t';
594 elsif (!$repl && index("()+",$c) >= 0) {
595 substr($_, $i, 0) = '\\';
600 &Die("Malformed substitution at line $.\n")
602 $pat = substr($_, 0, $repl + 1);
603 $repl = substr($_, $repl+1, $end-$repl-1);
604 $end = substr($_, $end + 1, 1000);
607 $subst = "$pat$repl$delim";
610 if ($end =~ s/^g//) {
614 if ($end =~ s/^p//) {
615 $cmd .= ' && (print)';
618 if ($end =~ s/^w[ \t]*//) {
619 $fh = &make_filehandle($end);
620 $cmd .= " && (print $fh \$_)";
624 &Die("Unrecognized substitution command".
625 "($end) at line $.\n");
627 chop ($_ = &q(<<"EOT"));
629 : $subst && \$tflag++$cmd;
644 $fh = &make_filehandle($_);
645 $_ = "print $fh \$_;";
653 $_ = "\$atext .= `cat $file 2>/dev/null`;";
658 $_ = 'print $1 if /^(.*)/;';
663 chop($_ = &q(<<'EOT'));
673 chop($_ = &q(<<'EOT'));
677 : chop if $len1 < length;
691 $_ = '$hold .= "\n"; $hold .= $_;';
701 $_ = '$_ .= "\n"; $_ .= $hold;';
706 $_ = '($_, $hold) = ($hold, $_);';
718 $lab = &make_label($_);
719 if ($lab eq $toplabel) {
728 $_ = 'next LINE if $tflag;';
736 $lab = &make_label($_);
737 $_ = q/if ($tflag) {$tflag = 0; /;
738 if ($lab eq $toplabel) {
748 s/abcdefghijklmnopqrstuvwxyz/a-z/g;
749 s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
763 chop($_ = &q(<<'EOT'));
774 s/(\n)(.)/$1$space$2/g;
783 local($addr) = $outer;
785 local($prefix,$delim,$ch);
787 # Process pattern one potential delimiter at a time.
789 DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
792 if ($delim eq '\\') {
795 $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
796 $ch = 'b' if $ch =~ /^[<>]$/;
799 elsif ($delim eq '[') {
801 s/^\^// && ($delim .= '^');
802 s/^]// && ($delim .= ']');
804 elsif ($delim eq ']') {
807 elsif ($inbracket || $delim ne $outer) {
808 $delim = '\\' . $delim;
812 if ($delim eq $outer && !$inbracket) {
824 $string =~ s/^:\t?//g;
829 $_[0] =~ s/_a-za-z0-9/\\w/ig;
830 $_[0] =~ s/a-z_a-z0-9/\\w/ig;
831 $_[0] =~ s/a-za-z_0-9/\\w/ig;
832 $_[0] =~ s/a-za-z0-9_/\\w/ig;
833 $_[0] =~ s/_0-9a-za-z/\\w/ig;
834 $_[0] =~ s/0-9_a-za-z/\\w/ig;
835 $_[0] =~ s/0-9a-z_a-z/\\w/ig;
836 $_[0] =~ s/0-9a-za-z_/\\w/ig;
837 $_[0] =~ s/\[\\w\]/\\w/g;
838 $_[0] =~ s/\[^\\w\]/\\W/g;
839 $_[0] =~ s/\[0-9\]/\\d/g;
840 $_[0] =~ s/\[^0-9\]/\\D/g;
841 $_[0] =~ s/\\d\\d\*/\\d+/g;
842 $_[0] =~ s/\\D\\D\*/\\D+/g;
843 $_[0] =~ s/\\w\\w\*/\\w+/g;
844 $_[0] =~ s/\\t\\t\*/\\t+/g;
845 $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
846 $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
851 close OUT or die "Can't close $file: $!";
852 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
853 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';