perl 3.0 patch #3 Patch #2 continued
[p5sagit/p5-mst-13.2.git] / x2p / s2p.SH
CommitLineData
a687059c 1: This forces SH files to create target in same directory as SH file.
2: This is so that make depend always knows where to find SH derivatives.
3case "$0" in
4*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
5esac
6case $CONFIG in
7'')
8 if test ! -f config.sh; then
9 ln ../config.sh . || \
10 ln ../../config.sh . || \
11 ln ../../../config.sh . || \
12 (echo "Can't find config.sh."; exit 1)
13 fi
14 . config.sh
15 ;;
16esac
17echo "Extracting s2p (with variable substitutions)"
18: This section of the file will have variable substitutions done on it.
19: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
20: Protect any dollar signs and backticks that you do not want interpreted
21: by putting a backslash in front. You may delete these comments.
22$spitshell >s2p <<!GROK!THIS!
23#!$bin/perl
24
25\$bin = '$bin';
26!GROK!THIS!
27
28: In the following dollars and backticks do not need the extra backslash.
29$spitshell >>s2p <<'!NO!SUBS!'
30
31# $Header: s2p.SH,v 3.0 89/10/18 15:35:02 lwall Locked $
378cc40b 32#
a687059c 33# $Log: s2p.SH,v $
34# Revision 3.0 89/10/18 15:35:02 lwall
35# 3.0 baseline
36#
37# Revision 2.0.1.1 88/07/11 23:26:23 root
38# patch2: s2p didn't put a proper prologue on output script
39#
378cc40b 40# Revision 2.0 88/06/05 00:15:55 root
41# Baseline version 2.0.
42#
43#
8d063cd8 44
45$indent = 4;
46$shiftwidth = 4;
47$l = '{'; $r = '}';
48$tempvar = '1';
49
50while ($ARGV[0] =~ '^-') {
51 $_ = shift;
52 last if /^--/;
53 if (/^-D/) {
54 $debug++;
55 open(body,'>-');
56 next;
57 }
58 if (/^-n/) {
59 $assumen++;
60 next;
61 }
62 if (/^-p/) {
63 $assumep++;
64 next;
65 }
378cc40b 66 die "I don't recognize this switch: $_\n";
8d063cd8 67}
68
69unless ($debug) {
378cc40b 70 open(body,">/tmp/sperl$$") || do Die("Can't open temp file");
8d063cd8 71}
72
73if (!$assumen && !$assumep) {
74 print body
75'while ($ARGV[0] =~ /^-/) {
76 $_ = shift;
77 last if /^--/;
78 if (/^-n/) {
79 $nflag++;
80 next;
81 }
378cc40b 82 die "I don\'t recognize this switch: $_\\n";
8d063cd8 83}
84
85';
86}
87
88print body '
89#ifdef PRINTIT
90#ifdef ASSUMEP
91$printit++;
92#else
93$printit++ unless $nflag;
94#endif
95#endif
96line: while (<>) {
97';
98
99line: while (<>) {
100 s/[ \t]*(.*)\n$/$1/;
101 if (/^:/) {
102 s/^:[ \t]*//;
103 $label = do make_label($_);
104 if ($. == 1) {
105 $toplabel = $label;
106 }
107 $_ = "$label:";
108 if ($lastlinewaslabel++) {$_ .= "\t;";}
109 if ($indent >= 2) {
110 $indent -= 2;
111 $indmod = 2;
112 }
113 next;
114 } else {
115 $lastlinewaslabel = '';
116 }
117 $addr1 = '';
118 $addr2 = '';
119 if (s/^([0-9]+)//) {
120 $addr1 = "$1";
121 }
122 elsif (s/^\$//) {
123 $addr1 = 'eof()';
124 }
125 elsif (s|^/||) {
a687059c 126 $addr1 = do fetchpat('/');
8d063cd8 127 }
128 if (s/^,//) {
129 if (s/^([0-9]+)//) {
130 $addr2 = "$1";
131 } elsif (s/^\$//) {
132 $addr2 = "eof()";
133 } elsif (s|^/||) {
a687059c 134 $addr2 = do fetchpat('/');
8d063cd8 135 } else {
378cc40b 136 do Die("Invalid second address at line $.\n");
8d063cd8 137 }
138 $addr1 .= " .. $addr2";
139 }
140 # a { to keep vi happy
378cc40b 141 s/^[ \t]+//;
8d063cd8 142 if ($_ eq '}') {
143 $indent -= 4;
144 next;
145 }
146 if (s/^!//) {
147 $if = 'unless';
148 $else = "$r else $l\n";
149 } else {
150 $if = 'if';
151 $else = '';
152 }
153 if (s/^{//) { # a } to keep vi happy
154 $indmod = 4;
155 $redo = $_;
156 $_ = '';
157 $rmaybe = '';
158 } else {
159 $rmaybe = "\n$r";
160 if ($addr2 || $addr1) {
a687059c 161 $space = ' ' x $shiftwidth;
8d063cd8 162 } else {
163 $space = '';
164 }
165 $_ = do transmogrify();
166 }
167
168 if ($addr1) {
169 if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
170 $_ !~ / if / && $_ !~ / unless /) {
171 s/;$/ $if $addr1;/;
172 $_ = substr($_,$shiftwidth,1000);
173 } else {
174 $command = $_;
175 $_ = "$if ($addr1) $l\n$change$command$rmaybe";
176 }
177 $change = '';
178 next line;
179 }
180} continue {
181 @lines = split(/\n/,$_);
182 while ($#lines >= 0) {
183 $_ = shift(lines);
184 unless (s/^ *<<--//) {
a687059c 185 print body "\t" x ($indent / 8), ' ' x ($indent % 8);
8d063cd8 186 }
187 print body $_, "\n";
188 }
189 $indent += $indmod;
190 $indmod = 0;
191 if ($redo) {
192 $_ = $redo;
193 $redo = '';
194 redo line;
195 }
196}
197
198print body "}\n";
199if ($appendseen || $tseen || !$assumen) {
200 $printit++ if $dseen || (!$assumen && !$assumep);
201 print body '
202continue {
203#ifdef PRINTIT
204#ifdef DSEEN
205#ifdef ASSUMEP
206 print if $printit++;
207#else
208 if ($printit) { print;} else { $printit++ unless $nflag; }
209#endif
210#else
211 print if $printit;
212#endif
213#else
214 print;
215#endif
216#ifdef TSEEN
217 $tflag = \'\';
218#endif
219#ifdef APPENDSEEN
220 if ($atext) { print $atext; $atext = \'\'; }
221#endif
222}
223';
224}
225
226close body;
227
228unless ($debug) {
378cc40b 229 open(head,">/tmp/sperl2$$.c") || do Die("Can't open temp file 2");
8d063cd8 230 print head "#define PRINTIT\n" if ($printit);
231 print head "#define APPENDSEEN\n" if ($appendseen);
232 print head "#define TSEEN\n" if ($tseen);
233 print head "#define DSEEN\n" if ($dseen);
234 print head "#define ASSUMEN\n" if ($assumen);
235 print head "#define ASSUMEP\n" if ($assumep);
236 if ($opens) {print head "$opens\n";}
378cc40b 237 open(body,"/tmp/sperl$$") || do Die("Can't reopen temp file");
8d063cd8 238 while (<body>) {
239 print head $_;
240 }
241 close head;
242
a687059c 243 print "#!$bin/perl
244eval \"exec $bin/perl -S \$0 \$*\"
245 if \$running_under_some_shell;
246
247";
378cc40b 248 open(body,"cc -E /tmp/sperl2$$.c |") ||
249 do Die("Can't reopen temp file");
8d063cd8 250 while (<body>) {
251 /^# [0-9]/ && next;
252 /^[ \t]*$/ && next;
253 s/^<><>//;
254 print;
255 }
256}
257
378cc40b 258unlink "/tmp/sperl$$", "/tmp/sperl2$$";
8d063cd8 259
260sub Die {
378cc40b 261 unlink "/tmp/sperl$$", "/tmp/sperl2$$";
8d063cd8 262 die $_[0];
263}
264sub make_filehandle {
265 $fname = $_ = $_[0];
266 s/[^a-zA-Z]/_/g;
267 s/^_*//;
268 if (/^([a-z])([a-z]*)$/) {
269 $first = $1;
270 $rest = $2;
271 $first =~ y/a-z/A-Z/;
272 $_ = $first . $rest;
273 }
274 if (!$seen{$_}) {
378cc40b 275 $opens .= "open($_,'>$fname') || die \"Can't create $fname\";\n";
8d063cd8 276 }
277 $seen{$_} = $_;
278}
279
280sub make_label {
281 $label = $_[0];
282 $label =~ s/[^a-zA-Z0-9]/_/g;
283 if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
284 $label = substr($label,0,8);
a687059c 285 if ($label =~ /^([a-z])([a-z]*)$/) { # could be reserved word
8d063cd8 286 $first = $1;
287 $rest = $2;
a687059c 288 $first =~ y/a-z/A-Z/; # so capitalize it
8d063cd8 289 $label = $first . $rest;
290 }
291 $label;
292}
293
294sub transmogrify {
295 { # case
296 if (/^d/) {
297 $dseen++;
298 $_ = '
299<<--#ifdef PRINTIT
300$printit = \'\';
301<<--#endif
302next line;';
303 next;
304 }
305
306 if (/^n/) {
307 $_ =
308'<<--#ifdef PRINTIT
309<<--#ifdef DSEEN
310<<--#ifdef ASSUMEP
311print if $printit++;
312<<--#else
313if ($printit) { print;} else { $printit++ unless $nflag; }
314<<--#endif
315<<--#else
316print if $printit;
317<<--#endif
318<<--#else
319print;
320<<--#endif
321<<--#ifdef APPENDSEEN
322if ($atext) {print $atext; $atext = \'\';}
323<<--#endif
324$_ = <>;
325<<--#ifdef TSEEN
326$tflag = \'\';
327<<--#endif';
328 next;
329 }
330
331 if (/^a/) {
332 $appendseen++;
333 $command = $space . '$atext .=' . "\n<<--'";
334 $lastline = 0;
335 while (<>) {
336 s/^[ \t]*//;
337 s/^[\\]//;
338 unless (s|\\$||) { $lastline = 1;}
339 s/'/\\'/g;
340 s/^([ \t]*\n)/<><>$1/;
341 $command .= $_;
342 $command .= '<<--';
343 last if $lastline;
344 }
345 $_ = $command . "';";
346 last;
347 }
348
349 if (/^[ic]/) {
350 if (/^c/) { $change = 1; }
351 $addr1 = '$iter = (' . $addr1 . ')';
352 $command = $space . 'if ($iter == 1) { print' . "\n<<--'";
353 $lastline = 0;
354 while (<>) {
355 s/^[ \t]*//;
356 s/^[\\]//;
357 unless (s/\\$//) { $lastline = 1;}
358 s/'/\\'/g;
359 s/^([ \t]*\n)/<><>$1/;
360 $command .= $_;
361 $command .= '<<--';
362 last if $lastline;
363 }
364 $_ = $command . "';}";
365 if ($change) {
366 $dseen++;
367 $change = "$_\n";
368 $_ = "
369<<--#ifdef PRINTIT
370$space\$printit = '';
371<<--#endif
372${space}next line;";
373 }
374 last;
375 }
376
377 if (/^s/) {
378 $delim = substr($_,1,1);
379 $len = length($_);
380 $repl = $end = 0;
a687059c 381 $inbracket = 0;
8d063cd8 382 for ($i = 2; $i < $len; $i++) {
383 $c = substr($_,$i,1);
a687059c 384 if ($c eq $delim) {
385 if ($inbracket) {
386 $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000);
387 $i++;
388 $len++;
389 }
390 else {
391 if ($repl) {
392 $end = $i;
393 last;
394 } else {
395 $repl = $i;
396 }
397 }
398 }
399 elsif ($c eq '\\') {
8d063cd8 400 $i++;
401 if ($i >= $len) {
402 $_ .= 'n';
403 $_ .= <>;
404 $len = length($_);
405 $_ = substr($_,0,--$len);
406 }
a687059c 407 elsif (!$repl && substr($_,$i,1) =~ /^[(){}\w]$/) {
8d063cd8 408 $i--;
409 $len--;
410 $_ = substr($_,0,$i) . substr($_,$i+1,10000);
411 }
412 }
a687059c 413 elsif ($c eq '[' && !$repl) {
414 $i++ if substr($_,$i,1) eq '^';
415 $i++ if substr($_,$i,1) eq ']';
416 $inbracket = 1;
8d063cd8 417 }
a687059c 418 elsif ($c eq ']') {
419 $inbracket = 0;
420 }
421 elsif (!$repl && index("()",$c) >= 0) {
8d063cd8 422 $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000);
423 $i++;
424 $len++;
425 }
426 }
378cc40b 427 do Die("Malformed substitution at line $.\n") unless $end;
8d063cd8 428 $pat = substr($_, 0, $repl + 1);
429 $repl = substr($_, $repl + 1, $end - $repl - 1);
430 $end = substr($_, $end + 1, 1000);
431 $dol = '$';
378cc40b 432 $repl =~ s/\$/\\$/;
8d063cd8 433 $repl =~ s'&'$&'g;
434 $repl =~ s/[\\]([0-9])/$dol$1/g;
435 $subst = "$pat$repl$delim";
436 $cmd = '';
437 while ($end) {
438 if ($end =~ s/^g//) { $subst .= 'g'; next; }
439 if ($end =~ s/^p//) { $cmd .= ' && (print)'; next; }
440 if ($end =~ s/^w[ \t]*//) {
441 $fh = do make_filehandle($end);
442 $cmd .= " && (print $fh \$_)";
443 $end = '';
444 next;
445 }
378cc40b 446 do Die("Unrecognized substitution command ($end) at line $.\n");
8d063cd8 447 }
a687059c 448 $_ =
449"<<--#ifdef TSEEN
450$subst && \$tflag++$cmd;
451<<--#else
452$subst$cmd;
453<<--#endif";
8d063cd8 454 next;
455 }
456
457 if (/^p/) {
458 $_ = 'print;';
459 next;
460 }
461
462 if (/^w/) {
463 s/^w[ \t]*//;
464 $fh = do make_filehandle($_);
465 $_ = "print $fh \$_;";
466 next;
467 }
468
469 if (/^r/) {
470 $appendseen++;
471 s/^r[ \t]*//;
472 $file = $_;
473 $_ = "\$atext .= `cat $file 2>/dev/null`;";
474 next;
475 }
476
477 if (/^P/) {
a687059c 478 $_ = 'print $1 if /(^.*\n)/;';
8d063cd8 479 next;
480 }
481
482 if (/^D/) {
483 $_ =
a687059c 484's/^.*\n//;
485redo line if $_;
8d063cd8 486next line;';
487 next;
488 }
489
490 if (/^N/) {
491 $_ = '
492$_ .= <>;
493<<--#ifdef TSEEN
494$tflag = \'\';
495<<--#endif';
496 next;
497 }
498
499 if (/^h/) {
500 $_ = '$hold = $_;';
501 next;
502 }
503
504 if (/^H/) {
505 $_ = '$hold .= $_ ? $_ : "\n";';
506 next;
507 }
508
509 if (/^g/) {
510 $_ = '$_ = $hold;';
511 next;
512 }
513
514 if (/^G/) {
515 $_ = '$_ .= $hold ? $hold : "\n";';
516 next;
517 }
518
519 if (/^x/) {
520 $_ = '($_, $hold) = ($hold, $_);';
521 next;
522 }
523
524 if (/^b$/) {
525 $_ = 'next line;';
526 next;
527 }
528
529 if (/^b/) {
530 s/^b[ \t]*//;
531 $lab = do make_label($_);
532 if ($lab eq $toplabel) {
533 $_ = 'redo line;';
534 } else {
535 $_ = "goto $lab;";
536 }
537 next;
538 }
539
540 if (/^t$/) {
541 $_ = 'next line if $tflag;';
542 $tseen++;
543 next;
544 }
545
546 if (/^t/) {
547 s/^t[ \t]*//;
548 $lab = do make_label($_);
549 if ($lab eq $toplabel) {
550 $_ = 'if ($tflag) {$tflag = \'\'; redo line;}';
551 } else {
552 $_ = "if (\$tflag) {\$tflag = ''; goto $lab;}";
553 }
554 $tseen++;
555 next;
556 }
557
558 if (/^=/) {
559 $_ = 'print "$.\n";';
560 next;
561 }
562
563 if (/^q/) {
564 $_ =
565'close(ARGV);
566@ARGV = ();
567next line;';
568 next;
569 }
570 } continue {
571 if ($space) {
572 s/^/$space/;
573 s/(\n)(.)/$1$space$2/g;
574 }
575 last;
576 }
577 $_;
578}
579
a687059c 580sub fetchpat {
581 local($outer) = @_;
582 local($addr) = $outer;
583 local($inbracket);
584 local($prefix,$delim,$ch);
585
586 delim: while (s:^([^\](|)[\\/]*)([](|)[\\/])::) {
587 $prefix = $1;
588 $delim = $2;
589 print "$prefix\t$delim\t$_\n";
590 if ($delim eq '\\') {
591 s/(.)//;
592 $ch = $1;
593 $delim = '' if $ch =~ /^[(){}\w]$/;
594 $delim .= $1;
595 }
596 elsif ($delim eq '[') {
597 $inbracket = 1;
598 s/^\^// && ($delim .= '^');
599 s/^]// && ($delim .= ']');
600 print "$prefix\t$delim\t$_\n";
601 }
602 elsif ($delim eq ']') {
603 $inbracket = 0;
604 }
605 elsif ($inbracket || $delim ne $outer) {
606 print "Adding\n";
607 $delim = '\\' . $delim;
608 }
609 $addr .= $prefix;
610 $addr .= $delim;
611 if ($delim eq $outer && !$inbracket) {
612 last delim;
613 }
614 }
615 $addr;
616}
617
618!NO!SUBS!
619chmod 755 s2p
620$eunicefix s2p