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