This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
a "replacement" for awk and sed
[perl5.git] / x2p / s2p
CommitLineData
8d063cd8
LW
1#!/bin/perl
2
3$indent = 4;
4$shiftwidth = 4;
5$l = '{'; $r = '}';
6$tempvar = '1';
7
8while ($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
27unless ($debug) {
28 open(body,">/tmp/sperl$$") || do Die("Can't open temp file.");
29}
30
31if (!$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
46print body '
47#ifdef PRINTIT
48#ifdef ASSUMEP
49$printit++;
50#else
51$printit++ unless $nflag;
52#endif
53#endif
54line: while (<>) {
55';
56
57line: 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
192print body "}\n";
193if ($appendseen || $tseen || !$assumen) {
194 $printit++ if $dseen || (!$assumen && !$assumep);
195 print body '
196continue {
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
220close body;
221
222unless ($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
250sub Die {
251 `/bin/rm -f /tmp/sperl$$ /tmp/sperl2$$`;
252 die $_[0];
253}
254sub 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
270sub 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
284sub transmogrify {
285 { # case
286 if (/^d/) {
287 $dseen++;
288 $_ = '
289<<--#ifdef PRINTIT
290$printit = \'\';
291<<--#endif
292next line;';
293 next;
294 }
295
296 if (/^n/) {
297 $_ =
298'<<--#ifdef PRINTIT
299<<--#ifdef DSEEN
300<<--#ifdef ASSUMEP
301print if $printit++;
302<<--#else
303if ($printit) { print;} else { $printit++ unless $nflag; }
304<<--#endif
305<<--#else
306print if $printit;
307<<--#endif
308<<--#else
309print;
310<<--#endif
311<<--#ifdef APPENDSEEN
312if ($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//;
457if ($_) {redo line;}
458next 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 = ();
539next 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