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