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 '&' && $repl) {
 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                     $i++ if substr($_,$i,1) eq '^';
 567                     $i++ if substr($_,$i,1) eq ']';
 568                     $inbracket = 1;
 569                 }
 570                 elsif ($c eq ']') {
 571                     $inbracket = 0;
 572                 }
 573                 elsif ($c eq "\t") {
 574                     substr($_, $i, 1) = '\\t';
 575                     $i++;
 576                     $len++;
 577                 }
 578                 elsif (!$repl && index("()+",$c) >= 0) {
 579                     substr($_, $i, 0) = '\\';
 580                     $i++;
 581                     $len++;
 582                 }
 583             }
 584             &Die("Malformed substitution at line $.\n")
 585               unless $end;
 586             $pat = substr($_, 0, $repl + 1);
 587             $repl = substr($_, $repl+1, $end-$repl-1);
 588             $end = substr($_, $end + 1, 1000);
 589             &simplify($pat);
 590             $subst = "$pat$repl$delim";
 591             $cmd = '';
 592             while ($end) {
 593                 if ($end =~ s/^g//) {
 594                     $subst .= 'g';
 595                     next;
 596                 }
 597                 if ($end =~ s/^p//) {
 598                     $cmd .= ' && (print)';
 599                     next;
 600                 }
 601                 if ($end =~ s/^w[ \t]*//) {
 602                     $fh = &make_filehandle($end);
 603                     $cmd .= " && (print $fh \$_)";
 604                     $end = '';
 605                     next;
 606                 }
 607                 &Die("Unrecognized substitution command".
 608                   "($end) at line $.\n");
 609             }
 610             chop ($_ = &q(<<"EOT"));
 611 :       <<--#ifdef TSEEN
 612 :       $subst && \$tflag++$cmd;
 613 :       <<--#else
 614 :       $subst$cmd;
 615 :       <<--#endif
 616 EOT
 617             next;
 618         }
 619
 620         if (/^p/) {
 621             $_ = 'print;';
 622             next;
 623         }
 624
 625         if (/^w/) {
 626             s/^w[ \t]*//;
 627             $fh = &make_filehandle($_);
 628             $_ = "print $fh \$_;";
 629             next;
 630         }
 631
 632         if (/^r/) {
 633             $appendseen++;
 634             s/^r[ \t]*//;
 635             $file = $_;
 636             $_ = "\$atext .= `cat $file 2>/dev/null`;";
 637             next;
 638         }
 639
 640         if (/^P/) {
 641             $_ = 'print $1 if /^(.*)/;';
 642             next;
 643         }
 644
 645         if (/^D/) {
 646             chop($_ = &q(<<'EOT'));
 647 :       s/^.*\n?//;
 648 :       redo LINE if $_;
 649 :       next LINE;
 650 EOT
 651             $sawnext++;
 652             next;
 653         }
 654
 655         if (/^N/) {
 656             chop($_ = &q(<<'EOT'));
 657 :       $_ .= "\n";
 658 :       $len1 = length;
 659 :       $_ .= <>;
 660 :       chop if $len1 < length;
 661 :       <<--#ifdef TSEEN
 662 :       $tflag = 0;
 663 :       <<--#endif
 664 EOT
 665             next;
 666         }
 667
 668         if (/^h/) {
 669             $_ = '$hold = $_;';
 670             next;
 671         }
 672
 673         if (/^H/) {
 674             $_ = '$hold .= "\n", $hold .= $_;';
 675             next;
 676         }
 677
 678         if (/^g/) {
 679             $_ = '$_ = $hold;';
 680             next;
 681         }
 682
 683         if (/^G/) {
 684             $_ = '$_ .= "\n", $_ .= $hold;';
 685             next;
 686         }
 687
 688         if (/^x/) {
 689             $_ = '($_, $hold) = ($hold, $_);';
 690             next;
 691         }
 692
 693         if (/^b$/) {
 694             $_ = 'next LINE;';
 695             $sawnext++;
 696             next;
 697         }
 698
 699         if (/^b/) {
 700             s/^b[ \t]*//;
 701             $lab = &make_label($_);
 702             if ($lab eq $toplabel) {
 703                 $_ = 'redo LINE;';
 704             } else {
 705                 $_ = "goto $lab;";
 706             }
 707             next;
 708         }
 709
 710         if (/^t$/) {
 711             $_ = 'next LINE if $tflag;';
 712             $sawnext++;
 713             $tseen++;
 714             next;
 715         }
 716
 717         if (/^t/) {
 718             s/^t[ \t]*//;
 719             $lab = &make_label($_);
 720             $_ = q/if ($tflag) {$tflag = 0; /;
 721             if ($lab eq $toplabel) {
 722                 $_ .= 'redo LINE;}';
 723             } else {
 724                 $_ .= "goto $lab;}";
 725             }
 726             $tseen++;
 727             next;
 728         }
 729
 730         if (/^y/) {
 731             s/abcdefghijklmnopqrstuvwxyz/a-z/g;
 732             s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
 733             s/abcdef/a-f/g;
 734             s/ABCDEF/A-F/g;
 735             s/0123456789/0-9/g;
 736             s/01234567/0-7/g;
 737             $_ .= ';';
 738         }
 739
 740         if (/^=/) {
 741             $_ = 'print $.;';
 742             next;
 743         }
 744
 745         if (/^q/) {
 746             chop($_ = &q(<<'EOT'));
 747 :       close(ARGV);
 748 :       @ARGV = ();
 749 :       next LINE;
 750 EOT
 751             $sawnext++;
 752             next;
 753         }
 754     } continue {
 755         if ($space) {
 756             s/^/$space/;
 757             s/(\n)(.)/$1$space$2/g;
 758         }
 759         last;
 760     }
 761     $_;
 762 }
 763
 764 sub fetchpat {
 765     local($outer) = @_;
 766     local($addr) = $outer;
 767     local($inbracket);
 768     local($prefix,$delim,$ch);
 769
 770     # Process pattern one potential delimiter at a time.
 771
 772     DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
 773         $prefix = $1;
 774         $delim = $2;
 775         if ($delim eq '\\') {
 776             s/(.)//;
 777             $ch = $1;
 778             $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
 779             $ch = 'b' if $ch =~ /^[<>]$/;
 780             $delim .= $ch;
 781         }
 782         elsif ($delim eq '[') {
 783             $inbracket = 1;
 784             s/^\^// && ($delim .= '^');
 785             s/^]// && ($delim .= ']');
 786         }
 787         elsif ($delim eq ']') {
 788             $inbracket = 0;
 789         }
 790         elsif ($inbracket || $delim ne $outer) {
 791             $delim = '\\' . $delim;
 792         }
 793         $addr .= $prefix;
 794         $addr .= $delim;
 795         if ($delim eq $outer && !$inbracket) {
 796             last DELIM;
 797         }
 798     }
 799     $addr =~ s/\t/\\t/g;
 800     &simplify($addr);
 801     $addr;
 802 }
 803
 804 sub q {
 805     local($string) = @_;
 806     local($*) = 1;
 807     $string =~ s/^:\t?//g;
 808     $string;
 809 }
 810
 811 sub simplify {
 812     $_[0] =~ s/_a-za-z0-9/\\w/ig;
 813     $_[0] =~ s/a-z_a-z0-9/\\w/ig;
 814     $_[0] =~ s/a-za-z_0-9/\\w/ig;
 815     $_[0] =~ s/a-za-z0-9_/\\w/ig;
 816     $_[0] =~ s/_0-9a-za-z/\\w/ig;
 817     $_[0] =~ s/0-9_a-za-z/\\w/ig;
 818     $_[0] =~ s/0-9a-z_a-z/\\w/ig;
 819     $_[0] =~ s/0-9a-za-z_/\\w/ig;
 820     $_[0] =~ s/\[\\w\]/\\w/g;
 821     $_[0] =~ s/\[^\\w\]/\\W/g;
 822     $_[0] =~ s/\[0-9\]/\\d/g;
 823     $_[0] =~ s/\[^0-9\]/\\D/g;
 824     $_[0] =~ s/\\d\\d\*/\\d+/g;
 825     $_[0] =~ s/\\D\\D\*/\\D+/g;
 826     $_[0] =~ s/\\w\\w\*/\\w+/g;
 827     $_[0] =~ s/\\t\\t\*/\\t+/g;
 828     $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
 829     $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
 830 }
 831
 832 sub skip {
 833     local($level) = 0;
 834
 835     while(<BODY>) {
 836         /^#ifdef/ && $level++;
 837         /^#else/  && !$level && return;
 838         /^#endif/ && !$level-- && return;
 839     }
 840
 841     die "Unterminated `#ifdef' conditional\n";
 842 }
 843 !NO!SUBS!
 844
 845 close OUT or die "Can't close $file: $!";
 846 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 847 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 848 chdir $origdir;