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