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');
350 : eval 'exec $perlpath -S \$0 \${1+"\$@"}'
351 : if \$running_under_some_shell;
354 print"$opens\n" if $opens;
355 seek(BODY, 0, 0) || die "Can't rewind temp file: $!\n";
358 /^#ifdef (\w+)/ && ((${lc $1} || &skip), next);
359 /^#else/ && (&skip, next);
370 unlink "/tmp/sperl$$";
377 "\t" x ($indent / 8) . ' ' x ($indent % 8);
379 sub make_filehandle {
382 if (!$seen{$fname}) {
383 $_ = "FH_" . $_ if /^\d/;
388 for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
392 $opens .= &q(<<"EOT");
393 : open($_, '>$fname') || die "Can't create $fname: \$!";
402 $label =~ s/[^a-zA-Z0-9]/_/g;
403 if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
404 $label = substr($label,0,8);
406 # Could be a reserved word, so capitalize it.
407 substr($label,0,1) =~ y/a-z/A-Z/
408 if $label =~ /^[a-z]/;
417 chop($_ = &q(<<'EOT'));
428 chop($_ = &q(<<'EOT'));
432 : print if $printit++;
437 : { $printit++ unless $nflag; }
445 : <<--#ifdef APPENDSEEN
446 : if ($atext) {chop $atext; print $atext; $atext = '';}
459 $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
464 unless (s|\\$||) { $lastline = 1;}
465 s/^([ \t]*\n)/<><>$1/;
470 $_ = $command . "End_Of_Text";
475 if (/^c/) { $change = 1; }
476 $addr1 = 1 if $addr1 eq '';
477 $addr1 = '$iter = (' . $addr1 . ')';
479 " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
484 unless (s/\\$//) { $lastline = 1;}
486 s/^([ \t]*\n)/<><>$1/;
491 $_ = $command . "End_Of_Text";
495 chop($_ = &q(<<"EOT"));
497 : $space\$printit = 0;
507 $delim = substr($_,1,1);
511 for ($i = 2; $i < $len; $i++) {
512 $c = substr($_,$i,1);
515 substr($_, $i, 0) = '\\';
534 $_ = substr($_,0,--$len);
536 elsif (substr($_,$i,1) =~ /^[n]$/) {
540 substr($_,$i,1) =~ /^[(){}\w]$/) {
543 substr($_, $i, 1) = '';
546 substr($_,$i,1) =~ /^[<>]$/) {
547 substr($_,$i,1) = 'b';
549 elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
550 substr($_,$i-1,1) = '$';
553 elsif ($c eq '&' && $repl) {
554 substr($_, $i, 0) = '$';
558 elsif ($c eq '$' && $repl) {
559 substr($_, $i, 0) = '\\';
563 elsif ($c eq '[' && !$repl) {
564 $i++ if substr($_,$i,1) eq '^';
565 $i++ if substr($_,$i,1) eq ']';
572 substr($_, $i, 1) = '\\t';
576 elsif (!$repl && index("()+",$c) >= 0) {
577 substr($_, $i, 0) = '\\';
582 &Die("Malformed substitution at line $.\n")
584 $pat = substr($_, 0, $repl + 1);
585 $repl = substr($_, $repl+1, $end-$repl-1);
586 $end = substr($_, $end + 1, 1000);
588 $subst = "$pat$repl$delim";
591 if ($end =~ s/^g//) {
595 if ($end =~ s/^p//) {
596 $cmd .= ' && (print)';
599 if ($end =~ s/^w[ \t]*//) {
600 $fh = &make_filehandle($end);
601 $cmd .= " && (print $fh \$_)";
605 &Die("Unrecognized substitution command".
606 "($end) at line $.\n");
608 chop ($_ = &q(<<"EOT"));
610 : $subst && \$tflag++$cmd;
625 $fh = &make_filehandle($_);
626 $_ = "print $fh \$_;";
634 $_ = "\$atext .= `cat $file 2>/dev/null`;";
639 $_ = 'print $1 if /^(.*)/;';
644 chop($_ = &q(<<'EOT'));
654 chop($_ = &q(<<'EOT'));
658 : chop if $len1 < length;
672 $_ = '$hold .= "\n"; $hold .= $_;';
682 $_ = '$_ .= "\n"; $_ .= $hold;';
687 $_ = '($_, $hold) = ($hold, $_);';
699 $lab = &make_label($_);
700 if ($lab eq $toplabel) {
709 $_ = 'next LINE if $tflag;';
717 $lab = &make_label($_);
718 $_ = q/if ($tflag) {$tflag = 0; /;
719 if ($lab eq $toplabel) {
729 s/abcdefghijklmnopqrstuvwxyz/a-z/g;
730 s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
744 chop($_ = &q(<<'EOT'));
755 s/(\n)(.)/$1$space$2/g;
764 local($addr) = $outer;
766 local($prefix,$delim,$ch);
768 # Process pattern one potential delimiter at a time.
770 DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
773 if ($delim eq '\\') {
776 $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
777 $ch = 'b' if $ch =~ /^[<>]$/;
780 elsif ($delim eq '[') {
782 s/^\^// && ($delim .= '^');
783 s/^]// && ($delim .= ']');
785 elsif ($delim eq ']') {
788 elsif ($inbracket || $delim ne $outer) {
789 $delim = '\\' . $delim;
793 if ($delim eq $outer && !$inbracket) {
805 $string =~ s/^:\t?//g;
810 $_[0] =~ s/_a-za-z0-9/\\w/ig;
811 $_[0] =~ s/a-z_a-z0-9/\\w/ig;
812 $_[0] =~ s/a-za-z_0-9/\\w/ig;
813 $_[0] =~ s/a-za-z0-9_/\\w/ig;
814 $_[0] =~ s/_0-9a-za-z/\\w/ig;
815 $_[0] =~ s/0-9_a-za-z/\\w/ig;
816 $_[0] =~ s/0-9a-z_a-z/\\w/ig;
817 $_[0] =~ s/0-9a-za-z_/\\w/ig;
818 $_[0] =~ s/\[\\w\]/\\w/g;
819 $_[0] =~ s/\[^\\w\]/\\W/g;
820 $_[0] =~ s/\[0-9\]/\\d/g;
821 $_[0] =~ s/\[^0-9\]/\\D/g;
822 $_[0] =~ s/\\d\\d\*/\\d+/g;
823 $_[0] =~ s/\\D\\D\*/\\D+/g;
824 $_[0] =~ s/\\w\\w\*/\\w+/g;
825 $_[0] =~ s/\\t\\t\*/\\t+/g;
826 $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
827 $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
834 /^#ifdef/ && $level++;
835 /^#else/ && !$level && return;
836 /^#endif/ && !$level-- && return;
839 die "Unterminated `#ifdef' conditional\n";
843 close OUT or die "Can't close $file: $!";
844 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
845 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';