gpt

   1 #!/usr/bin/perl
   2
   3 package GenericPrepTemplate;
   4
   5 #BEGIN {
   6 #    use Exporter ();
   7 #    use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
   8 #    $VERSION= 1.00;
   9 #    @ISA= qw(Exporter);
  10 #    @EXPORT= qw(&process_input);
  11 #    %EXPORT_TAGS= ();
  12 #    @EXPORT_OK= qw();
  13 #}
  14 #use vars @EXPORT_OK;
  15 #use vars qw($fh);
  16
  17 use IO::Handle;
  18 use IO::File;
  19
  20 open DEBUG, ">/dev/null" or die "gpt: /dev/null: $!\n";
  21
  22 while ($main::ARGV[0] =~ m/^-/) {
  23     $_= shift @main::ARGV;
  24     next if m/^--$/;
  25     while (m/^-./) {
  26         if (s/^-d/-/) {
  27             open DEBUG, ">&2" or die "gpt: debug to stderr: $!\n";
  28         } else {
  29             die "gpt: unknown option \`$_'\n";
  30         }
  31     }
  32 }
  33
  34 $fn= '<command line>';
  35 if (!@main::ARGV) {
  36     $lno= '<empty>';
  37     $fh= new IO::Handle;
  38     $fh->fdopen(fileno(STDIN),'r') or err("fdopen stdin: $!");
  39     process_fh($fh,'<standard input>');
  40     $fh->close or err("close stdin: $!\n");
  41 } else {
  42     for ($i=0; $i<@main::ARGV; $i++) {
  43         $lno= '<arg#'.($i+1).'>';
  44         process_file($main::ARGV[$i]);
  45     }
  46 }
  47 close STDOUT or die "gpt: close stdout: $!\n";
  48 exit 0;
  49
  50 sub process_file ($) {
  51     my ($value) = @_;
  52     $fh= new IO::File $value,'r' or err("cannot open file \`$value': $!");
  53     process_fh($fh,$value);
  54     $fh->close or err("gpt: cannot close file \`$value': $!");
  55 }
  56
  57 sub err ($) { die "gpt: $fn:$lno: $_[0]\n"; }
  58
  59 sub add_perl ($) {
  60     my ($str) = @_;
  61     if (@oplist>1) { $substr.= $str; }
  62     else { $expr.= $str; }
  63 }
  64
  65 sub add_text ($) {
  66     my ($str) = @_;
  67     if (@oplist) { $substr.=$str; }
  68     else { output($str); }
  69 }
  70
  71 sub eval_expr () {
  72     my ($value);
  73     $@='';
  74     print DEBUG "E $fn:$lno:e\`$expr'\n";
  75     $value= do {
  76         package main;
  77         eval $GenericPrepTemplate::expr;
  78     };
  79     if (length $@) {
  80         chomp $@; err("error: $@");
  81     }
  82     print DEBUG "E $fn:$lno:v\`$value'\n";
  83     $value;
  84 }
  85
  86 sub process_input () {
  87     my ($esc,$top,$want,$fh,$value,$wasyes);
  88     while (length $l) {
  89         print DEBUG "L $fn:$lno:",join('',@oplist),
  90                     ":`$l' e\`$expr' s\`$substr'\n";
  91         if (@oplist & 1) { # scanning perl
  92             if ($l =~ m/^()\@\@/ || $l =~ m/([^\000])\@\@/) {
  93                 ($to,$op,$esc,$l) = ($`,$1,$&,$');
  94                 add_perl($to);
  95                 if ($op =~ m/[ \t\n0-9a-zA-Z_\;\)\}?]/ || $op eq '') {
  96                     $top= pop @oplist;
  97                     if (!@oplist) {
  98                         # And evaluate.
  99                         $expr.= $op unless $op =~ m/[?]/;
 100                         $value= eval_expr();
 101                         if ($top eq '<') {
 102                             process_file($value);
 103                         } elsif ($top eq '?') {
 104                             push @oplist, '?',':;'.!!$value;
 105                         } elsif ($top ne '-') {
 106                             output($value);
 107                         }
 108                         $expr='';
 109                     } else {
 110                         $substr.= $esc;
 111                     }
 112                 } elsif ($op =~ m/[\(\{]/) {
 113                     if (@oplist>1) { $substr.= $esc; }
 114                     push @oplist, $op;
 115                 } else {
 116                     err("bad escape sequence $op\@\@ in perl part");
 117                 }
 118             } else {
 119                 add_perl($l);
 120                 $l= '';
 121             }
 122         } else { # scanning text
 123             if ($l =~ m/\@\@(.|\n)/) {
 124                 ($to,$op,$esc,$l) = ($`,$1,$&,$');
 125                 add_text($to);
 126                 if ($op =~ m/[-< \$?\n]/) {
 127                     if (!@oplist) {
 128                         add_perl($op) if $op =~ m/[\$]/;
 129                     } else {
 130                         $substr.= $esc;
 131                     }
 132                     push @oplist, $op;
 133                 } elsif ($op =~ m/[\)\}\;\:]/) {
 134                     err("unmatched closing \@\@$op") unless @oplist;
 135                     $want= pop @oplist;
 136                     if ($want =~ y/({/)}/) {
 137                         $wasyes=-1;
 138                         err("found \@\@$op but wanted \@\@$want")
 139                             unless $want eq $op;
 140                     } elsif ($want =~ m/^([:;]+)(1?)$/) {
 141                         ($want,$wasyes)=($1,$2);
 142                         err("found \@\@$op where not expected (wanted ".
 143                             join(' or ', map { "\@\@$_" } split //, $want).")")
 144                             unless $op =~ m/^[$want]$/;
 145                         '?' eq pop @oplist or die;
 146                         if ($wasyes) {
 147                             local ($l) = ($substr);
 148                             local ($substr,$expr,$to,$op);
 149                             process_input();
 150                         };
 151                         $substr='';
 152                         $esc='';
 153                         if ($op eq ':') {
 154                             push @oplist, '?',';'.!$wasyes;
 155                         }
 156                     } else {
 157                         die "internal /$want/ /$op/";
 158                     }
 159                     if (@oplist==1) {
 160                         # Just finished a substr.
 161                         $substri++;
 162                         $substrs[$substri]= $substr;
 163                         print DEBUG "S $fn:$lno:S$substri\`$substr'\n";
 164                         $expr.= ' GenericPrepTemplate::output(' if $op eq '}';
 165                         $expr.= " GenericPrepTemplate::process_i($substri) ";
 166                         $expr.= " );\n" if $op eq '}';
 167                         $substr='';
 168                     } else {
 169                         $substr.= $esc;
 170                     }
 171                 } elsif ($op eq '#') {
 172                     $l =~ s/^[^\n]*//; $l =~ s/^\n//;
 173                 } else {
 174                     err("bad escape sequence \@\@$op in text part");
 175                 }
 176             } else {
 177                 add_text($l);
 178                 $l= '';
 179             }
 180         }
 181     }
 182 }
 183
 184 sub close_nesteds () {
 185     my ($op);
 186     while (@oplist) {
 187         $op= $oplist[$#oplist];
 188         if (@oplist & 1) {
 189             err("unterminated \@\@?") if $op eq '?';
 190             $l=' @@';
 191         } else {
 192             if ($op =~ y/({/)}/) {
 193                 $l= '@@'.$op;
 194             } elsif ($op =~ m/^[;:]+/) {
 195                 $l= '@@;';
 196             } else {
 197                 die "intern /@oplist/";
 198             }
 199         }
 200         process_input();
 201     }
 202 }
 203
 204 sub process_fh ($$) {
 205     local ($fh,$fn) = @_;
 206     local ($l,$lno, @oplist,$substr,$expr,$to,$op);
 207
 208     while (defined ($l= $fh->getline)) {
 209         next if $l =~ m,^\#\! ?/\S+/gpt\b, && $.==1;
 210         $lno= $.;
 211         process_input();
 212     }
 213
 214     die "gpt: $fn: read error: $!" if $fh->error;
 215     close_nesteds();
 216 }
 217
 218 sub output ($) {
 219     if (defined $outbuf) {
 220         print DEBUG "O \`$outbuf'+\`$_[0]'\n";
 221         $outbuf.= $_[0];
 222     } else {
 223         print DEBUG "O w\`$_[0]'\n";
 224         print STDOUT $_[0] or err("write stdout: $!");
 225     }
 226 }
 227
 228 sub process_i ($) {
 229     my ($i) = @_;
 230     local ($l,$fn,$lno) = ($substrs[$i], "$fn<sub#$i>", '');
 231     local ($outbuf, @oplist,$substr,$expr,$to,$op);
 232     $outbuf='';
 233     process_input();
 234     close_nesteds();
 235     return $outbuf;
 236 }