home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 5 Edit / 05-Edit.zip / PERL30X.ZIP / S2P.CMD < prev    next >
OS/2 REXX Batch file  |  1991-01-14  |  12KB  |  674 lines
  1. extproc perl -Sx
  2. #!perl
  3.  
  4. $bin = 'c:/bin';
  5.  
  6. # $Header: s2p.SH,v 3.0.1.6 90/10/20 02:21:43 lwall Locked $
  7. #
  8. # $Log:    s2p.SH,v $
  9. # Revision 3.0.1.6  90/10/20  02:21:43  lwall
  10. # patch37: changed some ". config.sh" to ". ./config.sh"
  11. #
  12. # Revision 3.0.1.5  90/10/16  11:32:40  lwall
  13. # patch29: s2p modernized
  14. #
  15. # Revision 3.0.1.4  90/08/09  05:50:43  lwall
  16. # patch19: s2p didn't translate \n right
  17. #
  18. # Revision 3.0.1.3  90/03/01  10:31:21  lwall
  19. # patch9: s2p didn't handle \< and \>
  20. #
  21. # Revision 3.0.1.2  89/11/17  15:51:27  lwall
  22. # patch5: in s2p, line labels without a subsequent statement were done wrong
  23. # patch5: s2p left residue in /tmp
  24. #
  25. # Revision 3.0.1.1  89/11/11  05:08:25  lwall
  26. # patch2: in s2p, + within patterns needed backslashing
  27. # patch2: s2p was printing out some debugging info to the output file
  28. #
  29. # Revision 3.0  89/10/18  15:35:02  lwall
  30. # 3.0 baseline
  31. #
  32. # Revision 2.0.1.1  88/07/11  23:26:23  root
  33. # patch2: s2p didn't put a proper prologue on output script
  34. #
  35. # Revision 2.0  88/06/05  00:15:55  root
  36. # Baseline version 2.0.
  37. #
  38. #
  39.  
  40. $indent = 4;
  41. $shiftwidth = 4;
  42. $l = '{'; $r = '}';
  43.  
  44. while ($ARGV[0] =~ /^-/) {
  45.     $_ = shift;
  46.   last if /^--/;
  47.     if (/^-D/) {
  48.     $debug++;
  49.     open(BODY,'>-');
  50.     next;
  51.     }
  52.     if (/^-n/) {
  53.     $assumen++;
  54.     next;
  55.     }
  56.     if (/^-p/) {
  57.     $assumep++;
  58.     next;
  59.     }
  60.     die "I don't recognize this switch: $_\n";
  61. }
  62.  
  63. unless ($debug) {
  64.     open(BODY,">sperl$$") ||
  65.       &Die("Can't open temp file: $!\n");
  66. }
  67.  
  68. if (!$assumen && !$assumep) {
  69.     print BODY <<'EOT';
  70. while ($ARGV[0] =~ /^-/) {
  71.     $_ = shift;
  72.   last if /^--/;
  73.     if (/^-n/) {
  74.     $nflag++;
  75.     next;
  76.     }
  77.     die "I don't recognize this switch: $_\\n";
  78. }
  79.  
  80. EOT
  81. }
  82.  
  83. print BODY <<'EOT';
  84.  
  85. #ifdef PRINTIT
  86. #ifdef ASSUMEP
  87. $printit++;
  88. #else
  89. $printit++ unless $nflag;
  90. #endif
  91. #endif
  92. LINE: while (<>) {
  93. EOT
  94.  
  95. LINE: while (<>) {
  96.  
  97.     # Wipe out surrounding whitespace.
  98.  
  99.     s/[ \t]*(.*)\n$/$1/;
  100.  
  101.     # Perhaps it's a label/comment.
  102.  
  103.     if (/^:/) {
  104.     s/^:[ \t]*//;
  105.     $label = &make_label($_);
  106.     if ($. == 1) {
  107.         $toplabel = $label;
  108.     }
  109.     $_ = "$label:";
  110.     if ($lastlinewaslabel++) {
  111.         $indent += 4;
  112.         print BODY &tab, ";\n";
  113.         $indent -= 4;
  114.     }
  115.     if ($indent >= 2) {
  116.         $indent -= 2;
  117.         $indmod = 2;
  118.     }
  119.     next;
  120.     } else {
  121.     $lastlinewaslabel = '';
  122.     }
  123.  
  124.     # Look for one or two address clauses
  125.  
  126.     $addr1 = '';
  127.     $addr2 = '';
  128.     if (s/^([0-9]+)//) {
  129.     $addr1 = "$1";
  130.     }
  131.     elsif (s/^\$//) {
  132.     $addr1 = 'eof()';
  133.     }
  134.     elsif (s|^/||) {
  135.     $addr1 = &fetchpat('/');
  136.     }
  137.     if (s/^,//) {
  138.     if (s/^([0-9]+)//) {
  139.         $addr2 = "$1";
  140.     } elsif (s/^\$//) {
  141.         $addr2 = "eof()";
  142.     } elsif (s|^/||) {
  143.         $addr2 = &fetchpat('/');
  144.     } else {
  145.         &Die("Invalid second address at line $.\n");
  146.     }
  147.     $addr1 .= " .. $addr2";
  148.     }
  149.  
  150.     # Now we check for metacommands {, }, and ! and worry
  151.     # about indentation.
  152.  
  153.     s/^[ \t]+//;
  154.     # a { to keep vi happy
  155.     if ($_ eq '}') {
  156.     $indent -= 4;
  157.     next;
  158.     }
  159.     if (s/^!//) {
  160.     $if = 'unless';
  161.     $else = "$r else $l\n";
  162.     } else {
  163.     $if = 'if';
  164.     $else = '';
  165.     }
  166.     if (s/^{//) {    # a } to keep vi happy
  167.     $indmod = 4;
  168.     $redo = $_;
  169.     $_ = '';
  170.     $rmaybe = '';
  171.     } else {
  172.     $rmaybe = "\n$r";
  173.     if ($addr2 || $addr1) {
  174.         $space = ' ' x $shiftwidth;
  175.     } else {
  176.         $space = '';
  177.     }
  178.     $_ = &transmogrify();
  179.     }
  180.  
  181.     # See if we can optimize to modifier form.
  182.  
  183.     if ($addr1) {
  184.     if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
  185.       $_ !~ / if / && $_ !~ / unless /) {
  186.         s/;$/ $if $addr1;/;
  187.         $_ = substr($_,$shiftwidth,1000);
  188.     } else {
  189.         $_ = "$if ($addr1) $l\n$change$_$rmaybe";
  190.     }
  191.     $change = '';
  192.     next LINE;
  193.     }
  194. } continue {
  195.     @lines = split(/\n/,$_);
  196.     for (@lines) {
  197.     unless (s/^ *<<--//) {
  198.         print BODY &tab;
  199.     }
  200.     print BODY $_, "\n";
  201.     }
  202.     $indent += $indmod;
  203.     $indmod = 0;
  204.     if ($redo) {
  205.     $_ = $redo;
  206.     $redo = '';
  207.     redo LINE;
  208.     }
  209. }
  210. if ($lastlinewaslabel++) {
  211.     $indent += 4;
  212.     print BODY &tab, ";\n";
  213.     $indent -= 4;
  214. }
  215.  
  216. print BODY "}\n";
  217. if ($appendseen || $tseen || !$assumen) {
  218.     $printit++ if $dseen || (!$assumen && !$assumep);
  219.     print BODY <<'EOT';
  220.  
  221. continue {
  222. #ifdef PRINTIT
  223. #ifdef DSEEN
  224. #ifdef ASSUMEP
  225.     print if $printit++;
  226. #else
  227.     if ($printit)
  228.     { print; }
  229.     else
  230.     { $printit++ unless $nflag; }
  231. #endif
  232. #else
  233.     print if $printit;
  234. #endif
  235. #else
  236.     print;
  237. #endif
  238. #ifdef TSEEN
  239.     $tflag = '';
  240. #endif
  241. #ifdef APPENDSEEN
  242.     if ($atext) { print $atext; $atext = ''; }
  243. #endif
  244. }
  245. EOT
  246. }
  247.  
  248. close BODY;
  249.  
  250. unless ($debug) {
  251.     open(HEAD,">sperl2$$.c")
  252.       || &Die("Can't open temp file 2: $!\n");
  253.     print HEAD "#define PRINTIT\n" if ($printit);
  254.     print HEAD "#define APPENDSEEN\n" if ($appendseen);
  255.     print HEAD "#define TSEEN\n" if ($tseen);
  256.     print HEAD "#define DSEEN\n" if ($dseen);
  257.     print HEAD "#define ASSUMEN\n" if ($assumen);
  258.     print HEAD "#define ASSUMEP\n" if ($assumep);
  259.     if ($opens) {print HEAD "$opens\n";}
  260.     open(BODY,"sperl$$")
  261.       || &Die("Can't reopen temp file: $!\n");
  262.     while (<BODY>) {
  263.     print HEAD $_;
  264.     }
  265.     close HEAD;
  266.  
  267.     print <<"EOT";
  268. #!$bin/perl
  269. eval 'exec $bin/perl -S \$0 \$*'
  270.     if \$running_under_some_shell;
  271.  
  272. EOT
  273.     open(BODY,"cc -E sperl2$$.c |") ||
  274.     &Die("Can't reopen temp file: $!\n");
  275.     while (<BODY>) {
  276.     /^# [0-9]/ && next;
  277.     /^[ \t]*$/ && next;
  278.     s/^<><>//;
  279.     print;
  280.     }
  281. }
  282.  
  283. &Cleanup;
  284. exit;
  285.  
  286. sub Cleanup {
  287.     unlink "sperl$$", "sperl2$$", "sperl2$$.c";
  288. }
  289. sub Die {
  290.     &Cleanup;
  291.     die $_[0];
  292. }
  293. sub tab {
  294.     "\t" x ($indent / 8) . ' ' x ($indent % 8);
  295. }
  296. sub make_filehandle {
  297.     local($_) = $_[0];
  298.     local($fname) = $_;
  299.     s/[^a-zA-Z]/_/g;
  300.     s/^_*//;
  301.     substr($_,0,1) =~ y/a-z/A-Z/ if /^[a-z]/;
  302.     if (!$seen{$_}) {
  303.     $opens .= <<"EOT";
  304. open($_,'>$fname') || die "Can't create $fname";
  305. EOT
  306.     }
  307.     $seen{$_} = $_;
  308. }
  309.  
  310. sub make_label {
  311.     local($label) = @_;
  312.     $label =~ s/[^a-zA-Z0-9]/_/g;
  313.     if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
  314.     $label = substr($label,0,8);
  315.  
  316.     # Could be a reserved word, so capitalize it.
  317.     substr($label,0,1) =~ y/a-z/A-Z/
  318.       if $label =~ /^[a-z]/;
  319.  
  320.     $label;
  321. }
  322.  
  323. sub transmogrify {
  324.     {    # case
  325.     if (/^d/) {
  326.         $dseen++;
  327.         chop($_ = <<'EOT');
  328. <<--#ifdef PRINTIT
  329. $printit = '';
  330. <<--#endif
  331. next LINE;
  332. EOT
  333.         next;
  334.     }
  335.  
  336.     if (/^n/) {
  337.         chop($_ = <<'EOT');
  338. <<--#ifdef PRINTIT
  339. <<--#ifdef DSEEN
  340. <<--#ifdef ASSUMEP
  341. print if $printit++;
  342. <<--#else
  343. if ($printit)
  344.     { print; }
  345. else
  346.     { $printit++ unless $nflag; }
  347. <<--#endif
  348. <<--#else
  349. print if $printit;
  350. <<--#endif
  351. <<--#else
  352. print;
  353. <<--#endif
  354. <<--#ifdef APPENDSEEN
  355. if ($atext) {print $atext; $atext = '';}
  356. <<--#endif
  357. $_ = <>;
  358. <<--#ifdef TSEEN
  359. $tflag = '';
  360. <<--#endif
  361. EOT
  362.         next;
  363.     }
  364.  
  365.     if (/^a/) {
  366.         $appendseen++;
  367.         $command = $space . '$atext .=' . "\n<<--'";
  368.         $lastline = 0;
  369.         while (<>) {
  370.         s/^[ \t]*//;
  371.         s/^[\\]//;
  372.         unless (s|\\$||) { $lastline = 1;}
  373.         s/'/\\'/g;
  374.         s/^([ \t]*\n)/<><>$1/;
  375.         $command .= $_;
  376.         $command .= '<<--';
  377.         last if $lastline;
  378.         }
  379.         $_ = $command . "';";
  380.         last;
  381.     }
  382.  
  383.     if (/^[ic]/) {
  384.         if (/^c/) { $change = 1; }
  385.         $addr1 = '$iter = (' . $addr1 . ')';
  386.         $command = $space . 'if ($iter == 1) { print'
  387.           . "\n<<--'";
  388.         $lastline = 0;
  389.         while (<>) {
  390.         s/^[ \t]*//;
  391.         s/^[\\]//;
  392.         unless (s/\\$//) { $lastline = 1;}
  393.         s/'/\\'/g;
  394.         s/^([ \t]*\n)/<><>$1/;
  395.         $command .= $_;
  396.         $command .= '<<--';
  397.         last if $lastline;
  398.         }
  399.         $_ = $command . "';}";
  400.         if ($change) {
  401.         $dseen++;
  402.         $change = "$_\n";
  403.         chop($_ = <<"EOT");
  404. <<--#ifdef PRINTIT
  405. $space\$printit = '';
  406. <<--#endif
  407. ${space}next LINE;
  408. EOT
  409.         }
  410.         last;
  411.     }
  412.  
  413.     if (/^s/) {
  414.         $delim = substr($_,1,1);
  415.         $len = length($_);
  416.         $repl = $end = 0;
  417.         $inbracket = 0;
  418.         for ($i = 2; $i < $len; $i++) {
  419.         $c = substr($_,$i,1);
  420.         if ($c eq $delim) {
  421.             if ($inbracket) {
  422.             substr($_, $i, 0) = '\\';
  423.             $i++;
  424.             $len++;
  425.             }
  426.             else {
  427.             if ($repl) {
  428.                 $end = $i;
  429.                 last;
  430.             } else {
  431.                 $repl = $i;
  432.             }
  433.             }
  434.         }
  435.         elsif ($c eq '\\') {
  436.             $i++;
  437.             if ($i >= $len) {
  438.             $_ .= 'n';
  439.             $_ .= <>;
  440.             $len = length($_);
  441.             $_ = substr($_,0,--$len);
  442.             }
  443.             elsif (substr($_,$i,1) =~ /^[n]$/) {
  444.             ;
  445.             }
  446.             elsif (!$repl &&
  447.               substr($_,$i,1) =~ /^[(){}\w]$/) {
  448.             $i--;
  449.             $len--;
  450.             substr($_, $i, 1) = '';
  451.             }
  452.             elsif (!$repl &&
  453.               substr($_,$i,1) =~ /^[<>]$/) {
  454.             substr($_,$i,1) = 'b';
  455.             }
  456.         }
  457.         elsif ($c eq '[' && !$repl) {
  458.             $i++ if substr($_,$i,1) eq '^';
  459.             $i++ if substr($_,$i,1) eq ']';
  460.             $inbracket = 1;
  461.         }
  462.         elsif ($c eq ']') {
  463.             $inbracket = 0;
  464.         }
  465.         elsif (!$repl && index("()+",$c) >= 0) {
  466.             substr($_, $i, 0) = '\\';
  467.             $i++;
  468.             $len++;
  469.         }
  470.         }
  471.         &Die("Malformed substitution at line $.\n")
  472.           unless $end;
  473.         $pat = substr($_, 0, $repl + 1);
  474.         $repl = substr($_, $repl+1, $end-$repl-1);
  475.         $end = substr($_, $end + 1, 1000);
  476.         $dol = '$';
  477.         $repl =~ s/\$/\\$/;
  478.         $repl =~ s'&'$&'g;
  479.         $repl =~ s/[\\]([0-9])/$dol$1/g;
  480.         $subst = "$pat$repl$delim";
  481.         $cmd = '';
  482.         while ($end) {
  483.         if ($end =~ s/^g//) {
  484.             $subst .= 'g';
  485.             next;
  486.         }
  487.         if ($end =~ s/^p//) {
  488.             $cmd .= ' && (print)';
  489.             next;
  490.         }
  491.         if ($end =~ s/^w[ \t]*//) {
  492.             $fh = &make_filehandle($end);
  493.             $cmd .= " && (print $fh \$_)";
  494.             $end = '';
  495.             next;
  496.         }
  497.         &Die("Unrecognized substitution command".
  498.           "($end) at line $.\n");
  499.         }
  500.         chop ($_ = <<"EOT");
  501. <<--#ifdef TSEEN
  502. $subst && \$tflag++$cmd;
  503. <<--#else
  504. $subst$cmd;
  505. <<--#endif
  506. EOT
  507.         next;
  508.     }
  509.  
  510.     if (/^p/) {
  511.         $_ = 'print;';
  512.         next;
  513.     }
  514.  
  515.     if (/^w/) {
  516.         s/^w[ \t]*//;
  517.         $fh = &make_filehandle($_);
  518.         $_ = "print $fh \$_;";
  519.         next;
  520.     }
  521.  
  522.     if (/^r/) {
  523.         $appendseen++;
  524.         s/^r[ \t]*//;
  525.         $file = $_;
  526.         $_ = "\$atext .= `cat $file 2>/dev/null`;";
  527.         next;
  528.     }
  529.  
  530.     if (/^P/) {
  531.         $_ = 'print $1 if /(^.*\n)/;';
  532.         next;
  533.     }
  534.  
  535.     if (/^D/) {
  536.         chop($_ = <<'EOT');
  537. s/^.*\n//;
  538. redo LINE if $_;
  539. next LINE;
  540. EOT
  541.         next;
  542.     }
  543.  
  544.     if (/^N/) {
  545.         chop($_ = <<'EOT');
  546. $_ .= <>;
  547. <<--#ifdef TSEEN
  548. $tflag = '';
  549. <<--#endif
  550. EOT
  551.         next;
  552.     }
  553.  
  554.     if (/^h/) {
  555.         $_ = '$hold = $_;';
  556.         next;
  557.     }
  558.  
  559.     if (/^H/) {
  560.         $_ = '$hold .= $_ ? $_ : "\n";';
  561.         next;
  562.     }
  563.  
  564.     if (/^g/) {
  565.         $_ = '$_ = $hold;';
  566.         next;
  567.     }
  568.  
  569.     if (/^G/) {
  570.         $_ = '$_ .= $hold ? $hold : "\n";';
  571.         next;
  572.     }
  573.  
  574.     if (/^x/) {
  575.         $_ = '($_, $hold) = ($hold, $_);';
  576.         next;
  577.     }
  578.  
  579.     if (/^b$/) {
  580.         $_ = 'next LINE;';
  581.         next;
  582.     }
  583.  
  584.     if (/^b/) {
  585.         s/^b[ \t]*//;
  586.         $lab = &make_label($_);
  587.         if ($lab eq $toplabel) {
  588.         $_ = 'redo LINE;';
  589.         } else {
  590.         $_ = "goto $lab;";
  591.         }
  592.         next;
  593.     }
  594.  
  595.     if (/^t$/) {
  596.         $_ = 'next LINE if $tflag;';
  597.         $tseen++;
  598.         next;
  599.     }
  600.  
  601.     if (/^t/) {
  602.         s/^t[ \t]*//;
  603.         $lab = &make_label($_);
  604.         $_ = q/if ($tflag) {$tflag = ''; /;
  605.         if ($lab eq $toplabel) {
  606.         $_ .= 'redo LINE;}';
  607.         } else {
  608.         $_ .= "goto $lab;}";
  609.         }
  610.         $tseen++;
  611.         next;
  612.     }
  613.  
  614.     if (/^=/) {
  615.         $_ = 'print "$.\n";';
  616.         next;
  617.     }
  618.  
  619.     if (/^q/) {
  620.         chop($_ = <<'EOT');
  621. close(ARGV);
  622. @ARGV = ();
  623. next LINE;
  624. EOT
  625.         next;
  626.     }
  627.     } continue {
  628.     if ($space) {
  629.         s/^/$space/;
  630.         s/(\n)(.)/$1$space$2/g;
  631.     }
  632.     last;
  633.     }
  634.     $_;
  635. }
  636.  
  637. sub fetchpat {
  638.     local($outer) = @_;
  639.     local($addr) = $outer;
  640.     local($inbracket);
  641.     local($prefix,$delim,$ch);
  642.  
  643.     # Process pattern one potential delimiter at a time.
  644.  
  645.     DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
  646.     $prefix = $1;
  647.     $delim = $2;
  648.     if ($delim eq '\\') {
  649.         s/(.)//;
  650.         $ch = $1;
  651.         $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
  652.         $ch = 'b' if $ch =~ /^[<>]$/;
  653.         $delim .= $ch;
  654.     }
  655.     elsif ($delim eq '[') {
  656.         $inbracket = 1;
  657.         s/^\^// && ($delim .= '^');
  658.         s/^]// && ($delim .= ']');
  659.     }
  660.     elsif ($delim eq ']') {
  661.         $inbracket = 0;
  662.     }
  663.     elsif ($inbracket || $delim ne $outer) {
  664.         $delim = '\\' . $delim;
  665.     }
  666.     $addr .= $prefix;
  667.     $addr .= $delim;
  668.     if ($delim eq $outer && !$inbracket) {
  669.         last DELIM;
  670.     }
  671.     }
  672.     $addr;
  673. }
  674.