Re: Problems with: Creating an installable tar archive
[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);
8a5546a1 5use Cwd;
4633a7c4 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 17chdir dirname($0);
18$file = basename($0, '.PL');
774d564b 19$file .= '.com' if $^O eq 'VMS';
4633a7c4 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 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 34!GROK!THIS!
35
4633a7c4 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 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 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 116$indent = 4;
117$shiftwidth = 4;
118$l = '{'; $r = '}';
8d063cd8 119
0a12ae7d 120while ($ARGV[0] =~ /^-/) {
8d063cd8 121 $_ = shift;
122 last if /^--/;
123 if (/^-D/) {
124 $debug++;
0a12ae7d 125 open(BODY,'>-');
8d063cd8 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 137}
138
139unless ($debug) {
1aa91729 140 open(BODY,"+>/tmp/sperl$$") ||
0a12ae7d 141 &Die("Can't open temp file: $!\n");
8d063cd8 142}
143
144if (!$assumen && !$assumep) {
9ef589d8 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 157}
158
9ef589d8 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 178EOT
179
9ef589d8 180LINE:
181while (<>) {
0a12ae7d 182
183 # Wipe out surrounding whitespace.
8d063cd8 184
8d063cd8 185 s/[ \t]*(.*)\n$/$1/;
0a12ae7d 186
187 # Perhaps it's a label/comment.
188
8d063cd8 189 if (/^:/) {
190 s/^:[ \t]*//;
0a12ae7d 191 $label = &make_label($_);
8d063cd8 192 if ($. == 1) {
193 $toplabel = $label;
9ef589d8 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 198 }
199 $_ = "$label:";
ffed7fef 200 if ($lastlinewaslabel++) {
201 $indent += 4;
0a12ae7d 202 print BODY &tab, ";\n";
ffed7fef 203 $indent -= 4;
204 }
8d063cd8 205 if ($indent >= 2) {
206 $indent -= 2;
207 $indmod = 2;
208 }
209 next;
210 } else {
211 $lastlinewaslabel = '';
212 }
0a12ae7d 213
214 # Look for one or two address clauses
215
8d063cd8 216 $addr1 = '';
217 $addr2 = '';
218 if (s/^([0-9]+)//) {
219 $addr1 = "$1";
9ef589d8 220 $addr1 = "\$. == $addr1" unless /^,/;
8d063cd8 221 }
222 elsif (s/^\$//) {
223 $addr1 = 'eof()';
224 }
225 elsif (s|^/||) {
0a12ae7d 226 $addr1 = &fetchpat('/');
8d063cd8 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 238 if ($addr2 =~ /^\d+$/) {
239 $addr1 .= "..$addr2";
240 }
241 else {
242 $addr1 .= "...$addr2";
243 }
8d063cd8 244 }
0a12ae7d 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 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 271 } else {
272 $space = '';
273 }
0a12ae7d 274 $_ = &transmogrify();
8d063cd8 275 }
276
0a12ae7d 277 # See if we can optimize to modifier form.
278
8d063cd8 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 286 }
287 $change = '';
0a12ae7d 288 next LINE;
8d063cd8 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 297 }
298 $indent += $indmod;
299 $indmod = 0;
300 if ($redo) {
301 $_ = $redo;
302 $redo = '';
0a12ae7d 303 redo LINE;
8d063cd8 304 }
305}
ffed7fef 306if ($lastlinewaslabel++) {
307 $indent += 4;
0a12ae7d 308 print BODY &tab, ";\n";
ffed7fef 309 $indent -= 4;
310}
8d063cd8 311
8d063cd8 312if ($appendseen || $tseen || !$assumen) {
313 $printit++ if $dseen || (!$assumen && !$assumep);
9ef589d8 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
342
343print BODY &q(<<'EOT');
344: }
0a12ae7d 345EOT
8d063cd8 346}
347
8d063cd8 348unless ($debug) {
8d063cd8 349
9ef589d8 350 print &q(<<"EOT");
4633a7c4 351: $startperl
5f05dabc 352: eval 'exec $perlpath -S \$0 \${1+"\$@"}'
9ef589d8 353: if \$running_under_some_shell;
354:
0a12ae7d 355EOT
1aa91729 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 360 /^#ifdef (\w+)/ && ((${lc $1} || &skip), next);
361 /^#else/ && (&skip, next);
362 /^#endif/ && next;
8d063cd8 363 s/^<><>//;
364 print;
365 }
366}
367
0a12ae7d 368&Cleanup;
369exit;
8d063cd8 370
0a12ae7d 371sub Cleanup {
1aa91729 372 unlink "/tmp/sperl$$";
0a12ae7d 373}
8d063cd8 374sub Die {
0a12ae7d 375 &Cleanup;
8d063cd8 376 die $_[0];
377}
0a12ae7d 378sub tab {
379 "\t" x ($indent / 8) . ' ' x ($indent % 8);
380}
8d063cd8 381sub make_filehandle {
0a12ae7d 382 local($_) = $_[0];
383 local($fname) = $_;
9ef589d8 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 400}
401
402sub make_label {
0a12ae7d 403 local($label) = @_;
8d063cd8 404 $label =~ s/[^a-zA-Z0-9]/_/g;
405 if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
406 $label = substr($label,0,8);
0a12ae7d 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 412 $label;
413}
414
415sub transmogrify {
416 { # case
417 if (/^d/) {
418 $dseen++;
9ef589d8 419 chop($_ = &q(<<'EOT'));
420: <<--#ifdef PRINTIT
421: $printit = 0;
422: <<--#endif
423: next LINE;
0a12ae7d 424EOT
9ef589d8 425 $sawnext++;
8d063cd8 426 next;
427 }
428
429 if (/^n/) {
9ef589d8 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 456 next;
457 }
458
459 if (/^a/) {
460 $appendseen++;
9ef589d8 461 $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
8d063cd8 462 $lastline = 0;
463 while (<>) {
464 s/^[ \t]*//;
465 s/^[\\]//;
466 unless (s|\\$||) { $lastline = 1;}
8d063cd8 467 s/^([ \t]*\n)/<><>$1/;
468 $command .= $_;
469 $command .= '<<--';
470 last if $lastline;
471 }
9ef589d8 472 $_ = $command . "End_Of_Text";
8d063cd8 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 480 $command = $space .
481 " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
8d063cd8 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 494 if ($change) {
495 $dseen++;
496 $change = "$_\n";
9ef589d8 497 chop($_ = &q(<<"EOT"));
498: <<--#ifdef PRINTIT
499: $space\$printit = 0;
500: <<--#endif
501: ${space}next LINE;
0a12ae7d 502EOT
9ef589d8 503 $sawnext++;
8d063cd8 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 513 for ($i = 2; $i < $len; $i++) {
514 $c = substr($_,$i,1);
a687059c 515 if ($c eq $delim) {
516 if ($inbracket) {
0a12ae7d 517 substr($_, $i, 0) = '\\';
a687059c 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 531 $i++;
532 if ($i >= $len) {
533 $_ .= 'n';
534 $_ .= <>;
535 $len = length($_);
536 $_ = substr($_,0,--$len);
537 }
00bf170e 538 elsif (substr($_,$i,1) =~ /^[n]$/) {
539 ;
540 }
0a12ae7d 541 elsif (!$repl &&
542 substr($_,$i,1) =~ /^[(){}\w]$/) {
8d063cd8 543 $i--;
544 $len--;
0a12ae7d 545 substr($_, $i, 1) = '';
8d063cd8 546 }
0a12ae7d 547 elsif (!$repl &&
548 substr($_,$i,1) =~ /^[<>]$/) {
9f68db38 549 substr($_,$i,1) = 'b';
550 }
2b69d0c2 551 elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
552 substr($_,$i-1,1) = '$';
553 }
554 }
555 elsif ($c eq '&' && $repl) {
556 substr($_, $i, 0) = '$';
557 $i++;
558 $len++;
559 }
560 elsif ($c eq '$' && $repl) {
561 substr($_, $i, 0) = '\\';
562 $i++;
563 $len++;
8d063cd8 564 }
a687059c 565 elsif ($c eq '[' && !$repl) {
566 $i++ if substr($_,$i,1) eq '^';
567 $i++ if substr($_,$i,1) eq ']';
568 $inbracket = 1;
8d063cd8 569 }
a687059c 570 elsif ($c eq ']') {
571 $inbracket = 0;
572 }
9ef589d8 573 elsif ($c eq "\t") {
574 substr($_, $i, 1) = '\\t';
575 $i++;
576 $len++;
577 }
ae986130 578 elsif (!$repl && index("()+",$c) >= 0) {
0a12ae7d 579 substr($_, $i, 0) = '\\';
8d063cd8 580 $i++;
581 $len++;
582 }
583 }
0a12ae7d 584 &Die("Malformed substitution at line $.\n")
585 unless $end;
8d063cd8 586 $pat = substr($_, 0, $repl + 1);
0a12ae7d 587 $repl = substr($_, $repl+1, $end-$repl-1);
8d063cd8 588 $end = substr($_, $end + 1, 1000);
9ef589d8 589 &simplify($pat);
8d063cd8 590 $subst = "$pat$repl$delim";
591 $cmd = '';
592 while ($end) {
0a12ae7d 593 if ($end =~ s/^g//) {
594 $subst .= 'g';
595 next;
596 }
597 if ($end =~ s/^p//) {
598 $cmd .= ' && (print)';
599 next;
600 }
8d063cd8 601 if ($end =~ s/^w[ \t]*//) {
0a12ae7d 602 $fh = &make_filehandle($end);
8d063cd8 603 $cmd .= " && (print $fh \$_)";
604 $end = '';
605 next;
606 }
0a12ae7d 607 &Die("Unrecognized substitution command".
608 "($end) at line $.\n");
8d063cd8 609 }
9ef589d8 610 chop ($_ = &q(<<"EOT"));
611: <<--#ifdef TSEEN
612: $subst && \$tflag++$cmd;
613: <<--#else
614: $subst$cmd;
615: <<--#endif
0a12ae7d 616EOT
8d063cd8 617 next;
618 }
619
620 if (/^p/) {
621 $_ = 'print;';
622 next;
623 }
624
625 if (/^w/) {
626 s/^w[ \t]*//;
0a12ae7d 627 $fh = &make_filehandle($_);
8d063cd8 628 $_ = "print $fh \$_;";
629 next;
630 }
631
632 if (/^r/) {
633 $appendseen++;
634 s/^r[ \t]*//;
635 $file = $_;
636 $_ = "\$atext .= `cat $file 2>/dev/null`;";
637 next;
638 }
639
640 if (/^P/) {
9ef589d8 641 $_ = 'print $1 if /^(.*)/;';
8d063cd8 642 next;
643 }
644
645 if (/^D/) {
9ef589d8 646 chop($_ = &q(<<'EOT'));
647: s/^.*\n?//;
648: redo LINE if $_;
649: next LINE;
0a12ae7d 650EOT
9ef589d8 651 $sawnext++;
8d063cd8 652 next;
653 }
654
655 if (/^N/) {
9ef589d8 656 chop($_ = &q(<<'EOT'));
657: $_ .= "\n";
658: $len1 = length;
659: $_ .= <>;
660: chop if $len1 < length;
661: <<--#ifdef TSEEN
662: $tflag = 0;
663: <<--#endif
0a12ae7d 664EOT
8d063cd8 665 next;
666 }
667
668 if (/^h/) {
669 $_ = '$hold = $_;';
670 next;
671 }
672
673 if (/^H/) {
9ef589d8 674 $_ = '$hold .= "\n"; $hold .= $_;';
8d063cd8 675 next;
676 }
677
678 if (/^g/) {
679 $_ = '$_ = $hold;';
680 next;
681 }
682
683 if (/^G/) {
9ef589d8 684 $_ = '$_ .= "\n"; $_ .= $hold;';
8d063cd8 685 next;
686 }
687
688 if (/^x/) {
689 $_ = '($_, $hold) = ($hold, $_);';
690 next;
691 }
692
693 if (/^b$/) {
0a12ae7d 694 $_ = 'next LINE;';
9ef589d8 695 $sawnext++;
8d063cd8 696 next;
697 }
698
699 if (/^b/) {
700 s/^b[ \t]*//;
0a12ae7d 701 $lab = &make_label($_);
8d063cd8 702 if ($lab eq $toplabel) {
0a12ae7d 703 $_ = 'redo LINE;';
8d063cd8 704 } else {
705 $_ = "goto $lab;";
706 }
707 next;
708 }
709
710 if (/^t$/) {
0a12ae7d 711 $_ = 'next LINE if $tflag;';
9ef589d8 712 $sawnext++;
8d063cd8 713 $tseen++;
714 next;
715 }
716
717 if (/^t/) {
718 s/^t[ \t]*//;
0a12ae7d 719 $lab = &make_label($_);
9ef589d8 720 $_ = q/if ($tflag) {$tflag = 0; /;
8d063cd8 721 if ($lab eq $toplabel) {
0a12ae7d 722 $_ .= 'redo LINE;}';
8d063cd8 723 } else {
0a12ae7d 724 $_ .= "goto $lab;}";
8d063cd8 725 }
726 $tseen++;
727 next;
728 }
729
9ef589d8 730 if (/^y/) {
731 s/abcdefghijklmnopqrstuvwxyz/a-z/g;
732 s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
733 s/abcdef/a-f/g;
734 s/ABCDEF/A-F/g;
735 s/0123456789/0-9/g;
736 s/01234567/0-7/g;
737 $_ .= ';';
738 }
739
8d063cd8 740 if (/^=/) {
9ef589d8 741 $_ = 'print $.;';
8d063cd8 742 next;
743 }
744
745 if (/^q/) {
9ef589d8 746 chop($_ = &q(<<'EOT'));
747: close(ARGV);
748: @ARGV = ();
749: next LINE;
0a12ae7d 750EOT
9ef589d8 751 $sawnext++;
8d063cd8 752 next;
753 }
754 } continue {
755 if ($space) {
756 s/^/$space/;
757 s/(\n)(.)/$1$space$2/g;
758 }
759 last;
760 }
761 $_;
762}
763
a687059c 764sub fetchpat {
765 local($outer) = @_;
766 local($addr) = $outer;
767 local($inbracket);
768 local($prefix,$delim,$ch);
769
0a12ae7d 770 # Process pattern one potential delimiter at a time.
771
772 DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
a687059c 773 $prefix = $1;
774 $delim = $2;
a687059c 775 if ($delim eq '\\') {
776 s/(.)//;
777 $ch = $1;
00bf170e 778 $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
9f68db38 779 $ch = 'b' if $ch =~ /^[<>]$/;
780 $delim .= $ch;
a687059c 781 }
782 elsif ($delim eq '[') {
783 $inbracket = 1;
784 s/^\^// && ($delim .= '^');
785 s/^]// && ($delim .= ']');
a687059c 786 }
787 elsif ($delim eq ']') {
788 $inbracket = 0;
789 }
790 elsif ($inbracket || $delim ne $outer) {
a687059c 791 $delim = '\\' . $delim;
792 }
793 $addr .= $prefix;
794 $addr .= $delim;
795 if ($delim eq $outer && !$inbracket) {
0a12ae7d 796 last DELIM;
a687059c 797 }
798 }
9ef589d8 799 $addr =~ s/\t/\\t/g;
800 &simplify($addr);
a687059c 801 $addr;
802}
803
9ef589d8 804sub q {
805 local($string) = @_;
806 local($*) = 1;
807 $string =~ s/^:\t?//g;
808 $string;
809}
810
811sub simplify {
812 $_[0] =~ s/_a-za-z0-9/\\w/ig;
813 $_[0] =~ s/a-z_a-z0-9/\\w/ig;
814 $_[0] =~ s/a-za-z_0-9/\\w/ig;
815 $_[0] =~ s/a-za-z0-9_/\\w/ig;
816 $_[0] =~ s/_0-9a-za-z/\\w/ig;
817 $_[0] =~ s/0-9_a-za-z/\\w/ig;
818 $_[0] =~ s/0-9a-z_a-z/\\w/ig;
819 $_[0] =~ s/0-9a-za-z_/\\w/ig;
820 $_[0] =~ s/\[\\w\]/\\w/g;
821 $_[0] =~ s/\[^\\w\]/\\W/g;
822 $_[0] =~ s/\[0-9\]/\\d/g;
823 $_[0] =~ s/\[^0-9\]/\\D/g;
824 $_[0] =~ s/\\d\\d\*/\\d+/g;
825 $_[0] =~ s/\\D\\D\*/\\D+/g;
826 $_[0] =~ s/\\w\\w\*/\\w+/g;
827 $_[0] =~ s/\\t\\t\*/\\t+/g;
828 $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
829 $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
830}
831
1aa91729 832sub skip {
833 local($level) = 0;
834
835 while(<BODY>) {
836 /^#ifdef/ && $level++;
837 /^#else/ && !$level && return;
838 /^#endif/ && !$level-- && return;
839 }
840
841 die "Unterminated `#ifdef' conditional\n";
842}
a687059c 843!NO!SUBS!
4633a7c4 844
845close OUT or die "Can't close $file: $!";
846chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
847exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
8a5546a1 848chdir $origdir;