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 $Config{perlpath} -S \$0 \${1+"\$@"}'
30 if \$running_under_some_shell;
31 \$startperl = "$Config{startperl}";
32 \$perlpath = "$Config{perlpath}";
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 $
45 s2p - Sed to Perl translator
49 B<s2p [options] filename>
53 I<S2p> takes a sed script specified on the command line (or from
54 standard input) and produces a comparable I<perl> script on the
63 =item B<-DE<lt>numberE<gt>>
69 specifies that this sed script was always invoked with a B<sed -n>.
70 Otherwise a switch parser is prepended to the front of the script.
74 specifies that this sed script was never invoked with a B<sed -n>.
75 Otherwise a switch parser is prepended to the front of the script.
81 The perl script produced looks very sed-ish, and there may very well
82 be better ways to express what you want to do in perl. For instance,
83 s2p does not make any use of the split operator, but you might want
86 The perl script you end up with may be either faster or slower than
87 the original sed script. If you're only interested in speed you'll
88 just have to try it both ways. Of course, if you want to do something
89 sed doesn't do, you have no choice. It's often possible to speed up
90 the perl script by various methods, such as deleting all references to
95 S2p uses no environment variables.
99 Larry Wall E<lt>F<larry@wall.org>E<gt>
105 perl The perl compiler/interpreter
107 a2p awk to perl translator
119 while ($ARGV[0] =~ /^-/) {
135 die "I don't recognize this switch: $_\n";
139 open(BODY,">/tmp/sperl$$") ||
140 &Die("Can't open temp file: $!\n");
143 if (!$assumen && !$assumep) {
144 print BODY &q(<<'EOT');
145 : while ($ARGV[0] =~ /^-/) {
152 : die "I don't recognize this switch: $_\\n";
158 print BODY &q(<<'EOT');
163 : $printit++ unless $nflag;
167 : $\ = "\n"; # automatically add newline on print
171 : while (chop($_ = <>)) {
182 # Wipe out surrounding whitespace.
186 # Perhaps it's a label/comment.
190 $label = &make_label($_);
193 if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
195 redo LINE; # Never referenced, so delete it if not a comment.
199 if ($lastlinewaslabel++) {
201 print BODY &tab, ";\n";
210 $lastlinewaslabel = '';
213 # Look for one or two address clauses
219 $addr1 = "\$. == $addr1" unless /^,/;
225 $addr1 = &fetchpat('/');
233 $addr2 = &fetchpat('/');
235 &Die("Invalid second address at line $.\n");
237 if ($addr2 =~ /^\d+$/) {
238 $addr1 .= "..$addr2";
241 $addr1 .= "...$addr2";
245 # Now we check for metacommands {, }, and ! and worry
249 # a { to keep vi happy
256 $else = "$r else $l\n";
261 if (s/^{//) { # a } to keep vi happy
268 if ($addr2 || $addr1) {
269 $space = ' ' x $shiftwidth;
273 $_ = &transmogrify();
276 # See if we can optimize to modifier form.
279 if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
280 $_ !~ / if / && $_ !~ / unless /) {
282 $_ = substr($_,$shiftwidth,1000);
284 $_ = "$if ($addr1) $l\n$change$_$rmaybe";
290 @lines = split(/\n/,$_);
292 unless (s/^ *<<--//) {
305 if ($lastlinewaslabel++) {
307 print BODY &tab, ";\n";
311 if ($appendseen || $tseen || !$assumen) {
312 $printit++ if $dseen || (!$assumen && !$assumep);
313 print BODY &q(<<'EOT');
321 : print if $printit++;
326 : { $printit++ unless $nflag; }
338 : if ($atext) { chop $atext; print $atext; $atext = ''; }
342 print BODY &q(<<'EOT');
350 open(HEAD,">/tmp/sperl2$$.c")
351 || &Die("Can't open temp file 2: $!\n");
352 print HEAD "#define PRINTIT\n" if $printit;
353 print HEAD "#define APPENDSEEN\n" if $appendseen;
354 print HEAD "#define TSEEN\n" if $tseen;
355 print HEAD "#define DSEEN\n" if $dseen;
356 print HEAD "#define ASSUMEN\n" if $assumen;
357 print HEAD "#define ASSUMEP\n" if $assumep;
358 print HEAD "#define TOPLABEL\n" if $toplabel;
359 print HEAD "#define SAWNEXT\n" if $sawnext;
360 if ($opens) {print HEAD "$opens\n";}
361 open(BODY,"/tmp/sperl$$")
362 || &Die("Can't reopen temp file: $!\n");
370 : eval 'exec $perlpath -S \$0 \${1+"\$@"}'
371 : if \$running_under_some_shell;
374 open(BODY,"cc -E /tmp/sperl2$$.c |") ||
375 &Die("Can't reopen temp file: $!\n");
389 unlink "sperl$$", "sperl2$$", "sperl2$$.c";
396 "\t" x ($indent / 8) . ' ' x ($indent % 8);
398 sub make_filehandle {
401 if (!$seen{$fname}) {
402 $_ = "FH_" . $_ if /^\d/;
407 for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
411 $opens .= &q(<<"EOT");
412 : open($_, '>$fname') || die "Can't create $fname: \$!";
421 $label =~ s/[^a-zA-Z0-9]/_/g;
422 if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
423 $label = substr($label,0,8);
425 # Could be a reserved word, so capitalize it.
426 substr($label,0,1) =~ y/a-z/A-Z/
427 if $label =~ /^[a-z]/;
436 chop($_ = &q(<<'EOT'));
447 chop($_ = &q(<<'EOT'));
451 : print if $printit++;
456 : { $printit++ unless $nflag; }
464 : <<--#ifdef APPENDSEEN
465 : if ($atext) {chop $atext; print $atext; $atext = '';}
478 $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
483 unless (s|\\$||) { $lastline = 1;}
484 s/^([ \t]*\n)/<><>$1/;
489 $_ = $command . "End_Of_Text";
494 if (/^c/) { $change = 1; }
495 $addr1 = 1 if $addr1 eq '';
496 $addr1 = '$iter = (' . $addr1 . ')';
498 " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
503 unless (s/\\$//) { $lastline = 1;}
505 s/^([ \t]*\n)/<><>$1/;
510 $_ = $command . "End_Of_Text";
514 chop($_ = &q(<<"EOT"));
516 : $space\$printit = 0;
526 $delim = substr($_,1,1);
530 for ($i = 2; $i < $len; $i++) {
531 $c = substr($_,$i,1);
534 substr($_, $i, 0) = '\\';
553 $_ = substr($_,0,--$len);
555 elsif (substr($_,$i,1) =~ /^[n]$/) {
559 substr($_,$i,1) =~ /^[(){}\w]$/) {
562 substr($_, $i, 1) = '';
565 substr($_,$i,1) =~ /^[<>]$/) {
566 substr($_,$i,1) = 'b';
568 elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
569 substr($_,$i-1,1) = '$';
572 elsif ($c eq '&' && $repl) {
573 substr($_, $i, 0) = '$';
577 elsif ($c eq '$' && $repl) {
578 substr($_, $i, 0) = '\\';
582 elsif ($c eq '[' && !$repl) {
583 $i++ if substr($_,$i,1) eq '^';
584 $i++ if substr($_,$i,1) eq ']';
591 substr($_, $i, 1) = '\\t';
595 elsif (!$repl && index("()+",$c) >= 0) {
596 substr($_, $i, 0) = '\\';
601 &Die("Malformed substitution at line $.\n")
603 $pat = substr($_, 0, $repl + 1);
604 $repl = substr($_, $repl+1, $end-$repl-1);
605 $end = substr($_, $end + 1, 1000);
608 $subst = "$pat$repl$delim";
611 if ($end =~ s/^g//) {
615 if ($end =~ s/^p//) {
616 $cmd .= ' && (print)';
619 if ($end =~ s/^w[ \t]*//) {
620 $fh = &make_filehandle($end);
621 $cmd .= " && (print $fh \$_)";
625 &Die("Unrecognized substitution command".
626 "($end) at line $.\n");
628 chop ($_ = &q(<<"EOT"));
630 : $subst && \$tflag++$cmd;
645 $fh = &make_filehandle($_);
646 $_ = "print $fh \$_;";
654 $_ = "\$atext .= `cat $file 2>/dev/null`;";
659 $_ = 'print $1 if /^(.*)/;';
664 chop($_ = &q(<<'EOT'));
674 chop($_ = &q(<<'EOT'));
678 : chop if $len1 < length;
692 $_ = '$hold .= "\n"; $hold .= $_;';
702 $_ = '$_ .= "\n"; $_ .= $hold;';
707 $_ = '($_, $hold) = ($hold, $_);';
719 $lab = &make_label($_);
720 if ($lab eq $toplabel) {
729 $_ = 'next LINE if $tflag;';
737 $lab = &make_label($_);
738 $_ = q/if ($tflag) {$tflag = 0; /;
739 if ($lab eq $toplabel) {
749 s/abcdefghijklmnopqrstuvwxyz/a-z/g;
750 s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
764 chop($_ = &q(<<'EOT'));
775 s/(\n)(.)/$1$space$2/g;
784 local($addr) = $outer;
786 local($prefix,$delim,$ch);
788 # Process pattern one potential delimiter at a time.
790 DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
793 if ($delim eq '\\') {
796 $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
797 $ch = 'b' if $ch =~ /^[<>]$/;
800 elsif ($delim eq '[') {
802 s/^\^// && ($delim .= '^');
803 s/^]// && ($delim .= ']');
805 elsif ($delim eq ']') {
808 elsif ($inbracket || $delim ne $outer) {
809 $delim = '\\' . $delim;
813 if ($delim eq $outer && !$inbracket) {
825 $string =~ s/^:\t?//g;
830 $_[0] =~ s/_a-za-z0-9/\\w/ig;
831 $_[0] =~ s/a-z_a-z0-9/\\w/ig;
832 $_[0] =~ s/a-za-z_0-9/\\w/ig;
833 $_[0] =~ s/a-za-z0-9_/\\w/ig;
834 $_[0] =~ s/_0-9a-za-z/\\w/ig;
835 $_[0] =~ s/0-9_a-za-z/\\w/ig;
836 $_[0] =~ s/0-9a-z_a-z/\\w/ig;
837 $_[0] =~ s/0-9a-za-z_/\\w/ig;
838 $_[0] =~ s/\[\\w\]/\\w/g;
839 $_[0] =~ s/\[^\\w\]/\\W/g;
840 $_[0] =~ s/\[0-9\]/\\d/g;
841 $_[0] =~ s/\[^0-9\]/\\D/g;
842 $_[0] =~ s/\\d\\d\*/\\d+/g;
843 $_[0] =~ s/\\D\\D\*/\\D+/g;
844 $_[0] =~ s/\\w\\w\*/\\w+/g;
845 $_[0] =~ s/\\t\\t\*/\\t+/g;
846 $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
847 $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
852 close OUT or die "Can't close $file: $!";
853 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
854 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';