Fix a2p translation of '{print "a" "b" "c"}'
[p5sagit/p5-mst-13.2.git] / x2p / s2p.PL
CommitLineData
4633a7c4 1#!/usr/local/bin/perl
2
3use Config;
4use File::Basename qw(&basename &dirname);
5
6# List explicitly here the variables you want Configure to
7# generate. Metaconfig only looks for shell variables, so you
8# have to mention them as if they were shell variables, not
9# %Config entries. Thus you write
10# $startperl
11# to ensure Configure will look for $Config{startperl}.
12
13# This forces PL files to create target in same directory as PL file.
14# This is so that make depend always knows where to find PL derivatives.
15chdir(dirname($0));
16($file = basename($0)) =~ s/\.PL$//;
17$file =~ s/\.pl$//
f360dba1 18 if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
4633a7c4 19
20open OUT,">$file" or die "Can't create $file: $!";
21
22print "Extracting $file (with variable substitutions)\n";
23
24# In this section, perl variables will be expanded during extraction.
25# You can use $Config{...} to use Configure variables.
26
27print OUT <<"!GROK!THIS!";
28$Config{'startperl'}
29 eval 'exec perl -S \$0 "\$@"'
30 if 0;
f70b6ff5 31\$startperl = "$Config{startperl}";
a687059c 32!GROK!THIS!
33
4633a7c4 34# In the following, perl variables are not expanded during extraction.
35
36print OUT <<'!NO!SUBS!';
a687059c 37
79072805 38# $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $
378cc40b 39#
a687059c 40# $Log: s2p.SH,v $
8d063cd8 41
d83e3bda 42=head1 NAME
43
44s2p - Sed to Perl translator
45
46=head1 SYNOPSIS
47
48B<s2p [options] filename>
49
50=head1 DESCRIPTION
51
52I<S2p> takes a sed script specified on the command line (or from
53standard input) and produces a comparable I<perl> script on the
54standard output.
55
56=head2 Options
57
58Options include:
59
60=over 5
61
62=item B<-DE<lt>numberE<gt>>
63
64sets debugging flags.
65
66=item B<-n>
67
68specifies that this sed script was always invoked with a B<sed -n>.
69Otherwise a switch parser is prepended to the front of the script.
70
71=item B<-p>
72
73specifies that this sed script was never invoked with a B<sed -n>.
74Otherwise a switch parser is prepended to the front of the script.
75
76=back
77
78=head2 Considerations
79
80The perl script produced looks very sed-ish, and there may very well
81be better ways to express what you want to do in perl. For instance,
82s2p does not make any use of the split operator, but you might want
83to.
84
85The perl script you end up with may be either faster or slower than
86the original sed script. If you're only interested in speed you'll
87just have to try it both ways. Of course, if you want to do something
88sed doesn't do, you have no choice. It's often possible to speed up
89the perl script by various methods, such as deleting all references to
90$\ and chop.
91
92=head1 ENVIRONMENT
93
94S2p uses no environment variables.
95
96=head1 AUTHOR
97
98Larry Wall E<lt>F<lwall@jpl-devvax.Jpl.Nasa.Gov>E<gt>
99
100=head1 FILES
101
102=head1 SEE ALSO
103
104 perl The perl compiler/interpreter
105
106 a2p awk to perl translator
107
108=head1 DIAGNOSTICS
109
110=head1 BUGS
111
112=cut
113
8d063cd8 114$indent = 4;
115$shiftwidth = 4;
116$l = '{'; $r = '}';
8d063cd8 117
0a12ae7d 118while ($ARGV[0] =~ /^-/) {
8d063cd8 119 $_ = shift;
120 last if /^--/;
121 if (/^-D/) {
122 $debug++;
0a12ae7d 123 open(BODY,'>-');
8d063cd8 124 next;
125 }
126 if (/^-n/) {
127 $assumen++;
128 next;
129 }
130 if (/^-p/) {
131 $assumep++;
132 next;
133 }
378cc40b 134 die "I don't recognize this switch: $_\n";
8d063cd8 135}
136
137unless ($debug) {
0a12ae7d 138 open(BODY,">/tmp/sperl$$") ||
139 &Die("Can't open temp file: $!\n");
8d063cd8 140}
141
142if (!$assumen && !$assumep) {
9ef589d8 143 print BODY &q(<<'EOT');
144: while ($ARGV[0] =~ /^-/) {
145: $_ = shift;
146: last if /^--/;
147: if (/^-n/) {
148: $nflag++;
149: next;
150: }
151: die "I don't recognize this switch: $_\\n";
152: }
153:
0a12ae7d 154EOT
8d063cd8 155}
156
9ef589d8 157print BODY &q(<<'EOT');
158: #ifdef PRINTIT
159: #ifdef ASSUMEP
160: $printit++;
161: #else
162: $printit++ unless $nflag;
163: #endif
164: #endif
165: <><>
166: $\ = "\n"; # automatically add newline on print
167: <><>
168: #ifdef TOPLABEL
169: LINE:
170: while (chop($_ = <>)) {
171: #else
172: LINE:
173: while (<>) {
174: chop;
175: #endif
0a12ae7d 176EOT
177
9ef589d8 178LINE:
179while (<>) {
0a12ae7d 180
181 # Wipe out surrounding whitespace.
8d063cd8 182
8d063cd8 183 s/[ \t]*(.*)\n$/$1/;
0a12ae7d 184
185 # Perhaps it's a label/comment.
186
8d063cd8 187 if (/^:/) {
188 s/^:[ \t]*//;
0a12ae7d 189 $label = &make_label($_);
8d063cd8 190 if ($. == 1) {
191 $toplabel = $label;
9ef589d8 192 if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
193 $_ = <>;
194 redo LINE; # Never referenced, so delete it if not a comment.
195 }
8d063cd8 196 }
197 $_ = "$label:";
ffed7fef 198 if ($lastlinewaslabel++) {
199 $indent += 4;
0a12ae7d 200 print BODY &tab, ";\n";
ffed7fef 201 $indent -= 4;
202 }
8d063cd8 203 if ($indent >= 2) {
204 $indent -= 2;
205 $indmod = 2;
206 }
207 next;
208 } else {
209 $lastlinewaslabel = '';
210 }
0a12ae7d 211
212 # Look for one or two address clauses
213
8d063cd8 214 $addr1 = '';
215 $addr2 = '';
216 if (s/^([0-9]+)//) {
217 $addr1 = "$1";
9ef589d8 218 $addr1 = "\$. == $addr1" unless /^,/;
8d063cd8 219 }
220 elsif (s/^\$//) {
221 $addr1 = 'eof()';
222 }
223 elsif (s|^/||) {
0a12ae7d 224 $addr1 = &fetchpat('/');
8d063cd8 225 }
226 if (s/^,//) {
227 if (s/^([0-9]+)//) {
228 $addr2 = "$1";
229 } elsif (s/^\$//) {
230 $addr2 = "eof()";
231 } elsif (s|^/||) {
0a12ae7d 232 $addr2 = &fetchpat('/');
8d063cd8 233 } else {
0a12ae7d 234 &Die("Invalid second address at line $.\n");
8d063cd8 235 }
2b69d0c2 236 if ($addr2 =~ /^\d+$/) {
237 $addr1 .= "..$addr2";
238 }
239 else {
240 $addr1 .= "...$addr2";
241 }
8d063cd8 242 }
0a12ae7d 243
244 # Now we check for metacommands {, }, and ! and worry
245 # about indentation.
246
378cc40b 247 s/^[ \t]+//;
0a12ae7d 248 # a { to keep vi happy
8d063cd8 249 if ($_ eq '}') {
250 $indent -= 4;
251 next;
252 }
253 if (s/^!//) {
254 $if = 'unless';
255 $else = "$r else $l\n";
256 } else {
257 $if = 'if';
258 $else = '';
259 }
260 if (s/^{//) { # a } to keep vi happy
261 $indmod = 4;
262 $redo = $_;
263 $_ = '';
264 $rmaybe = '';
265 } else {
266 $rmaybe = "\n$r";
267 if ($addr2 || $addr1) {
a687059c 268 $space = ' ' x $shiftwidth;
8d063cd8 269 } else {
270 $space = '';
271 }
0a12ae7d 272 $_ = &transmogrify();
8d063cd8 273 }
274
0a12ae7d 275 # See if we can optimize to modifier form.
276
8d063cd8 277 if ($addr1) {
278 if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
279 $_ !~ / if / && $_ !~ / unless /) {
280 s/;$/ $if $addr1;/;
281 $_ = substr($_,$shiftwidth,1000);
282 } else {
0a12ae7d 283 $_ = "$if ($addr1) $l\n$change$_$rmaybe";
8d063cd8 284 }
285 $change = '';
0a12ae7d 286 next LINE;
8d063cd8 287 }
288} continue {
289 @lines = split(/\n/,$_);
0a12ae7d 290 for (@lines) {
8d063cd8 291 unless (s/^ *<<--//) {
0a12ae7d 292 print BODY &tab;
8d063cd8 293 }
0a12ae7d 294 print BODY $_, "\n";
8d063cd8 295 }
296 $indent += $indmod;
297 $indmod = 0;
298 if ($redo) {
299 $_ = $redo;
300 $redo = '';
0a12ae7d 301 redo LINE;
8d063cd8 302 }
303}
ffed7fef 304if ($lastlinewaslabel++) {
305 $indent += 4;
0a12ae7d 306 print BODY &tab, ";\n";
ffed7fef 307 $indent -= 4;
308}
8d063cd8 309
8d063cd8 310if ($appendseen || $tseen || !$assumen) {
311 $printit++ if $dseen || (!$assumen && !$assumep);
9ef589d8 312 print BODY &q(<<'EOT');
313: #ifdef SAWNEXT
314: }
315: continue {
316: #endif
317: #ifdef PRINTIT
318: #ifdef DSEEN
319: #ifdef ASSUMEP
320: print if $printit++;
321: #else
322: if ($printit)
323: { print; }
324: else
325: { $printit++ unless $nflag; }
326: #endif
327: #else
328: print if $printit;
329: #endif
330: #else
331: print;
332: #endif
333: #ifdef TSEEN
334: $tflag = 0;
335: #endif
336: #ifdef APPENDSEEN
337: if ($atext) { chop $atext; print $atext; $atext = ''; }
338: #endif
339EOT
340
341print BODY &q(<<'EOT');
342: }
0a12ae7d 343EOT
8d063cd8 344}
345
0a12ae7d 346close BODY;
8d063cd8 347
348unless ($debug) {
0a12ae7d 349 open(HEAD,">/tmp/sperl2$$.c")
350 || &Die("Can't open temp file 2: $!\n");
9ef589d8 351 print HEAD "#define PRINTIT\n" if $printit;
352 print HEAD "#define APPENDSEEN\n" if $appendseen;
353 print HEAD "#define TSEEN\n" if $tseen;
354 print HEAD "#define DSEEN\n" if $dseen;
355 print HEAD "#define ASSUMEN\n" if $assumen;
356 print HEAD "#define ASSUMEP\n" if $assumep;
357 print HEAD "#define TOPLABEL\n" if $toplabel;
358 print HEAD "#define SAWNEXT\n" if $sawnext;
0a12ae7d 359 if ($opens) {print HEAD "$opens\n";}
360 open(BODY,"/tmp/sperl$$")
361 || &Die("Can't reopen temp file: $!\n");
362 while (<BODY>) {
363 print HEAD $_;
8d063cd8 364 }
0a12ae7d 365 close HEAD;
8d063cd8 366
9ef589d8 367 print &q(<<"EOT");
4633a7c4 368: $startperl
369: eval 'exec perl -S \$0 \${1+"\$@"}'
9ef589d8 370: if \$running_under_some_shell;
371:
0a12ae7d 372EOT
373 open(BODY,"cc -E /tmp/sperl2$$.c |") ||
374 &Die("Can't reopen temp file: $!\n");
375 while (<BODY>) {
8d063cd8 376 /^# [0-9]/ && next;
377 /^[ \t]*$/ && next;
378 s/^<><>//;
379 print;
380 }
381}
382
0a12ae7d 383&Cleanup;
384exit;
8d063cd8 385
0a12ae7d 386sub Cleanup {
387 chdir "/tmp";
388 unlink "sperl$$", "sperl2$$", "sperl2$$.c";
389}
8d063cd8 390sub Die {
0a12ae7d 391 &Cleanup;
8d063cd8 392 die $_[0];
393}
0a12ae7d 394sub tab {
395 "\t" x ($indent / 8) . ' ' x ($indent % 8);
396}
8d063cd8 397sub make_filehandle {
0a12ae7d 398 local($_) = $_[0];
399 local($fname) = $_;
9ef589d8 400 if (!$seen{$fname}) {
401 $_ = "FH_" . $_ if /^\d/;
402 s/[^a-zA-Z0-9]/_/g;
403 s/^_*//;
404 $_ = "\U$_";
405 if ($fhseen{$_}) {
406 for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
407 $_ .= $tmp;
408 }
409 $fhseen{$_} = 1;
410 $opens .= &q(<<"EOT");
411: open($_, '>$fname') || die "Can't create $fname: \$!";
0a12ae7d 412EOT
9ef589d8 413 $seen{$fname} = $_;
8d063cd8 414 }
9ef589d8 415 $seen{$fname};
8d063cd8 416}
417
418sub make_label {
0a12ae7d 419 local($label) = @_;
8d063cd8 420 $label =~ s/[^a-zA-Z0-9]/_/g;
421 if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
422 $label = substr($label,0,8);
0a12ae7d 423
424 # Could be a reserved word, so capitalize it.
425 substr($label,0,1) =~ y/a-z/A-Z/
426 if $label =~ /^[a-z]/;
427
8d063cd8 428 $label;
429}
430
431sub transmogrify {
432 { # case
433 if (/^d/) {
434 $dseen++;
9ef589d8 435 chop($_ = &q(<<'EOT'));
436: <<--#ifdef PRINTIT
437: $printit = 0;
438: <<--#endif
439: next LINE;
0a12ae7d 440EOT
9ef589d8 441 $sawnext++;
8d063cd8 442 next;
443 }
444
445 if (/^n/) {
9ef589d8 446 chop($_ = &q(<<'EOT'));
447: <<--#ifdef PRINTIT
448: <<--#ifdef DSEEN
449: <<--#ifdef ASSUMEP
450: print if $printit++;
451: <<--#else
452: if ($printit)
453: { print; }
454: else
455: { $printit++ unless $nflag; }
456: <<--#endif
457: <<--#else
458: print if $printit;
459: <<--#endif
460: <<--#else
461: print;
462: <<--#endif
463: <<--#ifdef APPENDSEEN
464: if ($atext) {chop $atext; print $atext; $atext = '';}
465: <<--#endif
466: $_ = <>;
467: chop;
468: <<--#ifdef TSEEN
469: $tflag = 0;
470: <<--#endif
0a12ae7d 471EOT
8d063cd8 472 next;
473 }
474
475 if (/^a/) {
476 $appendseen++;
9ef589d8 477 $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
8d063cd8 478 $lastline = 0;
479 while (<>) {
480 s/^[ \t]*//;
481 s/^[\\]//;
482 unless (s|\\$||) { $lastline = 1;}
8d063cd8 483 s/^([ \t]*\n)/<><>$1/;
484 $command .= $_;
485 $command .= '<<--';
486 last if $lastline;
487 }
9ef589d8 488 $_ = $command . "End_Of_Text";
8d063cd8 489 last;
490 }
491
492 if (/^[ic]/) {
493 if (/^c/) { $change = 1; }
9ef589d8 494 $addr1 = 1 if $addr1 eq '';
8d063cd8 495 $addr1 = '$iter = (' . $addr1 . ')';
9ef589d8 496 $command = $space .
497 " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
8d063cd8 498 $lastline = 0;
499 while (<>) {
500 s/^[ \t]*//;
501 s/^[\\]//;
502 unless (s/\\$//) { $lastline = 1;}
503 s/'/\\'/g;
504 s/^([ \t]*\n)/<><>$1/;
505 $command .= $_;
506 $command .= '<<--';
507 last if $lastline;
508 }
9ef589d8 509 $_ = $command . "End_Of_Text";
8d063cd8 510 if ($change) {
511 $dseen++;
512 $change = "$_\n";
9ef589d8 513 chop($_ = &q(<<"EOT"));
514: <<--#ifdef PRINTIT
515: $space\$printit = 0;
516: <<--#endif
517: ${space}next LINE;
0a12ae7d 518EOT
9ef589d8 519 $sawnext++;
8d063cd8 520 }
521 last;
522 }
523
524 if (/^s/) {
525 $delim = substr($_,1,1);
526 $len = length($_);
527 $repl = $end = 0;
a687059c 528 $inbracket = 0;
8d063cd8 529 for ($i = 2; $i < $len; $i++) {
530 $c = substr($_,$i,1);
a687059c 531 if ($c eq $delim) {
532 if ($inbracket) {
0a12ae7d 533 substr($_, $i, 0) = '\\';
a687059c 534 $i++;
535 $len++;
536 }
537 else {
538 if ($repl) {
539 $end = $i;
540 last;
541 } else {
542 $repl = $i;
543 }
544 }
545 }
546 elsif ($c eq '\\') {
8d063cd8 547 $i++;
548 if ($i >= $len) {
549 $_ .= 'n';
550 $_ .= <>;
551 $len = length($_);
552 $_ = substr($_,0,--$len);
553 }
00bf170e 554 elsif (substr($_,$i,1) =~ /^[n]$/) {
555 ;
556 }
0a12ae7d 557 elsif (!$repl &&
558 substr($_,$i,1) =~ /^[(){}\w]$/) {
8d063cd8 559 $i--;
560 $len--;
0a12ae7d 561 substr($_, $i, 1) = '';
8d063cd8 562 }
0a12ae7d 563 elsif (!$repl &&
564 substr($_,$i,1) =~ /^[<>]$/) {
9f68db38 565 substr($_,$i,1) = 'b';
566 }
2b69d0c2 567 elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
568 substr($_,$i-1,1) = '$';
569 }
570 }
571 elsif ($c eq '&' && $repl) {
572 substr($_, $i, 0) = '$';
573 $i++;
574 $len++;
575 }
576 elsif ($c eq '$' && $repl) {
577 substr($_, $i, 0) = '\\';
578 $i++;
579 $len++;
8d063cd8 580 }
a687059c 581 elsif ($c eq '[' && !$repl) {
582 $i++ if substr($_,$i,1) eq '^';
583 $i++ if substr($_,$i,1) eq ']';
584 $inbracket = 1;
8d063cd8 585 }
a687059c 586 elsif ($c eq ']') {
587 $inbracket = 0;
588 }
9ef589d8 589 elsif ($c eq "\t") {
590 substr($_, $i, 1) = '\\t';
591 $i++;
592 $len++;
593 }
ae986130 594 elsif (!$repl && index("()+",$c) >= 0) {
0a12ae7d 595 substr($_, $i, 0) = '\\';
8d063cd8 596 $i++;
597 $len++;
598 }
599 }
0a12ae7d 600 &Die("Malformed substitution at line $.\n")
601 unless $end;
8d063cd8 602 $pat = substr($_, 0, $repl + 1);
0a12ae7d 603 $repl = substr($_, $repl+1, $end-$repl-1);
8d063cd8 604 $end = substr($_, $end + 1, 1000);
9ef589d8 605 &simplify($pat);
8d063cd8 606 $dol = '$';
8d063cd8 607 $subst = "$pat$repl$delim";
608 $cmd = '';
609 while ($end) {
0a12ae7d 610 if ($end =~ s/^g//) {
611 $subst .= 'g';
612 next;
613 }
614 if ($end =~ s/^p//) {
615 $cmd .= ' && (print)';
616 next;
617 }
8d063cd8 618 if ($end =~ s/^w[ \t]*//) {
0a12ae7d 619 $fh = &make_filehandle($end);
8d063cd8 620 $cmd .= " && (print $fh \$_)";
621 $end = '';
622 next;
623 }
0a12ae7d 624 &Die("Unrecognized substitution command".
625 "($end) at line $.\n");
8d063cd8 626 }
9ef589d8 627 chop ($_ = &q(<<"EOT"));
628: <<--#ifdef TSEEN
629: $subst && \$tflag++$cmd;
630: <<--#else
631: $subst$cmd;
632: <<--#endif
0a12ae7d 633EOT
8d063cd8 634 next;
635 }
636
637 if (/^p/) {
638 $_ = 'print;';
639 next;
640 }
641
642 if (/^w/) {
643 s/^w[ \t]*//;
0a12ae7d 644 $fh = &make_filehandle($_);
8d063cd8 645 $_ = "print $fh \$_;";
646 next;
647 }
648
649 if (/^r/) {
650 $appendseen++;
651 s/^r[ \t]*//;
652 $file = $_;
653 $_ = "\$atext .= `cat $file 2>/dev/null`;";
654 next;
655 }
656
657 if (/^P/) {
9ef589d8 658 $_ = 'print $1 if /^(.*)/;';
8d063cd8 659 next;
660 }
661
662 if (/^D/) {
9ef589d8 663 chop($_ = &q(<<'EOT'));
664: s/^.*\n?//;
665: redo LINE if $_;
666: next LINE;
0a12ae7d 667EOT
9ef589d8 668 $sawnext++;
8d063cd8 669 next;
670 }
671
672 if (/^N/) {
9ef589d8 673 chop($_ = &q(<<'EOT'));
674: $_ .= "\n";
675: $len1 = length;
676: $_ .= <>;
677: chop if $len1 < length;
678: <<--#ifdef TSEEN
679: $tflag = 0;
680: <<--#endif
0a12ae7d 681EOT
8d063cd8 682 next;
683 }
684
685 if (/^h/) {
686 $_ = '$hold = $_;';
687 next;
688 }
689
690 if (/^H/) {
9ef589d8 691 $_ = '$hold .= "\n"; $hold .= $_;';
8d063cd8 692 next;
693 }
694
695 if (/^g/) {
696 $_ = '$_ = $hold;';
697 next;
698 }
699
700 if (/^G/) {
9ef589d8 701 $_ = '$_ .= "\n"; $_ .= $hold;';
8d063cd8 702 next;
703 }
704
705 if (/^x/) {
706 $_ = '($_, $hold) = ($hold, $_);';
707 next;
708 }
709
710 if (/^b$/) {
0a12ae7d 711 $_ = 'next LINE;';
9ef589d8 712 $sawnext++;
8d063cd8 713 next;
714 }
715
716 if (/^b/) {
717 s/^b[ \t]*//;
0a12ae7d 718 $lab = &make_label($_);
8d063cd8 719 if ($lab eq $toplabel) {
0a12ae7d 720 $_ = 'redo LINE;';
8d063cd8 721 } else {
722 $_ = "goto $lab;";
723 }
724 next;
725 }
726
727 if (/^t$/) {
0a12ae7d 728 $_ = 'next LINE if $tflag;';
9ef589d8 729 $sawnext++;
8d063cd8 730 $tseen++;
731 next;
732 }
733
734 if (/^t/) {
735 s/^t[ \t]*//;
0a12ae7d 736 $lab = &make_label($_);
9ef589d8 737 $_ = q/if ($tflag) {$tflag = 0; /;
8d063cd8 738 if ($lab eq $toplabel) {
0a12ae7d 739 $_ .= 'redo LINE;}';
8d063cd8 740 } else {
0a12ae7d 741 $_ .= "goto $lab;}";
8d063cd8 742 }
743 $tseen++;
744 next;
745 }
746
9ef589d8 747 if (/^y/) {
748 s/abcdefghijklmnopqrstuvwxyz/a-z/g;
749 s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
750 s/abcdef/a-f/g;
751 s/ABCDEF/A-F/g;
752 s/0123456789/0-9/g;
753 s/01234567/0-7/g;
754 $_ .= ';';
755 }
756
8d063cd8 757 if (/^=/) {
9ef589d8 758 $_ = 'print $.;';
8d063cd8 759 next;
760 }
761
762 if (/^q/) {
9ef589d8 763 chop($_ = &q(<<'EOT'));
764: close(ARGV);
765: @ARGV = ();
766: next LINE;
0a12ae7d 767EOT
9ef589d8 768 $sawnext++;
8d063cd8 769 next;
770 }
771 } continue {
772 if ($space) {
773 s/^/$space/;
774 s/(\n)(.)/$1$space$2/g;
775 }
776 last;
777 }
778 $_;
779}
780
a687059c 781sub fetchpat {
782 local($outer) = @_;
783 local($addr) = $outer;
784 local($inbracket);
785 local($prefix,$delim,$ch);
786
0a12ae7d 787 # Process pattern one potential delimiter at a time.
788
789 DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
a687059c 790 $prefix = $1;
791 $delim = $2;
a687059c 792 if ($delim eq '\\') {
793 s/(.)//;
794 $ch = $1;
00bf170e 795 $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
9f68db38 796 $ch = 'b' if $ch =~ /^[<>]$/;
797 $delim .= $ch;
a687059c 798 }
799 elsif ($delim eq '[') {
800 $inbracket = 1;
801 s/^\^// && ($delim .= '^');
802 s/^]// && ($delim .= ']');
a687059c 803 }
804 elsif ($delim eq ']') {
805 $inbracket = 0;
806 }
807 elsif ($inbracket || $delim ne $outer) {
a687059c 808 $delim = '\\' . $delim;
809 }
810 $addr .= $prefix;
811 $addr .= $delim;
812 if ($delim eq $outer && !$inbracket) {
0a12ae7d 813 last DELIM;
a687059c 814 }
815 }
9ef589d8 816 $addr =~ s/\t/\\t/g;
817 &simplify($addr);
a687059c 818 $addr;
819}
820
9ef589d8 821sub q {
822 local($string) = @_;
823 local($*) = 1;
824 $string =~ s/^:\t?//g;
825 $string;
826}
827
828sub simplify {
829 $_[0] =~ s/_a-za-z0-9/\\w/ig;
830 $_[0] =~ s/a-z_a-z0-9/\\w/ig;
831 $_[0] =~ s/a-za-z_0-9/\\w/ig;
832 $_[0] =~ s/a-za-z0-9_/\\w/ig;
833 $_[0] =~ s/_0-9a-za-z/\\w/ig;
834 $_[0] =~ s/0-9_a-za-z/\\w/ig;
835 $_[0] =~ s/0-9a-z_a-z/\\w/ig;
836 $_[0] =~ s/0-9a-za-z_/\\w/ig;
837 $_[0] =~ s/\[\\w\]/\\w/g;
838 $_[0] =~ s/\[^\\w\]/\\W/g;
839 $_[0] =~ s/\[0-9\]/\\d/g;
840 $_[0] =~ s/\[^0-9\]/\\D/g;
841 $_[0] =~ s/\\d\\d\*/\\d+/g;
842 $_[0] =~ s/\\D\\D\*/\\D+/g;
843 $_[0] =~ s/\\w\\w\*/\\w+/g;
844 $_[0] =~ s/\\t\\t\*/\\t+/g;
845 $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
846 $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
847}
848
a687059c 849!NO!SUBS!
4633a7c4 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 ':';