a "replacement" for awk and sed
[perl.git] / x2p / s2p
1 #!/bin/perl
2
3 $indent = 4;
4 $shiftwidth = 4;
5 $l = '{'; $r = '}';
6 $tempvar = '1';
7
8 while ($ARGV[0] =~ '^-') {
9     $_ = shift;
10   last if /^--/;
11     if (/^-D/) {
12         $debug++;
13         open(body,'>-');
14         next;
15     }
16     if (/^-n/) {
17         $assumen++;
18         next;
19     }
20     if (/^-p/) {
21         $assumep++;
22         next;
23     }
24     die "I don't recognize this switch: $_";
25 }
26
27 unless ($debug) {
28     open(body,">/tmp/sperl$$") || do Die("Can't open temp file.");
29 }
30
31 if (!$assumen && !$assumep) {
32     print body
33 'while ($ARGV[0] =~ /^-/) {
34     $_ = shift;
35   last if /^--/;
36     if (/^-n/) {
37         $nflag++;
38         next;
39     }
40     die "I don\'t recognize this switch: $_";
41 }
42
43 ';
44 }
45
46 print body '
47 #ifdef PRINTIT
48 #ifdef ASSUMEP
49 $printit++;
50 #else
51 $printit++ unless $nflag;
52 #endif
53 #endif
54 line: while (<>) {
55 ';
56
57 line: while (<>) {
58     s/[ \t]*(.*)\n$/$1/;
59     if (/^:/) {
60         s/^:[ \t]*//;
61         $label = do make_label($_);
62         if ($. == 1) {
63             $toplabel = $label;
64         }
65         $_ = "$label:";
66         if ($lastlinewaslabel++) {$_ .= "\t;";}
67         if ($indent >= 2) {
68             $indent -= 2;
69             $indmod = 2;
70         }
71         next;
72     } else {
73         $lastlinewaslabel = '';
74     }
75     $addr1 = '';
76     $addr2 = '';
77     if (s/^([0-9]+)//) {
78         $addr1 = "$1";
79     }
80     elsif (s/^\$//) {
81         $addr1 = 'eof()';
82     }
83     elsif (s|^/||) {
84         $addr1 = '/';
85         delim: while (s:^([^(|)\\/]*)([(|)\\/])::) {
86             $prefix = $1;
87             $delim = $2;
88             if ($delim eq '\\') {
89                 s/(.)(.*)/$2/;
90                 $ch = $1;
91                 $delim = '' if index("(|)",$ch) >= 0;
92                 $delim .= $1;
93             }
94             elsif ($delim ne '/') {
95                 $delim = '\\' . $delim;
96             }
97             $addr1 .= $prefix;
98             $addr1 .= $delim;
99             if ($delim eq '/') {
100                 last delim;
101             }
102         }
103     }
104     if (s/^,//) {
105         if (s/^([0-9]+)//) {
106             $addr2 = "$1";
107         } elsif (s/^\$//) {
108             $addr2 = "eof()";
109         } elsif (s|^/||) {
110             $addr2 = '/';
111             delim: while (s:^([^(|)\\/]*)([(|)\\/])::) {
112                 $prefix = $1;
113                 $delim = $2;
114                 if ($delim eq '\\') {
115                     s/(.)(.*)/$2/;
116                     $ch = $1;
117                     $delim = '' if index("(|)",$ch) >= 0;
118                     $delim .= $1;
119                 }
120                 elsif ($delim ne '/') {
121                     $delim = '\\' . $delim;
122                 }
123                 $addr2 .= $prefix;
124                 $addr2 .= $delim;
125                 if ($delim eq '/') {
126                     last delim;
127                 }
128             }
129         } else {
130             do Die("Invalid second address at line $.: $_");
131         }
132         $addr1 .= " .. $addr2";
133     }
134                                         # a { to keep vi happy
135     if ($_ eq '}') {
136         $indent -= 4;
137         next;
138     }
139     if (s/^!//) {
140         $if = 'unless';
141         $else = "$r else $l\n";
142     } else {
143         $if = 'if';
144         $else = '';
145     }
146     if (s/^{//) {       # a } to keep vi happy
147         $indmod = 4;
148         $redo = $_;
149         $_ = '';
150         $rmaybe = '';
151     } else {
152         $rmaybe = "\n$r";
153         if ($addr2 || $addr1) {
154             $space = substr('        ',0,$shiftwidth);
155         } else {
156             $space = '';
157         }
158         $_ = do transmogrify();
159     }
160
161     if ($addr1) {
162         if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
163           $_ !~ / if / && $_ !~ / unless /) {
164             s/;$/ $if $addr1;/;
165             $_ = substr($_,$shiftwidth,1000);
166         } else {
167             $command = $_;
168             $_ = "$if ($addr1) $l\n$change$command$rmaybe";
169         }
170         $change = '';
171         next line;
172     }
173 } continue {
174     @lines = split(/\n/,$_);
175     while ($#lines >= 0) {
176         $_ = shift(lines);
177         unless (s/^ *<<--//) {
178             print body substr("\t\t\t\t\t\t\t\t\t\t\t\t",0,$indent / 8),
179                 substr('        ',0,$indent % 8);
180         }
181         print body $_, "\n";
182     }
183     $indent += $indmod;
184     $indmod = 0;
185     if ($redo) {
186         $_ = $redo;
187         $redo = '';
188         redo line;
189     }
190 }
191
192 print body "}\n";
193 if ($appendseen || $tseen || !$assumen) {
194     $printit++ if $dseen || (!$assumen && !$assumep);
195     print body '
196 continue {
197 #ifdef PRINTIT
198 #ifdef DSEEN
199 #ifdef ASSUMEP
200     print if $printit++;
201 #else
202     if ($printit) { print;} else { $printit++ unless $nflag; }
203 #endif
204 #else
205     print if $printit;
206 #endif
207 #else
208     print;
209 #endif
210 #ifdef TSEEN
211     $tflag = \'\';
212 #endif
213 #ifdef APPENDSEEN
214     if ($atext) { print $atext; $atext = \'\'; }
215 #endif
216 }
217 ';
218 }
219
220 close body;
221
222 unless ($debug) {
223     open(head,">/tmp/sperl2$$") || do Die("Can't open temp file 2.\n");
224     print head "#define PRINTIT\n" if ($printit);
225     print head "#define APPENDSEEN\n" if ($appendseen);
226     print head "#define TSEEN\n" if ($tseen);
227     print head "#define DSEEN\n" if ($dseen);
228     print head "#define ASSUMEN\n" if ($assumen);
229     print head "#define ASSUMEP\n" if ($assumep);
230     if ($opens) {print head "$opens\n";}
231     open(body,"/tmp/sperl$$") || do Die("Can't reopen temp file.");
232     while (<body>) {
233         print head $_;
234     }
235     close head;
236
237     print "#!/bin/perl\n\n";
238     open(body,"cc -E /tmp/sperl2$$ |") ||
239         do Die("Can't reopen temp file.");
240     while (<body>) {
241         /^# [0-9]/ && next;
242         /^[ \t]*$/ && next;
243         s/^<><>//;
244         print;
245     }
246 }
247
248 `/bin/rm -f /tmp/sperl$$ /tmp/sperl2$$`;
249
250 sub Die {
251     `/bin/rm -f /tmp/sperl$$ /tmp/sperl2$$`;
252     die $_[0];
253 }
254 sub make_filehandle {
255     $fname = $_ = $_[0];
256     s/[^a-zA-Z]/_/g;
257     s/^_*//;
258     if (/^([a-z])([a-z]*)$/) {
259         $first = $1;
260         $rest = $2;
261         $first =~ y/a-z/A-Z/;
262         $_ = $first . $rest;
263     }
264     if (!$seen{$_}) {
265         $opens .= "open($_,'>$fname') || die \"Can't create $fname.\";\n";
266     }
267     $seen{$_} = $_;
268 }
269
270 sub make_label {
271     $label = $_[0];
272     $label =~ s/[^a-zA-Z0-9]/_/g;
273     if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
274     $label = substr($label,0,8);
275     if ($label =~ /^([a-z])([a-z]*)$/) {
276         $first = $1;
277         $rest = $2;
278         $first =~ y/a-z/A-Z/;
279         $label = $first . $rest;
280     }
281     $label;
282 }
283
284 sub transmogrify {
285     {   # case
286         if (/^d/) {
287             $dseen++;
288             $_ = '
289 <<--#ifdef PRINTIT
290 $printit = \'\';
291 <<--#endif
292 next line;';
293             next;
294         }
295
296         if (/^n/) {
297             $_ =
298 '<<--#ifdef PRINTIT
299 <<--#ifdef DSEEN
300 <<--#ifdef ASSUMEP
301 print if $printit++;
302 <<--#else
303 if ($printit) { print;} else { $printit++ unless $nflag; }
304 <<--#endif
305 <<--#else
306 print if $printit;
307 <<--#endif
308 <<--#else
309 print;
310 <<--#endif
311 <<--#ifdef APPENDSEEN
312 if ($atext) {print $atext; $atext = \'\';}
313 <<--#endif
314 $_ = <>;
315 <<--#ifdef TSEEN
316 $tflag = \'\';
317 <<--#endif';
318             next;
319         }
320
321         if (/^a/) {
322             $appendseen++;
323             $command = $space .  '$atext .=' . "\n<<--'";
324             $lastline = 0;
325             while (<>) {
326                 s/^[ \t]*//;
327                 s/^[\\]//;
328                 unless (s|\\$||) { $lastline = 1;}
329                 s/'/\\'/g;
330                 s/^([ \t]*\n)/<><>$1/;
331                 $command .= $_;
332                 $command .= '<<--';
333                 last if $lastline;
334             }
335             $_ = $command . "';";
336             last;
337         }
338
339         if (/^[ic]/) {
340             if (/^c/) { $change = 1; }
341             $addr1 = '$iter = (' . $addr1 . ')';
342             $command = $space .  'if ($iter == 1) { print' . "\n<<--'";
343             $lastline = 0;
344             while (<>) {
345                 s/^[ \t]*//;
346                 s/^[\\]//;
347                 unless (s/\\$//) { $lastline = 1;}
348                 s/'/\\'/g;
349                 s/^([ \t]*\n)/<><>$1/;
350                 $command .= $_;
351                 $command .= '<<--';
352                 last if $lastline;
353             }
354             $_ = $command . "';}";
355             if ($change) {
356                 $dseen++;
357                 $change = "$_\n";
358                 $_ = "
359 <<--#ifdef PRINTIT
360 $space\$printit = '';
361 <<--#endif
362 ${space}next line;";
363             }
364             last;
365         }
366
367         if (/^s/) {
368             $delim = substr($_,1,1);
369             $len = length($_);
370             $repl = $end = 0;
371             for ($i = 2; $i < $len; $i++) {
372                 $c = substr($_,$i,1);
373                 if ($c eq '\\') {
374                     $i++;
375                     if ($i >= $len) {
376                         $_ .= 'n';
377                         $_ .= <>;
378                         $len = length($_);
379                         $_ = substr($_,0,--$len);
380                     }
381                     elsif (!$repl && index("(|)",substr($_,$i,1)) >= 0) {
382                         $i--;
383                         $len--;
384                         $_ = substr($_,0,$i) . substr($_,$i+1,10000);
385                     }
386                 }
387                 elsif ($c eq $delim) {
388                     if ($repl) {
389                         $end = $i;
390                         last;
391                     } else {
392                         $repl = $i;
393                     }
394                 }
395                 elsif (!$repl && index("(|)",$c) >= 0) {
396                     $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000);
397                     $i++;
398                     $len++;
399                 }
400             }
401             print "repl $repl end $end $_\n";
402             do Die("Malformed substitution at line $.") unless $end;
403             $pat = substr($_, 0, $repl + 1);
404             $repl = substr($_, $repl + 1, $end - $repl - 1);
405             $end = substr($_, $end + 1, 1000);
406             $dol = '$';
407             $repl =~ s'&'$&'g;
408             $repl =~ s/[\\]([0-9])/$dol$1/g;
409             $subst = "$pat$repl$delim";
410             $cmd = '';
411             while ($end) {
412                 if ($end =~ s/^g//) { $subst .= 'g'; next; }
413                 if ($end =~ s/^p//) { $cmd .= ' && (print)'; next; }
414                 if ($end =~ s/^w[ \t]*//) {
415                     $fh = do make_filehandle($end);
416                     $cmd .= " && (print $fh \$_)";
417                     $end = '';
418                     next;
419                 }
420                 do Die("Unrecognized substitution command ($end) at line $.");
421             }
422             $_ = $subst . $cmd . ';';
423             next;
424         }
425
426         if (/^p/) {
427             $_ = 'print;';
428             next;
429         }
430
431         if (/^w/) {
432             s/^w[ \t]*//;
433             $fh = do make_filehandle($_);
434             $_ = "print $fh \$_;";
435             next;
436         }
437
438         if (/^r/) {
439             $appendseen++;
440             s/^r[ \t]*//;
441             $file = $_;
442             $_ = "\$atext .= `cat $file 2>/dev/null`;";
443             next;
444         }
445
446         if (/^P/) {
447             $_ =
448 'if (/(^[^\n]*\n)/) {
449     print $1;
450 }';
451             next;
452         }
453
454         if (/^D/) {
455             $_ =
456 's/^[^\n]*\n//;
457 if ($_) {redo line;}
458 next line;';
459             next;
460         }
461
462         if (/^N/) {
463             $_ = '
464 $_ .= <>;
465 <<--#ifdef TSEEN
466 $tflag = \'\';
467 <<--#endif';
468             next;
469         }
470
471         if (/^h/) {
472             $_ = '$hold = $_;';
473             next;
474         }
475
476         if (/^H/) {
477             $_ = '$hold .= $_ ? $_ : "\n";';
478             next;
479         }
480
481         if (/^g/) {
482             $_ = '$_ = $hold;';
483             next;
484         }
485
486         if (/^G/) {
487             $_ = '$_ .= $hold ? $hold : "\n";';
488             next;
489         }
490
491         if (/^x/) {
492             $_ = '($_, $hold) = ($hold, $_);';
493             next;
494         }
495
496         if (/^b$/) {
497             $_ = 'next line;';
498             next;
499         }
500
501         if (/^b/) {
502             s/^b[ \t]*//;
503             $lab = do make_label($_);
504             if ($lab eq $toplabel) {
505                 $_ = 'redo line;';
506             } else {
507                 $_ = "goto $lab;";
508             }
509             next;
510         }
511
512         if (/^t$/) {
513             $_ = 'next line if $tflag;';
514             $tseen++;
515             next;
516         }
517
518         if (/^t/) {
519             s/^t[ \t]*//;
520             $lab = do make_label($_);
521             if ($lab eq $toplabel) {
522                 $_ = 'if ($tflag) {$tflag = \'\'; redo line;}';
523             } else {
524                 $_ = "if (\$tflag) {\$tflag = ''; goto $lab;}";
525             }
526             $tseen++;
527             next;
528         }
529
530         if (/^=/) {
531             $_ = 'print "$.\n";';
532             next;
533         }
534
535         if (/^q/) {
536             $_ =
537 'close(ARGV);
538 @ARGV = ();
539 next line;';
540             next;
541         }
542     } continue {
543         if ($space) {
544             s/^/$space/;
545             s/(\n)(.)/$1$space$2/g;
546         }
547         last;
548     }
549     $_;
550 }
551