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