x2p/s2p.PL

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