x2p/s2p.PL

   1 #!/usr/local/bin/perl
   2
   3 use Config;
   4 use 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.
  15 chdir dirname($0);
  16 $file = basename($0, '.PL');
  17 $file .= '.com' if $^O eq 'VMS';
  18
  19 open OUT,">$file" or die "Can't create $file: $!";
  20
  21 print "Extracting $file (with variable substitutions)\n";
  22
  23 # In this section, perl variables will be expanded during extraction.
  24 # You can use $Config{...} to use Configure variables.
  25
  26 print OUT <<"!GROK!THIS!";
  27 $Config{startperl}
  28     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
  29         if \$running_under_some_shell;
  30 \$startperl = "$Config{startperl}";
  31 \$perlpath = "$Config{perlpath}";
  32 !GROK!THIS!
  33
  34 # In the following, perl variables are not expanded during extraction.
  35
  36 print OUT <<'!NO!SUBS!';
  37
  38 # $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $
  39 #
  40 # $Log: s2p.SH,v $
  41
  42 =head1 NAME
  43
  44 s2p - Sed to Perl translator
  45
  46 =head1 SYNOPSIS
  47
  48 B<s2p [options] filename>
  49
  50 =head1 DESCRIPTION
  51
  52 I<S2p> takes a sed script specified on the command line (or from
  53 standard input) and produces a comparable I<perl> script on the
  54 standard output.
  55
  56 =head2 Options
  57
  58 Options include:
  59
  60 =over 5
  61
  62 =item B<-DE<lt>numberE<gt>>
  63
  64 sets debugging flags.
  65
  66 =item B<-n>
  67
  68 specifies that this sed script was always invoked with a B<sed -n>.
  69 Otherwise a switch parser is prepended to the front of the script.
  70
  71 =item B<-p>
  72
  73 specifies that this sed script was never invoked with a B<sed -n>.
  74 Otherwise a switch parser is prepended to the front of the script.
  75
  76 =back
  77
  78 =head2 Considerations
  79
  80 The perl script produced looks very sed-ish, and there may very well
  81 be better ways to express what you want to do in perl.  For instance,
  82 s2p does not make any use of the split operator, but you might want
  83 to.
  84
  85 The perl script you end up with may be either faster or slower than
  86 the original sed script.  If you're only interested in speed you'll
  87 just have to try it both ways.  Of course, if you want to do something
  88 sed doesn't do, you have no choice.  It's often possible to speed up
  89 the perl script by various methods, such as deleting all references to
  90 $\ and chop.
  91
  92 =head1 ENVIRONMENT
  93
  94 S2p uses no environment variables.
  95
  96 =head1 AUTHOR
  97
  98 Larry Wall E<lt>F<larry@wall.org>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
 114 $indent = 4;
 115 $shiftwidth = 4;
 116 $l = '{'; $r = '}';
 117
 118 while ($ARGV[0] =~ /^-/) {
 119     $_ = shift;
 120   last if /^--/;
 121     if (/^-D/) {
 122         $debug++;
 123         open(BODY,'>-');
 124         next;
 125     }
 126     if (/^-n/) {
 127         $assumen++;
 128         next;
 129     }
 130     if (/^-p/) {
 131         $assumep++;
 132         next;
 133     }
 134     die "I don't recognize this switch: $_\n";
 135 }
 136
 137 unless ($debug) {
 138     open(BODY,">/tmp/sperl$$") ||
 139       &Die("Can't open temp file: $!\n");
 140 }
 141
 142 if (!$assumen && !$assumep) {
 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 :
 154 EOT
 155 }
 156
 157 print 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
 176 EOT
 177
 178 LINE:
 179 while (<>) {
 180
 181     # Wipe out surrounding whitespace.
 182
 183     s/[ \t]*(.*)\n$/$1/;
 184
 185     # Perhaps it's a label/comment.
 186
 187     if (/^:/) {
 188         s/^:[ \t]*//;
 189         $label = &make_label($_);
 190         if ($. == 1) {
 191             $toplabel = $label;
 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             }
 196         }
 197         $_ = "$label:";
 198         if ($lastlinewaslabel++) {
 199             $indent += 4;
 200             print BODY &tab, ";\n";
 201             $indent -= 4;
 202         }
 203         if ($indent >= 2) {
 204             $indent -= 2;
 205             $indmod = 2;
 206         }
 207         next;
 208     } else {
 209         $lastlinewaslabel = '';
 210     }
 211
 212     # Look for one or two address clauses
 213
 214     $addr1 = '';
 215     $addr2 = '';
 216     if (s/^([0-9]+)//) {
 217         $addr1 = "$1";
 218         $addr1 = "\$. == $addr1" unless /^,/;
 219     }
 220     elsif (s/^\$//) {
 221         $addr1 = 'eof()';
 222     }
 223     elsif (s|^/||) {
 224         $addr1 = &fetchpat('/');
 225     }
 226     if (s/^,//) {
 227         if (s/^([0-9]+)//) {
 228             $addr2 = "$1";
 229         } elsif (s/^\$//) {
 230             $addr2 = "eof()";
 231         } elsif (s|^/||) {
 232             $addr2 = &fetchpat('/');
 233         } else {
 234             &Die("Invalid second address at line $.\n");
 235         }
 236         if ($addr2 =~ /^\d+$/) {
 237             $addr1 .= "..$addr2";
 238         }
 239         else {
 240             $addr1 .= "...$addr2";
 241         }
 242     }
 243
 244     # Now we check for metacommands {, }, and ! and worry
 245     # about indentation.
 246
 247     s/^[ \t]+//;
 248     # a { to keep vi happy
 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) {
 268             $space = ' ' x $shiftwidth;
 269         } else {
 270             $space = '';
 271         }
 272         $_ = &transmogrify();
 273     }
 274
 275     # See if we can optimize to modifier form.
 276
 277     if ($addr1) {
 278         if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
 279           $_ !~ / if / && $_ !~ / unless /) {
 280             s/;$/ $if $addr1;/;
 281             $_ = substr($_,$shiftwidth,1000);
 282         } else {
 283             $_ = "$if ($addr1) $l\n$change$_$rmaybe";
 284         }
 285         $change = '';
 286         next LINE;
 287     }
 288 } continue {
 289     @lines = split(/\n/,$_);
 290     for (@lines) {
 291         unless (s/^ *<<--//) {
 292             print BODY &tab;
 293         }
 294         print BODY $_, "\n";
 295     }
 296     $indent += $indmod;
 297     $indmod = 0;
 298     if ($redo) {
 299         $_ = $redo;
 300         $redo = '';
 301         redo LINE;
 302     }
 303 }
 304 if ($lastlinewaslabel++) {
 305     $indent += 4;
 306     print BODY &tab, ";\n";
 307     $indent -= 4;
 308 }
 309
 310 if ($appendseen || $tseen || !$assumen) {
 311     $printit++ if $dseen || (!$assumen && !$assumep);
 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
 339 EOT
 340
 341 print BODY &q(<<'EOT');
 342 :       }
 343 EOT
 344 }
 345
 346 close BODY;
 347
 348 unless ($debug) {
 349     open(HEAD,">/tmp/sperl2$$.c")
 350       || &Die("Can't open temp file 2: $!\n");
 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;
 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 $_;
 364     }
 365     close HEAD;
 366
 367     print &q(<<"EOT");
 368 :       $startperl
 369 :       eval 'exec $perlpath -S \$0 \${1+"\$@"}'
 370 :               if \$running_under_some_shell;
 371 :
 372 EOT
 373     open(BODY,"cc -E /tmp/sperl2$$.c |") ||
 374         &Die("Can't reopen temp file: $!\n");
 375     while (<BODY>) {
 376         /^# [0-9]/ && next;
 377         /^[ \t]*$/ && next;
 378         s/^<><>//;
 379         print;
 380     }
 381 }
 382
 383 &Cleanup;
 384 exit;
 385
 386 sub Cleanup {
 387     chdir "/tmp";
 388     unlink "sperl$$", "sperl2$$", "sperl2$$.c";
 389 }
 390 sub Die {
 391     &Cleanup;
 392     die $_[0];
 393 }
 394 sub tab {
 395     "\t" x ($indent / 8) . ' ' x ($indent % 8);
 396 }
 397 sub make_filehandle {
 398     local($_) = $_[0];
 399     local($fname) = $_;
 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: \$!";
 412 EOT
 413         $seen{$fname} = $_;
 414     }
 415     $seen{$fname};
 416 }
 417
 418 sub make_label {
 419     local($label) = @_;
 420     $label =~ s/[^a-zA-Z0-9]/_/g;
 421     if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
 422     $label = substr($label,0,8);
 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
 428     $label;
 429 }
 430
 431 sub transmogrify {
 432     {   # case
 433         if (/^d/) {
 434             $dseen++;
 435             chop($_ = &q(<<'EOT'));
 436 :       <<--#ifdef PRINTIT
 437 :       $printit = 0;
 438 :       <<--#endif
 439 :       next LINE;
 440 EOT
 441             $sawnext++;
 442             next;
 443         }
 444
 445         if (/^n/) {
 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
 471 EOT
 472             next;
 473         }
 474
 475         if (/^a/) {
 476             $appendseen++;
 477             $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
 478             $lastline = 0;
 479             while (<>) {
 480                 s/^[ \t]*//;
 481                 s/^[\\]//;
 482                 unless (s|\\$||) { $lastline = 1;}
 483                 s/^([ \t]*\n)/<><>$1/;
 484                 $command .= $_;
 485                 $command .= '<<--';
 486                 last if $lastline;
 487             }
 488             $_ = $command . "End_Of_Text";
 489             last;
 490         }
 491
 492         if (/^[ic]/) {
 493             if (/^c/) { $change = 1; }
 494             $addr1 = 1 if $addr1 eq '';
 495             $addr1 = '$iter = (' . $addr1 . ')';
 496             $command = $space .
 497               "    if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
 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             }
 509             $_ = $command . "End_Of_Text";
 510             if ($change) {
 511                 $dseen++;
 512                 $change = "$_\n";
 513                 chop($_ = &q(<<"EOT"));
 514 :       <<--#ifdef PRINTIT
 515 :       $space\$printit = 0;
 516 :       <<--#endif
 517 :       ${space}next LINE;
 518 EOT
 519                 $sawnext++;
 520             }
 521             last;
 522         }
 523
 524         if (/^s/) {
 525             $delim = substr($_,1,1);
 526             $len = length($_);
 527             $repl = $end = 0;
 528             $inbracket = 0;
 529             for ($i = 2; $i < $len; $i++) {
 530                 $c = substr($_,$i,1);
 531                 if ($c eq $delim) {
 532                     if ($inbracket) {
 533                         substr($_, $i, 0) = '\\';
 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 '\\') {
 547                     $i++;
 548                     if ($i >= $len) {
 549                         $_ .= 'n';
 550                         $_ .= <>;
 551                         $len = length($_);
 552                         $_ = substr($_,0,--$len);
 553                     }
 554                     elsif (substr($_,$i,1) =~ /^[n]$/) {
 555                         ;
 556                     }
 557                     elsif (!$repl &&
 558                       substr($_,$i,1) =~ /^[(){}\w]$/) {
 559                         $i--;
 560                         $len--;
 561                         substr($_, $i, 1) = '';
 562                     }
 563                     elsif (!$repl &&
 564                       substr($_,$i,1) =~ /^[<>]$/) {
 565                         substr($_,$i,1) = 'b';
 566                     }
 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++;
 580                 }
 581                 elsif ($c eq '[' && !$repl) {
 582                     $i++ if substr($_,$i,1) eq '^';
 583                     $i++ if substr($_,$i,1) eq ']';
 584                     $inbracket = 1;
 585                 }
 586                 elsif ($c eq ']') {
 587                     $inbracket = 0;
 588                 }
 589                 elsif ($c eq "\t") {
 590                     substr($_, $i, 1) = '\\t';
 591                     $i++;
 592                     $len++;
 593                 }
 594                 elsif (!$repl && index("()+",$c) >= 0) {
 595                     substr($_, $i, 0) = '\\';
 596                     $i++;
 597                     $len++;
 598                 }
 599             }
 600             &Die("Malformed substitution at line $.\n")
 601               unless $end;
 602             $pat = substr($_, 0, $repl + 1);
 603             $repl = substr($_, $repl+1, $end-$repl-1);
 604             $end = substr($_, $end + 1, 1000);
 605             &simplify($pat);
 606             $dol = '$';
 607             $subst = "$pat$repl$delim";
 608             $cmd = '';
 609             while ($end) {
 610                 if ($end =~ s/^g//) {
 611                     $subst .= 'g';
 612                     next;
 613                 }
 614                 if ($end =~ s/^p//) {
 615                     $cmd .= ' && (print)';
 616                     next;
 617                 }
 618                 if ($end =~ s/^w[ \t]*//) {
 619                     $fh = &make_filehandle($end);
 620                     $cmd .= " && (print $fh \$_)";
 621                     $end = '';
 622                     next;
 623                 }
 624                 &Die("Unrecognized substitution command".
 625                   "($end) at line $.\n");
 626             }
 627             chop ($_ = &q(<<"EOT"));
 628 :       <<--#ifdef TSEEN
 629 :       $subst && \$tflag++$cmd;
 630 :       <<--#else
 631 :       $subst$cmd;
 632 :       <<--#endif
 633 EOT
 634             next;
 635         }
 636
 637         if (/^p/) {
 638             $_ = 'print;';
 639             next;
 640         }
 641
 642         if (/^w/) {
 643             s/^w[ \t]*//;
 644             $fh = &make_filehandle($_);
 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/) {
 658             $_ = 'print $1 if /^(.*)/;';
 659             next;
 660         }
 661
 662         if (/^D/) {
 663             chop($_ = &q(<<'EOT'));
 664 :       s/^.*\n?//;
 665 :       redo LINE if $_;
 666 :       next LINE;
 667 EOT
 668             $sawnext++;
 669             next;
 670         }
 671
 672         if (/^N/) {
 673             chop($_ = &q(<<'EOT'));
 674 :       $_ .= "\n";
 675 :       $len1 = length;
 676 :       $_ .= <>;
 677 :       chop if $len1 < length;
 678 :       <<--#ifdef TSEEN
 679 :       $tflag = 0;
 680 :       <<--#endif
 681 EOT
 682             next;
 683         }
 684
 685         if (/^h/) {
 686             $_ = '$hold = $_;';
 687             next;
 688         }
 689
 690         if (/^H/) {
 691             $_ = '$hold .= "\n"; $hold .= $_;';
 692             next;
 693         }
 694
 695         if (/^g/) {
 696             $_ = '$_ = $hold;';
 697             next;
 698         }
 699
 700         if (/^G/) {
 701             $_ = '$_ .= "\n"; $_ .= $hold;';
 702             next;
 703         }
 704
 705         if (/^x/) {
 706             $_ = '($_, $hold) = ($hold, $_);';
 707             next;
 708         }
 709
 710         if (/^b$/) {
 711             $_ = 'next LINE;';
 712             $sawnext++;
 713             next;
 714         }
 715
 716         if (/^b/) {
 717             s/^b[ \t]*//;
 718             $lab = &make_label($_);
 719             if ($lab eq $toplabel) {
 720                 $_ = 'redo LINE;';
 721             } else {
 722                 $_ = "goto $lab;";
 723             }
 724             next;
 725         }
 726
 727         if (/^t$/) {
 728             $_ = 'next LINE if $tflag;';
 729             $sawnext++;
 730             $tseen++;
 731             next;
 732         }
 733
 734         if (/^t/) {
 735             s/^t[ \t]*//;
 736             $lab = &make_label($_);
 737             $_ = q/if ($tflag) {$tflag = 0; /;
 738             if ($lab eq $toplabel) {
 739                 $_ .= 'redo LINE;}';
 740             } else {
 741                 $_ .= "goto $lab;}";
 742             }
 743             $tseen++;
 744             next;
 745         }
 746
 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
 757         if (/^=/) {
 758             $_ = 'print $.;';
 759             next;
 760         }
 761
 762         if (/^q/) {
 763             chop($_ = &q(<<'EOT'));
 764 :       close(ARGV);
 765 :       @ARGV = ();
 766 :       next LINE;
 767 EOT
 768             $sawnext++;
 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
 781 sub fetchpat {
 782     local($outer) = @_;
 783     local($addr) = $outer;
 784     local($inbracket);
 785     local($prefix,$delim,$ch);
 786
 787     # Process pattern one potential delimiter at a time.
 788
 789     DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
 790         $prefix = $1;
 791         $delim = $2;
 792         if ($delim eq '\\') {
 793             s/(.)//;
 794             $ch = $1;
 795             $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
 796             $ch = 'b' if $ch =~ /^[<>]$/;
 797             $delim .= $ch;
 798         }
 799         elsif ($delim eq '[') {
 800             $inbracket = 1;
 801             s/^\^// && ($delim .= '^');
 802             s/^]// && ($delim .= ']');
 803         }
 804         elsif ($delim eq ']') {
 805             $inbracket = 0;
 806         }
 807         elsif ($inbracket || $delim ne $outer) {
 808             $delim = '\\' . $delim;
 809         }
 810         $addr .= $prefix;
 811         $addr .= $delim;
 812         if ($delim eq $outer && !$inbracket) {
 813             last DELIM;
 814         }
 815     }
 816     $addr =~ s/\t/\\t/g;
 817     &simplify($addr);
 818     $addr;
 819 }
 820
 821 sub q {
 822     local($string) = @_;
 823     local($*) = 1;
 824     $string =~ s/^:\t?//g;
 825     $string;
 826 }
 827
 828 sub 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
 849 !NO!SUBS!
 850
 851 close OUT or die "Can't close $file: $!";
 852 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 853 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';