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 unless ($debug) {
 347
 348     print &q(<<"EOT");
 349 :       $startperl
 350 :       eval 'exec $perlpath -S \$0 \${1+"\$@"}'
 351 :               if \$running_under_some_shell;
 352 :
 353 EOT
 354     print"$opens\n" if $opens;
 355     seek(BODY, 0, 0) || die "Can't rewind temp file: $!\n";
 356     while (<BODY>) {
 357         /^[ \t]*$/ && next;
 358         /^#ifdef (\w+)/ && ((${lc $1} || &skip), next);
 359         /^#else/ && (&skip, next);
 360         /^#endif/ && next;
 361         s/^<><>//;
 362         print;
 363     }
 364 }
 365
 366 &Cleanup;
 367 exit;
 368
 369 sub Cleanup {
 370     unlink "/tmp/sperl$$";
 371 }
 372 sub Die {
 373     &Cleanup;
 374     die $_[0];
 375 }
 376 sub tab {
 377     "\t" x ($indent / 8) . ' ' x ($indent % 8);
 378 }
 379 sub make_filehandle {
 380     local($_) = $_[0];
 381     local($fname) = $_;
 382     if (!$seen{$fname}) {
 383         $_ = "FH_" . $_ if /^\d/;
 384         s/[^a-zA-Z0-9]/_/g;
 385         s/^_*//;
 386         $_ = "\U$_";
 387         if ($fhseen{$_}) {
 388             for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
 389             $_ .= $tmp;
 390         }
 391         $fhseen{$_} = 1;
 392         $opens .= &q(<<"EOT");
 393 :       open($_, '>$fname') || die "Can't create $fname: \$!";
 394 EOT
 395         $seen{$fname} = $_;
 396     }
 397     $seen{$fname};
 398 }
 399
 400 sub make_label {
 401     local($label) = @_;
 402     $label =~ s/[^a-zA-Z0-9]/_/g;
 403     if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
 404     $label = substr($label,0,8);
 405
 406     # Could be a reserved word, so capitalize it.
 407     substr($label,0,1) =~ y/a-z/A-Z/
 408       if $label =~ /^[a-z]/;
 409
 410     $label;
 411 }
 412
 413 sub transmogrify {
 414     {   # case
 415         if (/^d/) {
 416             $dseen++;
 417             chop($_ = &q(<<'EOT'));
 418 :       <<--#ifdef PRINTIT
 419 :       $printit = 0;
 420 :       <<--#endif
 421 :       next LINE;
 422 EOT
 423             $sawnext++;
 424             next;
 425         }
 426
 427         if (/^n/) {
 428             chop($_ = &q(<<'EOT'));
 429 :       <<--#ifdef PRINTIT
 430 :       <<--#ifdef DSEEN
 431 :       <<--#ifdef ASSUMEP
 432 :       print if $printit++;
 433 :       <<--#else
 434 :       if ($printit)
 435 :           { print; }
 436 :       else
 437 :           { $printit++ unless $nflag; }
 438 :       <<--#endif
 439 :       <<--#else
 440 :       print if $printit;
 441 :       <<--#endif
 442 :       <<--#else
 443 :       print;
 444 :       <<--#endif
 445 :       <<--#ifdef APPENDSEEN
 446 :       if ($atext) {chop $atext; print $atext; $atext = '';}
 447 :       <<--#endif
 448 :       $_ = <>;
 449 :       chop;
 450 :       <<--#ifdef TSEEN
 451 :       $tflag = 0;
 452 :       <<--#endif
 453 EOT
 454             next;
 455         }
 456
 457         if (/^a/) {
 458             $appendseen++;
 459             $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
 460             $lastline = 0;
 461             while (<>) {
 462                 s/^[ \t]*//;
 463                 s/^[\\]//;
 464                 unless (s|\\$||) { $lastline = 1;}
 465                 s/^([ \t]*\n)/<><>$1/;
 466                 $command .= $_;
 467                 $command .= '<<--';
 468                 last if $lastline;
 469             }
 470             $_ = $command . "End_Of_Text";
 471             last;
 472         }
 473
 474         if (/^[ic]/) {
 475             if (/^c/) { $change = 1; }
 476             $addr1 = 1 if $addr1 eq '';
 477             $addr1 = '$iter = (' . $addr1 . ')';
 478             $command = $space .
 479               "    if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
 480             $lastline = 0;
 481             while (<>) {
 482                 s/^[ \t]*//;
 483                 s/^[\\]//;
 484                 unless (s/\\$//) { $lastline = 1;}
 485                 s/'/\\'/g;
 486                 s/^([ \t]*\n)/<><>$1/;
 487                 $command .= $_;
 488                 $command .= '<<--';
 489                 last if $lastline;
 490             }
 491             $_ = $command . "End_Of_Text";
 492             if ($change) {
 493                 $dseen++;
 494                 $change = "$_\n";
 495                 chop($_ = &q(<<"EOT"));
 496 :       <<--#ifdef PRINTIT
 497 :       $space\$printit = 0;
 498 :       <<--#endif
 499 :       ${space}next LINE;
 500 EOT
 501                 $sawnext++;
 502             }
 503             last;
 504         }
 505
 506         if (/^s/) {
 507             $delim = substr($_,1,1);
 508             $len = length($_);
 509             $repl = $end = 0;
 510             $inbracket = 0;
 511             for ($i = 2; $i < $len; $i++) {
 512                 $c = substr($_,$i,1);
 513                 if ($c eq $delim) {
 514                     if ($inbracket) {
 515                         substr($_, $i, 0) = '\\';
 516                         $i++;
 517                         $len++;
 518                     }
 519                     else {
 520                         if ($repl) {
 521                             $end = $i;
 522                             last;
 523                         } else {
 524                             $repl = $i;
 525                         }
 526                     }
 527                 }
 528                 elsif ($c eq '\\') {
 529                     $i++;
 530                     if ($i >= $len) {
 531                         $_ .= 'n';
 532                         $_ .= <>;
 533                         $len = length($_);
 534                         $_ = substr($_,0,--$len);
 535                     }
 536                     elsif (substr($_,$i,1) =~ /^[n]$/) {
 537                         ;
 538                     }
 539                     elsif (!$repl &&
 540                       substr($_,$i,1) =~ /^[(){}\w]$/) {
 541                         $i--;
 542                         $len--;
 543                         substr($_, $i, 1) = '';
 544                     }
 545                     elsif (!$repl &&
 546                       substr($_,$i,1) =~ /^[<>]$/) {
 547                         substr($_,$i,1) = 'b';
 548                     }
 549                     elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
 550                         substr($_,$i-1,1) = '$';
 551                     }
 552                 }
 553                 elsif ($c eq '&' && $repl) {
 554                     substr($_, $i, 0) = '$';
 555                     $i++;
 556                     $len++;
 557                 }
 558                 elsif ($c eq '$' && $repl) {
 559                     substr($_, $i, 0) = '\\';
 560                     $i++;
 561                     $len++;
 562                 }
 563                 elsif ($c eq '[' && !$repl) {
 564                     $i++ if substr($_,$i,1) eq '^';
 565                     $i++ if substr($_,$i,1) eq ']';
 566                     $inbracket = 1;
 567                 }
 568                 elsif ($c eq ']') {
 569                     $inbracket = 0;
 570                 }
 571                 elsif ($c eq "\t") {
 572                     substr($_, $i, 1) = '\\t';
 573                     $i++;
 574                     $len++;
 575                 }
 576                 elsif (!$repl && index("()+",$c) >= 0) {
 577                     substr($_, $i, 0) = '\\';
 578                     $i++;
 579                     $len++;
 580                 }
 581             }
 582             &Die("Malformed substitution at line $.\n")
 583               unless $end;
 584             $pat = substr($_, 0, $repl + 1);
 585             $repl = substr($_, $repl+1, $end-$repl-1);
 586             $end = substr($_, $end + 1, 1000);
 587             &simplify($pat);
 588             $subst = "$pat$repl$delim";
 589             $cmd = '';
 590             while ($end) {
 591                 if ($end =~ s/^g//) {
 592                     $subst .= 'g';
 593                     next;
 594                 }
 595                 if ($end =~ s/^p//) {
 596                     $cmd .= ' && (print)';
 597                     next;
 598                 }
 599                 if ($end =~ s/^w[ \t]*//) {
 600                     $fh = &make_filehandle($end);
 601                     $cmd .= " && (print $fh \$_)";
 602                     $end = '';
 603                     next;
 604                 }
 605                 &Die("Unrecognized substitution command".
 606                   "($end) at line $.\n");
 607             }
 608             chop ($_ = &q(<<"EOT"));
 609 :       <<--#ifdef TSEEN
 610 :       $subst && \$tflag++$cmd;
 611 :       <<--#else
 612 :       $subst$cmd;
 613 :       <<--#endif
 614 EOT
 615             next;
 616         }
 617
 618         if (/^p/) {
 619             $_ = 'print;';
 620             next;
 621         }
 622
 623         if (/^w/) {
 624             s/^w[ \t]*//;
 625             $fh = &make_filehandle($_);
 626             $_ = "print $fh \$_;";
 627             next;
 628         }
 629
 630         if (/^r/) {
 631             $appendseen++;
 632             s/^r[ \t]*//;
 633             $file = $_;
 634             $_ = "\$atext .= `cat $file 2>/dev/null`;";
 635             next;
 636         }
 637
 638         if (/^P/) {
 639             $_ = 'print $1 if /^(.*)/;';
 640             next;
 641         }
 642
 643         if (/^D/) {
 644             chop($_ = &q(<<'EOT'));
 645 :       s/^.*\n?//;
 646 :       redo LINE if $_;
 647 :       next LINE;
 648 EOT
 649             $sawnext++;
 650             next;
 651         }
 652
 653         if (/^N/) {
 654             chop($_ = &q(<<'EOT'));
 655 :       $_ .= "\n";
 656 :       $len1 = length;
 657 :       $_ .= <>;
 658 :       chop if $len1 < length;
 659 :       <<--#ifdef TSEEN
 660 :       $tflag = 0;
 661 :       <<--#endif
 662 EOT
 663             next;
 664         }
 665
 666         if (/^h/) {
 667             $_ = '$hold = $_;';
 668             next;
 669         }
 670
 671         if (/^H/) {
 672             $_ = '$hold .= "\n"; $hold .= $_;';
 673             next;
 674         }
 675
 676         if (/^g/) {
 677             $_ = '$_ = $hold;';
 678             next;
 679         }
 680
 681         if (/^G/) {
 682             $_ = '$_ .= "\n"; $_ .= $hold;';
 683             next;
 684         }
 685
 686         if (/^x/) {
 687             $_ = '($_, $hold) = ($hold, $_);';
 688             next;
 689         }
 690
 691         if (/^b$/) {
 692             $_ = 'next LINE;';
 693             $sawnext++;
 694             next;
 695         }
 696
 697         if (/^b/) {
 698             s/^b[ \t]*//;
 699             $lab = &make_label($_);
 700             if ($lab eq $toplabel) {
 701                 $_ = 'redo LINE;';
 702             } else {
 703                 $_ = "goto $lab;";
 704             }
 705             next;
 706         }
 707
 708         if (/^t$/) {
 709             $_ = 'next LINE if $tflag;';
 710             $sawnext++;
 711             $tseen++;
 712             next;
 713         }
 714
 715         if (/^t/) {
 716             s/^t[ \t]*//;
 717             $lab = &make_label($_);
 718             $_ = q/if ($tflag) {$tflag = 0; /;
 719             if ($lab eq $toplabel) {
 720                 $_ .= 'redo LINE;}';
 721             } else {
 722                 $_ .= "goto $lab;}";
 723             }
 724             $tseen++;
 725             next;
 726         }
 727
 728         if (/^y/) {
 729             s/abcdefghijklmnopqrstuvwxyz/a-z/g;
 730             s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
 731             s/abcdef/a-f/g;
 732             s/ABCDEF/A-F/g;
 733             s/0123456789/0-9/g;
 734             s/01234567/0-7/g;
 735             $_ .= ';';
 736         }
 737
 738         if (/^=/) {
 739             $_ = 'print $.;';
 740             next;
 741         }
 742
 743         if (/^q/) {
 744             chop($_ = &q(<<'EOT'));
 745 :       close(ARGV);
 746 :       @ARGV = ();
 747 :       next LINE;
 748 EOT
 749             $sawnext++;
 750             next;
 751         }
 752     } continue {
 753         if ($space) {
 754             s/^/$space/;
 755             s/(\n)(.)/$1$space$2/g;
 756         }
 757         last;
 758     }
 759     $_;
 760 }
 761
 762 sub fetchpat {
 763     local($outer) = @_;
 764     local($addr) = $outer;
 765     local($inbracket);
 766     local($prefix,$delim,$ch);
 767
 768     # Process pattern one potential delimiter at a time.
 769
 770     DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
 771         $prefix = $1;
 772         $delim = $2;
 773         if ($delim eq '\\') {
 774             s/(.)//;
 775             $ch = $1;
 776             $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
 777             $ch = 'b' if $ch =~ /^[<>]$/;
 778             $delim .= $ch;
 779         }
 780         elsif ($delim eq '[') {
 781             $inbracket = 1;
 782             s/^\^// && ($delim .= '^');
 783             s/^]// && ($delim .= ']');
 784         }
 785         elsif ($delim eq ']') {
 786             $inbracket = 0;
 787         }
 788         elsif ($inbracket || $delim ne $outer) {
 789             $delim = '\\' . $delim;
 790         }
 791         $addr .= $prefix;
 792         $addr .= $delim;
 793         if ($delim eq $outer && !$inbracket) {
 794             last DELIM;
 795         }
 796     }
 797     $addr =~ s/\t/\\t/g;
 798     &simplify($addr);
 799     $addr;
 800 }
 801
 802 sub q {
 803     local($string) = @_;
 804     local($*) = 1;
 805     $string =~ s/^:\t?//g;
 806     $string;
 807 }
 808
 809 sub simplify {
 810     $_[0] =~ s/_a-za-z0-9/\\w/ig;
 811     $_[0] =~ s/a-z_a-z0-9/\\w/ig;
 812     $_[0] =~ s/a-za-z_0-9/\\w/ig;
 813     $_[0] =~ s/a-za-z0-9_/\\w/ig;
 814     $_[0] =~ s/_0-9a-za-z/\\w/ig;
 815     $_[0] =~ s/0-9_a-za-z/\\w/ig;
 816     $_[0] =~ s/0-9a-z_a-z/\\w/ig;
 817     $_[0] =~ s/0-9a-za-z_/\\w/ig;
 818     $_[0] =~ s/\[\\w\]/\\w/g;
 819     $_[0] =~ s/\[^\\w\]/\\W/g;
 820     $_[0] =~ s/\[0-9\]/\\d/g;
 821     $_[0] =~ s/\[^0-9\]/\\D/g;
 822     $_[0] =~ s/\\d\\d\*/\\d+/g;
 823     $_[0] =~ s/\\D\\D\*/\\D+/g;
 824     $_[0] =~ s/\\w\\w\*/\\w+/g;
 825     $_[0] =~ s/\\t\\t\*/\\t+/g;
 826     $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
 827     $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
 828 }
 829
 830 sub skip {
 831     local($level) = 0;
 832
 833     while(<BODY>) {
 834         /^#ifdef/ && $level++;
 835         /^#else/  && !$level && return;
 836         /^#endif/ && !$level-- && return;
 837     }
 838
 839     die "Unterminated `#ifdef' conditional\n";
 840 }
 841 !NO!SUBS!
 842
 843 close OUT or die "Can't close $file: $!";
 844 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 845 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';