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