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