home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / x2p / s2p.PL < prev    next >
Perl Script  |  2000-03-03  |  16KB  |  855 lines
  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;
  855.