source: trunk/third/perl/x2p/s2p.PL @ 14545

Revision 14545, 15.5 KB checked in by ghudson, 24 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r14544, which included commits to RCS files with non-trunk default branches.
Line 
1#!/usr/local/bin/perl
2
3use Config;
4use File::Basename qw(&basename &dirname);
5use Cwd;
6
7# List explicitly here the variables you want Configure to
8# generate.  Metaconfig only looks for shell variables, so you
9# have to mention them as if they were shell variables, not
10# %Config entries.  Thus you write
11#  $startperl
12# to ensure Configure will look for $Config{startperl}.
13
14# This forces PL files to create target in same directory as PL file.
15# This is so that make depend always knows where to find PL derivatives.
16$origdir = cwd;
17chdir dirname($0);
18$file = basename($0, '.PL');
19$file .= '.com' if $^O eq 'VMS';
20
21open OUT,">$file" or die "Can't create $file: $!";
22
23print "Extracting $file (with variable substitutions)\n";
24
25# In this section, perl variables will be expanded during extraction.
26# You can use $Config{...} to use Configure variables.
27
28print OUT <<"!GROK!THIS!";
29$Config{startperl}
30    eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
31        if \$running_under_some_shell;
32\$startperl = "$Config{startperl}";
33\$perlpath = "$Config{perlpath}";
34!GROK!THIS!
35
36# In the following, perl variables are not expanded during extraction.
37
38print OUT <<'!NO!SUBS!';
39
40# $RCSfile: s2p.PL,v $$Revision: 1.1.1.2 $$Date: 2000-04-07 20:47:59 $
41#
42# $Log: not supported by cvs2svn $
43
44=head1 NAME
45
46s2p - Sed to Perl translator
47
48=head1 SYNOPSIS
49
50B<s2p [options] filename>
51
52=head1 DESCRIPTION
53
54I<s2p> takes a sed script specified on the command line (or from
55standard input) and produces a comparable I<perl> script on the
56standard output.
57
58=head2 Options
59
60Options include:
61
62=over 5
63
64=item B<-DE<lt>numberE<gt>>
65
66sets debugging flags.
67
68=item B<-n>
69
70specifies that this sed script was always invoked with a B<sed -n>.
71Otherwise a switch parser is prepended to the front of the script.
72
73=item B<-p>
74
75specifies that this sed script was never invoked with a B<sed -n>.
76Otherwise a switch parser is prepended to the front of the script.
77
78=back
79
80=head2 Considerations
81
82The perl script produced looks very sed-ish, and there may very well
83be better ways to express what you want to do in perl.  For instance,
84s2p does not make any use of the split operator, but you might want
85to.
86
87The perl script you end up with may be either faster or slower than
88the original sed script.  If you're only interested in speed you'll
89just have to try it both ways.  Of course, if you want to do something
90sed doesn't do, you have no choice.  It's often possible to speed up
91the perl script by various methods, such as deleting all references to
92$\ and chop.
93
94=head1 ENVIRONMENT
95
96s2p uses no environment variables.
97
98=head1 AUTHOR
99
100Larry Wall E<lt>F<larry@wall.org>E<gt>
101
102=head1 FILES
103
104=head1 SEE ALSO
105
106 perl   The perl compiler/interpreter
107
108 a2p    awk to perl translator
109
110=head1 DIAGNOSTICS
111
112=head1 BUGS
113
114=cut
115
116$indent = 4;
117$shiftwidth = 4;
118$l = '{'; $r = '}';
119
120while ($ARGV[0] =~ /^-/) {
121    $_ = shift;
122  last if /^--/;
123    if (/^-D/) {
124        $debug++;
125        open(BODY,'>-');
126        next;
127    }
128    if (/^-n/) {
129        $assumen++;
130        next;
131    }
132    if (/^-p/) {
133        $assumep++;
134        next;
135    }
136    die "I don't recognize this switch: $_\n";
137}
138
139unless ($debug) {
140    open(BODY,"+>/tmp/sperl$$") ||
141      &Die("Can't open temp file: $!\n");
142}
143
144if (!$assumen && !$assumep) {
145    print BODY &q(<<'EOT');
146:       while ($ARGV[0] =~ /^-/) {
147:           $_ = shift;
148:         last if /^--/;
149:           if (/^-n/) {
150:               $nflag++;
151:               next;
152:           }
153:           die "I don't recognize this switch: $_\\n";
154:       }
155:       
156EOT
157}
158
159print BODY &q(<<'EOT');
160:       #ifdef PRINTIT
161:       #ifdef ASSUMEP
162:       $printit++;
163:       #else
164:       $printit++ unless $nflag;
165:       #endif
166:       #endif
167:       <><>
168:       $\ = "\n";              # automatically add newline on print
169:       <><>
170:       #ifdef TOPLABEL
171:       LINE:
172:       while (chop($_ = <>)) {
173:       #else
174:       LINE:
175:       while (<>) {
176:           chop;
177:       #endif
178EOT
179
180LINE:
181while (<>) {
182
183    # Wipe out surrounding whitespace.
184
185    s/[ \t]*(.*)\n$/$1/;
186
187    # Perhaps it's a label/comment.
188
189    if (/^:/) {
190        s/^:[ \t]*//;
191        $label = &make_label($_);
192        if ($. == 1) {
193            $toplabel = $label;
194            if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
195                $_ = <>;
196                redo LINE; # Never referenced, so delete it if not a comment.
197            }
198        }
199        $_ = "$label:";
200        if ($lastlinewaslabel++) {
201            $indent += 4;
202            print BODY &tab, ";\n";
203            $indent -= 4;
204        }
205        if ($indent >= 2) {
206            $indent -= 2;
207            $indmod = 2;
208        }
209        next;
210    } else {
211        $lastlinewaslabel = '';
212    }
213
214    # Look for one or two address clauses
215
216    $addr1 = '';
217    $addr2 = '';
218    if (s/^([0-9]+)//) {
219        $addr1 = "$1";
220        $addr1 = "\$. == $addr1" unless /^,/;
221    }
222    elsif (s/^\$//) {
223        $addr1 = 'eof()';
224    }
225    elsif (s|^/||) {
226        $addr1 = &fetchpat('/');
227    }
228    if (s/^,//) {
229        if (s/^([0-9]+)//) {
230            $addr2 = "$1";
231        } elsif (s/^\$//) {
232            $addr2 = "eof()";
233        } elsif (s|^/||) {
234            $addr2 = &fetchpat('/');
235        } else {
236            &Die("Invalid second address at line $.\n");
237        }
238        if ($addr2 =~ /^\d+$/) {
239            $addr1 .= "..$addr2";
240        }
241        else {
242            $addr1 .= "...$addr2";
243        }
244    }
245
246    # Now we check for metacommands {, }, and ! and worry
247    # about indentation.
248
249    s/^[ \t]+//;
250    # a { to keep vi happy
251    if ($_ eq '}') {
252        $indent -= 4;
253        next;
254    }
255    if (s/^!//) {
256        $if = 'unless';
257        $else = "$r else $l\n";
258    } else {
259        $if = 'if';
260        $else = '';
261    }
262    if (s/^{//) {       # a } to keep vi happy
263        $indmod = 4;
264        $redo = $_;
265        $_ = '';
266        $rmaybe = '';
267    } else {
268        $rmaybe = "\n$r";
269        if ($addr2 || $addr1) {
270            $space = ' ' x $shiftwidth;
271        } else {
272            $space = '';
273        }
274        $_ = &transmogrify();
275    }
276
277    # See if we can optimize to modifier form.
278
279    if ($addr1) {
280        if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
281          $_ !~ / if / && $_ !~ / unless /) {
282            s/;$/ $if $addr1;/;
283            $_ = substr($_,$shiftwidth,1000);
284        } else {
285            $_ = "$if ($addr1) $l\n$change$_$rmaybe";
286        }
287        $change = '';
288        next LINE;
289    }
290} continue {
291    @lines = split(/\n/,$_);
292    for (@lines) {
293        unless (s/^ *<<--//) {
294            print BODY &tab;
295        }
296        print BODY $_, "\n";
297    }
298    $indent += $indmod;
299    $indmod = 0;
300    if ($redo) {
301        $_ = $redo;
302        $redo = '';
303        redo LINE;
304    }
305}
306if ($lastlinewaslabel++) {
307    $indent += 4;
308    print BODY &tab, ";\n";
309    $indent -= 4;
310}
311
312if ($appendseen || $tseen || !$assumen) {
313    $printit++ if $dseen || (!$assumen && !$assumep);
314    print BODY &q(<<'EOT');
315:       #ifdef SAWNEXT
316:       }
317:       continue {
318:       #endif
319:       #ifdef PRINTIT
320:       #ifdef DSEEN
321:       #ifdef ASSUMEP
322:           print if $printit++;
323:       #else
324:           if ($printit)
325:               { print; }
326:           else
327:               { $printit++ unless $nflag; }
328:       #endif
329:       #else
330:           print if $printit;
331:       #endif
332:       #else
333:           print;
334:       #endif
335:       #ifdef TSEEN
336:           $tflag = 0;
337:       #endif
338:       #ifdef APPENDSEEN
339:           if ($atext) { chop $atext; print $atext; $atext = ''; }
340:       #endif
341EOT
342}
343
344print BODY &q(<<'EOT');
345:       }
346EOT
347
348unless ($debug) {
349
350    print &q(<<"EOT");
351:       $startperl
352:       eval 'exec $perlpath -S \$0 \${1+"\$@"}'
353:               if \$running_under_some_shell;
354:       
355EOT
356    print"$opens\n" if $opens;
357    seek(BODY, 0, 0) || die "Can't rewind temp file: $!\n";
358    while (<BODY>) {
359        /^[ \t]*$/ && next;
360        /^#ifdef (\w+)/ && ((${lc $1} || &skip), next);
361        /^#else/ && (&skip, next);
362        /^#endif/ && next;
363        s/^<><>//;
364        print;
365    }
366}
367
368&Cleanup;
369exit;
370
371sub Cleanup {
372    unlink "/tmp/sperl$$";
373}
374sub Die {
375    &Cleanup;
376    die $_[0];
377}
378sub tab {
379    "\t" x ($indent / 8) . ' ' x ($indent % 8);
380}
381sub make_filehandle {
382    local($_) = $_[0];
383    local($fname) = $_;
384    if (!$seen{$fname}) {
385        $_ = "FH_" . $_ if /^\d/;
386        s/[^a-zA-Z0-9]/_/g;
387        s/^_*//;
388        $_ = "\U$_";
389        if ($fhseen{$_}) {
390            for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
391            $_ .= $tmp;
392        }
393        $fhseen{$_} = 1;
394        $opens .= &q(<<"EOT");
395:       open($_, '>$fname') || die "Can't create $fname: \$!";
396EOT
397        $seen{$fname} = $_;
398    }
399    $seen{$fname};
400}
401
402sub make_label {
403    local($label) = @_;
404    $label =~ s/[^a-zA-Z0-9]/_/g;
405    if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
406    $label = substr($label,0,8);
407
408    # Could be a reserved word, so capitalize it.
409    substr($label,0,1) =~ y/a-z/A-Z/
410      if $label =~ /^[a-z]/;
411
412    $label;
413}
414
415sub transmogrify {
416    {   # case
417        if (/^d/) {
418            $dseen++;
419            chop($_ = &q(<<'EOT'));
420:       <<--#ifdef PRINTIT
421:       $printit = 0;
422:       <<--#endif
423:       next LINE;
424EOT
425            $sawnext++;
426            next;
427        }
428
429        if (/^n/) {
430            chop($_ = &q(<<'EOT'));
431:       <<--#ifdef PRINTIT
432:       <<--#ifdef DSEEN
433:       <<--#ifdef ASSUMEP
434:       print if $printit++;
435:       <<--#else
436:       if ($printit)
437:           { print; }
438:       else
439:           { $printit++ unless $nflag; }
440:       <<--#endif
441:       <<--#else
442:       print if $printit;
443:       <<--#endif
444:       <<--#else
445:       print;
446:       <<--#endif
447:       <<--#ifdef APPENDSEEN
448:       if ($atext) {chop $atext; print $atext; $atext = '';}
449:       <<--#endif
450:       $_ = <>;
451:       chop;
452:       <<--#ifdef TSEEN
453:       $tflag = 0;
454:       <<--#endif
455EOT
456            next;
457        }
458
459        if (/^a/) {
460            $appendseen++;
461            $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
462            $lastline = 0;
463            while (<>) {
464                s/^[ \t]*//;
465                s/^[\\]//;
466                unless (s|\\$||) { $lastline = 1;}
467                s/^([ \t]*\n)/<><>$1/;
468                $command .= $_;
469                $command .= '<<--';
470                last if $lastline;
471            }
472            $_ = $command . "End_Of_Text";
473            last;
474        }
475
476        if (/^[ic]/) {
477            if (/^c/) { $change = 1; }
478            $addr1 = 1 if $addr1 eq '';
479            $addr1 = '$iter = (' . $addr1 . ')';
480            $command = $space .
481              "    if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
482            $lastline = 0;
483            while (<>) {
484                s/^[ \t]*//;
485                s/^[\\]//;
486                unless (s/\\$//) { $lastline = 1;}
487                s/'/\\'/g;
488                s/^([ \t]*\n)/<><>$1/;
489                $command .= $_;
490                $command .= '<<--';
491                last if $lastline;
492            }
493            $_ = $command . "End_Of_Text";
494            if ($change) {
495                $dseen++;
496                $change = "$_\n";
497                chop($_ = &q(<<"EOT"));
498:       <<--#ifdef PRINTIT
499:       $space\$printit = 0;
500:       <<--#endif
501:       ${space}next LINE;
502EOT
503                $sawnext++;
504            }
505            last;
506        }
507
508        if (/^s/) {
509            $delim = substr($_,1,1);
510            $len = length($_);
511            $repl = $end = 0;
512            $inbracket = 0;
513            for ($i = 2; $i < $len; $i++) {
514                $c = substr($_,$i,1);
515                if ($c eq $delim) {
516                    if ($inbracket) {
517                        substr($_, $i, 0) = '\\';
518                        $i++;
519                        $len++;
520                    }
521                    else {
522                        if ($repl) {
523                            $end = $i;
524                            last;
525                        } else {
526                            $repl = $i;
527                        }
528                    }
529                }
530                elsif ($c eq '\\') {
531                    $i++;
532                    if ($i >= $len) {
533                        $_ .= 'n';
534                        $_ .= <>;
535                        $len = length($_);
536                        $_ = substr($_,0,--$len);
537                    }
538                    elsif (substr($_,$i,1) =~ /^[n]$/) {
539                        ;
540                    }
541                    elsif (!$repl &&
542                      substr($_,$i,1) =~ /^[(){}\w]$/) {
543                        $i--;
544                        $len--;
545                        substr($_, $i, 1) = '';
546                    }
547                    elsif (!$repl &&
548                      substr($_,$i,1) =~ /^[<>]$/) {
549                        substr($_,$i,1) = 'b';
550                    }
551                    elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
552                        substr($_,$i-1,1) = '$';
553                    }
554                }
555                elsif ($c eq '@') {
556                    substr($_, $i, 0) = '\\';
557                    $i++;
558                    $len++;
559                }
560                elsif ($c eq '&' && $repl) {
561                    substr($_, $i, 0) = '$';
562                    $i++;
563                    $len++;
564                }
565                elsif ($c eq '$' && $repl) {
566                    substr($_, $i, 0) = '\\';
567                    $i++;
568                    $len++;
569                }
570                elsif ($c eq '[' && !$repl) {
571                    $i++ if substr($_,$i,1) eq '^';
572                    $i++ if substr($_,$i,1) eq ']';
573                    $inbracket = 1;
574                }
575                elsif ($c eq ']') {
576                    $inbracket = 0;
577                }
578                elsif ($c eq "\t") {
579                    substr($_, $i, 1) = '\\t';
580                    $i++;
581                    $len++;
582                }
583                elsif (!$repl && index("()+",$c) >= 0) {
584                    substr($_, $i, 0) = '\\';
585                    $i++;
586                    $len++;
587                }
588            }
589            &Die("Malformed substitution at line $.\n")
590              unless $end;
591            $pat = substr($_, 0, $repl + 1);
592            $repl = substr($_, $repl+1, $end-$repl-1);
593            $end = substr($_, $end + 1, 1000);
594            &simplify($pat);
595            $subst = "$pat$repl$delim";
596            $cmd = '';
597            while ($end) {
598                if ($end =~ s/^g//) {
599                    $subst .= 'g';
600                    next;
601                }
602                if ($end =~ s/^p//) {
603                    $cmd .= ' && (print)';
604                    next;
605                }
606                if ($end =~ s/^w[ \t]*//) {
607                    $fh = &make_filehandle($end);
608                    $cmd .= " && (print $fh \$_)";
609                    $end = '';
610                    next;
611                }
612                &Die("Unrecognized substitution command".
613                  "($end) at line $.\n");
614            }
615            chop ($_ = &q(<<"EOT"));
616:       <<--#ifdef TSEEN
617:       $subst && \$tflag++$cmd;
618:       <<--#else
619:       $subst$cmd;
620:       <<--#endif
621EOT
622            next;
623        }
624
625        if (/^p/) {
626            $_ = 'print;';
627            next;
628        }
629
630        if (/^w/) {
631            s/^w[ \t]*//;
632            $fh = &make_filehandle($_);
633            $_ = "print $fh \$_;";
634            next;
635        }
636
637        if (/^r/) {
638            $appendseen++;
639            s/^r[ \t]*//;
640            $file = $_;
641            $_ = "\$atext .= `cat $file 2>/dev/null`;";
642            next;
643        }
644
645        if (/^P/) {
646            $_ = 'print $1 if /^(.*)/;';
647            next;
648        }
649
650        if (/^D/) {
651            chop($_ = &q(<<'EOT'));
652:       s/^.*\n?//;
653:       redo LINE if $_;
654:       next LINE;
655EOT
656            $sawnext++;
657            next;
658        }
659
660        if (/^N/) {
661            chop($_ = &q(<<'EOT'));
662:       $_ .= "\n";
663:       $len1 = length;
664:       $_ .= <>;
665:       chop if $len1 < length;
666:       <<--#ifdef TSEEN
667:       $tflag = 0;
668:       <<--#endif
669EOT
670            next;
671        }
672
673        if (/^h/) {
674            $_ = '$hold = $_;';
675            next;
676        }
677
678        if (/^H/) {
679            $_ = '$hold .= "\n", $hold .= $_;';
680            next;
681        }
682
683        if (/^g/) {
684            $_ = '$_ = $hold;';
685            next;
686        }
687
688        if (/^G/) {
689            $_ = '$_ .= "\n", $_ .= $hold;';
690            next;
691        }
692
693        if (/^x/) {
694            $_ = '($_, $hold) = ($hold, $_);';
695            next;
696        }
697
698        if (/^b$/) {
699            $_ = 'next LINE;';
700            $sawnext++;
701            next;
702        }
703
704        if (/^b/) {
705            s/^b[ \t]*//;
706            $lab = &make_label($_);
707            if ($lab eq $toplabel) {
708                $_ = 'redo LINE;';
709            } else {
710                $_ = "goto $lab;";
711            }
712            next;
713        }
714
715        if (/^t$/) {
716            $_ = 'next LINE if $tflag;';
717            $sawnext++;
718            $tseen++;
719            next;
720        }
721
722        if (/^t/) {
723            s/^t[ \t]*//;
724            $lab = &make_label($_);
725            $_ = q/if ($tflag) {$tflag = 0; /;
726            if ($lab eq $toplabel) {
727                $_ .= 'redo LINE;}';
728            } else {
729                $_ .= "goto $lab;}";
730            }
731            $tseen++;
732            next;
733        }
734
735        if (/^y/) {
736            s/abcdefghijklmnopqrstuvwxyz/a-z/g;
737            s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
738            s/abcdef/a-f/g;
739            s/ABCDEF/A-F/g;
740            s/0123456789/0-9/g;
741            s/01234567/0-7/g;
742            $_ .= ';';
743        }
744
745        if (/^=/) {
746            $_ = 'print $.;';
747            next;
748        }
749
750        if (/^q/) {
751            chop($_ = &q(<<'EOT'));
752:       close(ARGV);
753:       @ARGV = ();
754:       next LINE;
755EOT
756            $sawnext++;
757            next;
758        }
759    } continue {
760        if ($space) {
761            s/^/$space/;
762            s/(\n)(.)/$1$space$2/g;
763        }
764        last;
765    }
766    $_;
767}
768
769sub fetchpat {
770    local($outer) = @_;
771    local($addr) = $outer;
772    local($inbracket);
773    local($prefix,$delim,$ch);
774
775    # Process pattern one potential delimiter at a time.
776
777    DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
778        $prefix = $1;
779        $delim = $2;
780        if ($delim eq '\\') {
781            s/(.)//;
782            $ch = $1;
783            $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
784            $ch = 'b' if $ch =~ /^[<>]$/;
785            $delim .= $ch;
786        }
787        elsif ($delim eq '[') {
788            $inbracket = 1;
789            s/^\^// && ($delim .= '^');
790            s/^]// && ($delim .= ']');
791        }
792        elsif ($delim eq ']') {
793            $inbracket = 0;
794        }
795        elsif ($inbracket || $delim ne $outer) {
796            $delim = '\\' . $delim;
797        }
798        $addr .= $prefix;
799        $addr .= $delim;
800        if ($delim eq $outer && !$inbracket) {
801            last DELIM;
802        }
803    }
804    $addr =~ s/\t/\\t/g;
805    $addr =~ s/\@/\\@/g;
806    &simplify($addr);
807    $addr;
808}
809
810sub q {
811    local($string) = @_;
812    local($*) = 1;
813    $string =~ s/^:\t?//g;
814    $string;
815}
816
817sub simplify {
818    $_[0] =~ s/_a-za-z0-9/\\w/ig;
819    $_[0] =~ s/a-z_a-z0-9/\\w/ig;
820    $_[0] =~ s/a-za-z_0-9/\\w/ig;
821    $_[0] =~ s/a-za-z0-9_/\\w/ig;
822    $_[0] =~ s/_0-9a-za-z/\\w/ig;
823    $_[0] =~ s/0-9_a-za-z/\\w/ig;
824    $_[0] =~ s/0-9a-z_a-z/\\w/ig;
825    $_[0] =~ s/0-9a-za-z_/\\w/ig;
826    $_[0] =~ s/\[\\w\]/\\w/g;
827    $_[0] =~ s/\[^\\w\]/\\W/g;
828    $_[0] =~ s/\[0-9\]/\\d/g;
829    $_[0] =~ s/\[^0-9\]/\\D/g;
830    $_[0] =~ s/\\d\\d\*/\\d+/g;
831    $_[0] =~ s/\\D\\D\*/\\D+/g;
832    $_[0] =~ s/\\w\\w\*/\\w+/g;
833    $_[0] =~ s/\\t\\t\*/\\t+/g;
834    $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
835    $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
836}
837
838sub skip {
839    local($level) = 0;
840
841    while(<BODY>) {
842        /^#ifdef/ && $level++;
843        /^#else/  && !$level && return;
844        /^#endif/ && !$level-- && return;
845    }
846
847    die "Unterminated `#ifdef' conditional\n";
848}
849!NO!SUBS!
850
851close OUT or die "Can't close $file: $!";
852chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
853exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
854chdir $origdir;
Note: See TracBrowser for help on using the repository browser.