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