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/(.)\@\@/m || $l =~ m/^()\@\@/m) {
  93                 ($to,$op,$esc,$l) = ($`,$1,$&,$');
  94                 add_perl($to);
  95                 if ($op =~ m/[ 0-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/[-< \$?]/) {
 127                     $substr.= $esc if @oplist;
 128                     push @oplist, $op;
 129                     add_perl($op) if $op =~ m/[\$]/;
 130                 } elsif ($op =~ m/[\)\}\;\:]/) {
 131                     err("unmatched closing \@\@$op") unless @oplist;
 132                     $want= pop @oplist;
 133                     if ($want =~ y/({/)}/) {
 134                         $wasyes=-1;
 135                         err("found \@\@$op but wanted \@\@$want")
 136                             unless $want eq $op;
 137                     } elsif ($want =~ m/^([:;]+)(1?)$/) {
 138                         ($want,$wasyes)=($1,$2);
 139                         err("found \@\@$op where not expected (wanted ".
 140                             join(' or ', map { "\@\@$_" } split //, $want).")")
 141                             unless $op =~ m/^[$want]$/;
 142                         '?' eq pop @oplist or die;
 143                         if ($wasyes) {
 144                             local ($l) = ($substr);
 145                             local ($substr,$expr,$to,$op);
 146                             process_input();
 147                         };
 148                         $substr='';
 149                         $esc='';
 150                         if ($op eq ':') {
 151                             push @oplist, '?',';'.!$wasyes;
 152                         }
 153                     } else {
 154                         die "internal /$want/ /$op/";
 155                     }
 156                     if (@oplist==1) {
 157                         # Just finished a substr.
 158                         $substri++;
 159                         $substrs[$substri]= $substr;
 160                         print DEBUG "S $fn:$lno:S$substri\`$substr'\n";
 161                         $expr.= ' GenericPrepTemplate::output(' if $op eq '}';
 162                         $expr.= " GenericPrepTemplate::process_i($substri) ";
 163                         $expr.= " );\n" if $op eq '}';
 164                         $substr='';
 165                     } else {
 166                         $substr.= $esc;
 167                     }
 168                 } elsif ($op eq '#') {
 169                     $l =~ s/^[^\n]*//; $l =~ s/^\n//;
 170                 } else {
 171                     err("bad escape sequence \@\@$op in text part");
 172                 }
 173             } else {
 174                 add_text($l);
 175                 $l= '';
 176             }
 177         }
 178     }
 179 }
 180
 181 sub close_nesteds () {
 182     my ($op);
 183     while (@oplist) {
 184         $op= $oplist[$#oplist];
 185         if (@oplist & 1) {
 186             err("unterminated \@\@?") if $op eq '?';
 187             $l=' @@';
 188         } else {
 189             if ($op =~ y/({/)}/) {
 190                 $l= '@@'.$op;
 191             } elsif ($op =~ m/^[;:]+/) {
 192                 $l= '@@;';
 193             } else {
 194                 die "intern /@oplist/";
 195             }
 196         }
 197         process_input();
 198     }
 199 }
 200
 201 sub process_fh ($$) {
 202     local ($fh,$fn) = @_;
 203     local ($l,$lno, @oplist,$substr,$expr,$to,$op);
 204
 205     while (defined ($l= $fh->getline)) {
 206         next if $l =~ m,^\#\! ?/\S+/gpt\b, && $.==1;
 207         $lno= $.;
 208         process_input();
 209     }
 210
 211     die "gpt: $fn: read error: $!" if $fh->error;
 212     close_nesteds();
 213 }
 214
 215 sub output ($) {
 216     if (defined $outbuf) {
 217         print DEBUG "O \`$outbuf'+\`$_[0]'\n";
 218         $outbuf.= $_[0];
 219     } else {
 220         print DEBUG "O w\`$_[0]'\n";
 221         print STDOUT $_[0] or err("write stdout: $!");
 222     }
 223 }
 224
 225 sub process_i ($) {
 226     my ($i) = @_;
 227     local ($l,$fn,$lno) = ($substrs[$i], "$fn<sub#$i>", '');
 228     local ($outbuf, @oplist,$substr,$expr,$to,$op);
 229     $outbuf='';
 230     process_input();
 231     close_nesteds();
 232     return $outbuf;
 233 }