This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[ID 19990908.014] s2p does not quote @
[perl5.git] / x2p / s2p.PL
CommitLineData
4633a7c4
LW
1#!/usr/local/bin/perl
2
3use Config;
4use File::Basename qw(&basename &dirname);
8a5546a1 5use Cwd;
4633a7c4
LW
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.
8a5546a1 16$origdir = cwd;
44a8e56a
PP
17chdir dirname($0);
18$file = basename($0, '.PL');
774d564b 19$file .= '.com' if $^O eq 'VMS';
4633a7c4
LW
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!";
5f05dabc
PP
29$Config{startperl}
30 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
31 if \$running_under_some_shell;
f70b6ff5 32\$startperl = "$Config{startperl}";
5f05dabc 33\$perlpath = "$Config{perlpath}";
a687059c
LW
34!GROK!THIS!
35
4633a7c4
LW
36# In the following, perl variables are not expanded during extraction.
37
38print OUT <<'!NO!SUBS!';
a687059c 39
79072805 40# $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $
378cc40b 41#
a687059c 42# $Log: s2p.SH,v $
8d063cd8 43
d83e3bda
JM
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
55497cff 100Larry Wall E<lt>F<larry@wall.org>E<gt>
d83e3bda
JM
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
8d063cd8
LW
116$indent = 4;
117$shiftwidth = 4;
118$l = '{'; $r = '}';
8d063cd8 119
0a12ae7d 120while ($ARGV[0] =~ /^-/) {
8d063cd8
LW
121 $_ = shift;
122 last if /^--/;
123 if (/^-D/) {
124 $debug++;
0a12ae7d 125 open(BODY,'>-');
8d063cd8
LW
126 next;
127 }
128 if (/^-n/) {
129 $assumen++;
130 next;
131 }
132 if (/^-p/) {
133 $assumep++;
134 next;
135 }
378cc40b 136 die "I don't recognize this switch: $_\n";
8d063cd8
LW
137}
138
139unless ($debug) {
1aa91729 140 open(BODY,"+>/tmp/sperl$$") ||
0a12ae7d 141 &Die("Can't open temp file: $!\n");
8d063cd8
LW
142}
143
144if (!$assumen && !$assumep) {
9ef589d8
LW
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:
0a12ae7d 156EOT
8d063cd8
LW
157}
158
9ef589d8
LW
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
0a12ae7d
LW
178EOT
179
9ef589d8
LW
180LINE:
181while (<>) {
0a12ae7d
LW
182
183 # Wipe out surrounding whitespace.
8d063cd8 184
8d063cd8 185 s/[ \t]*(.*)\n$/$1/;
0a12ae7d
LW
186
187 # Perhaps it's a label/comment.
188
8d063cd8
LW
189 if (/^:/) {
190 s/^:[ \t]*//;
0a12ae7d 191 $label = &make_label($_);
8d063cd8
LW
192 if ($. == 1) {
193 $toplabel = $label;
9ef589d8
LW
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 }
8d063cd8
LW
198 }
199 $_ = "$label:";
ffed7fef
LW
200 if ($lastlinewaslabel++) {
201 $indent += 4;
0a12ae7d 202 print BODY &tab, ";\n";
ffed7fef
LW
203 $indent -= 4;
204 }
8d063cd8
LW
205 if ($indent >= 2) {
206 $indent -= 2;
207 $indmod = 2;
208 }
209 next;
210 } else {
211 $lastlinewaslabel = '';
212 }
0a12ae7d
LW
213
214 # Look for one or two address clauses
215
8d063cd8
LW
216 $addr1 = '';
217 $addr2 = '';
218 if (s/^([0-9]+)//) {
219 $addr1 = "$1";
9ef589d8 220 $addr1 = "\$. == $addr1" unless /^,/;
8d063cd8
LW
221 }
222 elsif (s/^\$//) {
223 $addr1 = 'eof()';
224 }
225 elsif (s|^/||) {
0a12ae7d 226 $addr1 = &fetchpat('/');
8d063cd8
LW
227 }
228 if (s/^,//) {
229 if (s/^([0-9]+)//) {
230 $addr2 = "$1";
231 } elsif (s/^\$//) {
232 $addr2 = "eof()";
233 } elsif (s|^/||) {
0a12ae7d 234 $addr2 = &fetchpat('/');
8d063cd8 235 } else {
0a12ae7d 236 &Die("Invalid second address at line $.\n");
8d063cd8 237 }
2b69d0c2
LW
238 if ($addr2 =~ /^\d+$/) {
239 $addr1 .= "..$addr2";
240 }
241 else {
242 $addr1 .= "...$addr2";
243 }
8d063cd8 244 }
0a12ae7d
LW
245
246 # Now we check for metacommands {, }, and ! and worry
247 # about indentation.
248
378cc40b 249 s/^[ \t]+//;
0a12ae7d 250 # a { to keep vi happy
8d063cd8
LW
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) {
a687059c 270 $space = ' ' x $shiftwidth;
8d063cd8
LW
271 } else {
272 $space = '';
273 }
0a12ae7d 274 $_ = &transmogrify();
8d063cd8
LW
275 }
276
0a12ae7d
LW
277 # See if we can optimize to modifier form.
278
8d063cd8
LW
279 if ($addr1) {
280 if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
281 $_ !~ / if / && $_ !~ / unless /) {
282 s/;$/ $if $addr1;/;
283 $_ = substr($_,$shiftwidth,1000);
284 } else {
0a12ae7d 285 $_ = "$if ($addr1) $l\n$change$_$rmaybe";
8d063cd8
LW
286 }
287 $change = '';
0a12ae7d 288 next LINE;
8d063cd8
LW
289 }
290} continue {
291 @lines = split(/\n/,$_);
0a12ae7d 292 for (@lines) {
8d063cd8 293 unless (s/^ *<<--//) {
0a12ae7d 294 print BODY &tab;
8d063cd8 295 }
0a12ae7d 296 print BODY $_, "\n";
8d063cd8
LW
297 }
298 $indent += $indmod;
299 $indmod = 0;
300 if ($redo) {
301 $_ = $redo;
302 $redo = '';
0a12ae7d 303 redo LINE;
8d063cd8
LW
304 }
305}
ffed7fef
LW
306if ($lastlinewaslabel++) {
307 $indent += 4;
0a12ae7d 308 print BODY &tab, ";\n";
ffed7fef
LW
309 $indent -= 4;
310}
8d063cd8 311
8d063cd8
LW
312if ($appendseen || $tseen || !$assumen) {
313 $printit++ if $dseen || (!$assumen && !$assumep);
9ef589d8
LW
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
a0a15abb 342}
9ef589d8
LW
343
344print BODY &q(<<'EOT');
345: }
0a12ae7d 346EOT
8d063cd8 347
8d063cd8 348unless ($debug) {
8d063cd8 349
9ef589d8 350 print &q(<<"EOT");
4633a7c4 351: $startperl
5f05dabc 352: eval 'exec $perlpath -S \$0 \${1+"\$@"}'
9ef589d8
LW
353: if \$running_under_some_shell;
354:
0a12ae7d 355EOT
1aa91729
HM
356 print"$opens\n" if $opens;
357 seek(BODY, 0, 0) || die "Can't rewind temp file: $!\n";
0a12ae7d 358 while (<BODY>) {
8d063cd8 359 /^[ \t]*$/ && next;
1aa91729
HM
360 /^#ifdef (\w+)/ && ((${lc $1} || &skip), next);
361 /^#else/ && (&skip, next);
362 /^#endif/ && next;
8d063cd8
LW
363 s/^<><>//;
364 print;
365 }
366}
367
0a12ae7d
LW
368&Cleanup;
369exit;
8d063cd8 370
0a12ae7d 371sub Cleanup {
1aa91729 372 unlink "/tmp/sperl$$";
0a12ae7d 373}
8d063cd8 374sub Die {
0a12ae7d 375 &Cleanup;
8d063cd8
LW
376 die $_[0];
377}
0a12ae7d
LW
378sub tab {
379 "\t" x ($indent / 8) . ' ' x ($indent % 8);
380}
8d063cd8 381sub make_filehandle {
0a12ae7d
LW
382 local($_) = $_[0];
383 local($fname) = $_;
9ef589d8
LW
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: \$!";
0a12ae7d 396EOT
9ef589d8 397 $seen{$fname} = $_;
8d063cd8 398 }
9ef589d8 399 $seen{$fname};
8d063cd8
LW
400}
401
402sub make_label {
0a12ae7d 403 local($label) = @_;
8d063cd8
LW
404 $label =~ s/[^a-zA-Z0-9]/_/g;
405 if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
406 $label = substr($label,0,8);
0a12ae7d
LW
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
8d063cd8
LW
412 $label;
413}
414
415sub transmogrify {
416 { # case
417 if (/^d/) {
418 $dseen++;
9ef589d8
LW
419 chop($_ = &q(<<'EOT'));
420: <<--#ifdef PRINTIT
421: $printit = 0;
422: <<--#endif
423: next LINE;
0a12ae7d 424EOT
9ef589d8 425 $sawnext++;
8d063cd8
LW
426 next;
427 }
428
429 if (/^n/) {
9ef589d8
LW
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
0a12ae7d 455EOT
8d063cd8
LW
456 next;
457 }
458
459 if (/^a/) {
460 $appendseen++;
9ef589d8 461 $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
8d063cd8
LW
462 $lastline = 0;
463 while (<>) {
464 s/^[ \t]*//;
465 s/^[\\]//;
466 unless (s|\\$||) { $lastline = 1;}
8d063cd8
LW
467 s/^([ \t]*\n)/<><>$1/;
468 $command .= $_;
469 $command .= '<<--';
470 last if $lastline;
471 }
9ef589d8 472 $_ = $command . "End_Of_Text";
8d063cd8
LW
473 last;
474 }
475
476 if (/^[ic]/) {
477 if (/^c/) { $change = 1; }
9ef589d8 478 $addr1 = 1 if $addr1 eq '';
8d063cd8 479 $addr1 = '$iter = (' . $addr1 . ')';
9ef589d8
LW
480 $command = $space .
481 " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
8d063cd8
LW
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 }
9ef589d8 493 $_ = $command . "End_Of_Text";
8d063cd8
LW
494 if ($change) {
495 $dseen++;
496 $change = "$_\n";
9ef589d8
LW
497 chop($_ = &q(<<"EOT"));
498: <<--#ifdef PRINTIT
499: $space\$printit = 0;
500: <<--#endif
501: ${space}next LINE;
0a12ae7d 502EOT
9ef589d8 503 $sawnext++;
8d063cd8
LW
504 }
505 last;
506 }
507
508 if (/^s/) {
509 $delim = substr($_,1,1);
510 $len = length($_);
511 $repl = $end = 0;
a687059c 512 $inbracket = 0;
8d063cd8
LW
513 for ($i = 2; $i < $len; $i++) {
514 $c = substr($_,$i,1);
a687059c
LW
515 if ($c eq $delim) {
516 if ($inbracket) {
0a12ae7d 517 substr($_, $i, 0) = '\\';
a687059c
LW
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 '\\') {
8d063cd8
LW
531 $i++;
532 if ($i >= $len) {
533 $_ .= 'n';
534 $_ .= <>;
535 $len = length($_);
536 $_ = substr($_,0,--$len);
537 }
00bf170e
LW
538 elsif (substr($_,$i,1) =~ /^[n]$/) {
539 ;
540 }
0a12ae7d
LW
541 elsif (!$repl &&
542 substr($_,$i,1) =~ /^[(){}\w]$/) {
8d063cd8
LW
543 $i--;
544 $len--;
0a12ae7d 545 substr($_, $i, 1) = '';
8d063cd8 546 }
0a12ae7d
LW
547 elsif (!$repl &&
548 substr($_,$i,1) =~ /^[<>]$/) {
9f68db38
LW
549 substr($_,$i,1) = 'b';
550 }
2b69d0c2
LW
551 elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
552 substr($_,$i-1,1) = '$';
553 }
554 }
c602c2ef
AD
555 elsif ($c eq '@') {
556 substr($_, $i, 0) = '\\';
557 $i++;
558 $len++;
559 }
2b69d0c2
LW
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++;
8d063cd8 569 }
a687059c
LW
570 elsif ($c eq '[' && !$repl) {
571 $i++ if substr($_,$i,1) eq '^';
572 $i++ if substr($_,$i,1) eq ']';
573 $inbracket = 1;
8d063cd8 574 }
a687059c
LW
575 elsif ($c eq ']') {
576 $inbracket = 0;
577 }
9ef589d8
LW
578 elsif ($c eq "\t") {
579 substr($_, $i, 1) = '\\t';
580 $i++;
581 $len++;
582 }
ae986130 583 elsif (!$repl && index("()+",$c) >= 0) {
0a12ae7d 584 substr($_, $i, 0) = '\\';
8d063cd8
LW
585 $i++;
586 $len++;
587 }
588 }
0a12ae7d
LW
589 &Die("Malformed substitution at line $.\n")
590 unless $end;
8d063cd8 591 $pat = substr($_, 0, $repl + 1);
0a12ae7d 592 $repl = substr($_, $repl+1, $end-$repl-1);
8d063cd8 593 $end = substr($_, $end + 1, 1000);
9ef589d8 594 &simplify($pat);
8d063cd8
LW
595 $subst = "$pat$repl$delim";
596 $cmd = '';
597 while ($end) {
0a12ae7d
LW
598 if ($end =~ s/^g//) {
599 $subst .= 'g';
600 next;
601 }
602 if ($end =~ s/^p//) {
603 $cmd .= ' && (print)';
604 next;
605 }
8d063cd8 606 if ($end =~ s/^w[ \t]*//) {
0a12ae7d 607 $fh = &make_filehandle($end);
8d063cd8
LW
608 $cmd .= " && (print $fh \$_)";
609 $end = '';
610 next;
611 }
0a12ae7d
LW
612 &Die("Unrecognized substitution command".
613 "($end) at line $.\n");
8d063cd8 614 }
9ef589d8
LW
615 chop ($_ = &q(<<"EOT"));
616: <<--#ifdef TSEEN
617: $subst && \$tflag++$cmd;
618: <<--#else
619: $subst$cmd;
620: <<--#endif
0a12ae7d 621EOT
8d063cd8
LW
622 next;
623 }
624
625 if (/^p/) {
626 $_ = 'print;';
627 next;
628 }
629
630 if (/^w/) {
631 s/^w[ \t]*//;
0a12ae7d 632 $fh = &make_filehandle($_);
8d063cd8
LW
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/) {
9ef589d8 646 $_ = 'print $1 if /^(.*)/;';
8d063cd8
LW
647 next;
648 }
649
650 if (/^D/) {
9ef589d8
LW
651 chop($_ = &q(<<'EOT'));
652: s/^.*\n?//;
653: redo LINE if $_;
654: next LINE;
0a12ae7d 655EOT
9ef589d8 656 $sawnext++;
8d063cd8
LW
657 next;
658 }
659
660 if (/^N/) {
9ef589d8
LW
661 chop($_ = &q(<<'EOT'));
662: $_ .= "\n";
663: $len1 = length;
664: $_ .= <>;
665: chop if $len1 < length;
666: <<--#ifdef TSEEN
667: $tflag = 0;
668: <<--#endif
0a12ae7d 669EOT
8d063cd8
LW
670 next;
671 }
672
673 if (/^h/) {
674 $_ = '$hold = $_;';
675 next;
676 }
677
678 if (/^H/) {
d050a71c 679 $_ = '$hold .= "\n", $hold .= $_;';
8d063cd8
LW
680 next;
681 }
682
683 if (/^g/) {
684 $_ = '$_ = $hold;';
685 next;
686 }
687
688 if (/^G/) {
d050a71c 689 $_ = '$_ .= "\n", $_ .= $hold;';
8d063cd8
LW
690 next;
691 }
692
693 if (/^x/) {
694 $_ = '($_, $hold) = ($hold, $_);';
695 next;
696 }
697
698 if (/^b$/) {
0a12ae7d 699 $_ = 'next LINE;';
9ef589d8 700 $sawnext++;
8d063cd8
LW
701 next;
702 }
703
704 if (/^b/) {
705 s/^b[ \t]*//;
0a12ae7d 706 $lab = &make_label($_);
8d063cd8 707 if ($lab eq $toplabel) {
0a12ae7d 708 $_ = 'redo LINE;';
8d063cd8
LW
709 } else {
710 $_ = "goto $lab;";
711 }
712 next;
713 }
714
715 if (/^t$/) {
0a12ae7d 716 $_ = 'next LINE if $tflag;';
9ef589d8 717 $sawnext++;
8d063cd8
LW
718 $tseen++;
719 next;
720 }
721
722 if (/^t/) {
723 s/^t[ \t]*//;
0a12ae7d 724 $lab = &make_label($_);
9ef589d8 725 $_ = q/if ($tflag) {$tflag = 0; /;
8d063cd8 726 if ($lab eq $toplabel) {
0a12ae7d 727 $_ .= 'redo LINE;}';
8d063cd8 728 } else {
0a12ae7d 729 $_ .= "goto $lab;}";
8d063cd8
LW
730 }
731 $tseen++;
732 next;
733 }
734
9ef589d8
LW
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
8d063cd8 745 if (/^=/) {
9ef589d8 746 $_ = 'print $.;';
8d063cd8
LW
747 next;
748 }
749
750 if (/^q/) {
9ef589d8
LW
751 chop($_ = &q(<<'EOT'));
752: close(ARGV);
753: @ARGV = ();
754: next LINE;
0a12ae7d 755EOT
9ef589d8 756 $sawnext++;
8d063cd8
LW
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
a687059c
LW
769sub fetchpat {
770 local($outer) = @_;
771 local($addr) = $outer;
772 local($inbracket);
773 local($prefix,$delim,$ch);
774
0a12ae7d
LW
775 # Process pattern one potential delimiter at a time.
776
777 DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
a687059c
LW
778 $prefix = $1;
779 $delim = $2;
a687059c
LW
780 if ($delim eq '\\') {
781 s/(.)//;
782 $ch = $1;
00bf170e 783 $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
9f68db38
LW
784 $ch = 'b' if $ch =~ /^[<>]$/;
785 $delim .= $ch;
a687059c
LW
786 }
787 elsif ($delim eq '[') {
788 $inbracket = 1;
789 s/^\^// && ($delim .= '^');
790 s/^]// && ($delim .= ']');
a687059c
LW
791 }
792 elsif ($delim eq ']') {
793 $inbracket = 0;
794 }
795 elsif ($inbracket || $delim ne $outer) {
a687059c
LW
796 $delim = '\\' . $delim;
797 }
798 $addr .= $prefix;
799 $addr .= $delim;
800 if ($delim eq $outer && !$inbracket) {
0a12ae7d 801 last DELIM;
a687059c
LW
802 }
803 }
9ef589d8 804 $addr =~ s/\t/\\t/g;
c602c2ef 805 $addr =~ s/\@/\\@/g;
9ef589d8 806 &simplify($addr);
a687059c
LW
807 $addr;
808}
809
9ef589d8
LW
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
1aa91729
HM
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}
a687059c 849!NO!SUBS!
4633a7c4
LW
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 ':';
8a5546a1 854chdir $origdir;