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