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, ">&4";
  21
  22 $fn= '<command line>';
  23 if (!@main::ARGV) {
  24     $lno= '<empty>';
  25     $fh= new IO::Handle;
  26     $fh->fdopen(fileno(STDIN),'r') or err("fdopen stdin: $!");
  27     process_fh($fh,'<standard input>');
  28     $fh->close or err("close stdin: $!\n");
  29 } else {
  30     for ($i=0; $i<@main::ARGV; $i++) {
  31         $lno= '<arg#'.($i+1).'>';
  32         $value= $main::ARGV[$i];
  33         $fh= new IO::File $value,'r' or err("cannot open file \`$value': $!");
  34         process_fh($fh,$value);
  35         $fh->close or err("gpt: cannot close file \`$value': $!");
  36     }
  37 }
  38 close STDOUT or die "gpt: close stdout: $!\n";
  39 exit 0;
  40
  41 sub err ($) { die "gpt: $fn:$lno: $_[0]\n"; }
  42
  43 sub add_perl ($) {
  44     my ($str) = @_;
  45     if (@oplist>1) { $substr.= $str; }
  46     else { $expr.= $str; }
  47 }
  48
  49 sub add_text ($) {
  50     my ($str) = @_;
  51     if (@oplist) { $substr.=$str; }
  52     else { output($str); }
  53 }
  54
  55 sub eval_expr () {
  56     my ($value);
  57     $@='';
  58     print DEBUG "E $fn:$lno:e\`$expr'\n";
  59     $value= do {
  60         package main;
  61         eval $GenericPrepTemplate::expr;
  62     };
  63     if (length $@) {
  64         chomp $@; err("error: $@");
  65     }
  66     print DEBUG "E $fn:$lno:v\`$value'\n";
  67     $value;
  68 }
  69
  70 sub process_input () {
  71     my ($esc,$top,$want,$fh,$value,$wasyes);
  72     while (length $l) {
  73         print DEBUG "L $fn:$lno:",join('',@oplist),
  74                     ":`$l' e\`$expr' s\`$substr'\n";
  75         if (@oplist & 1) { # scanning perl
  76             if ($l =~ m/(.)\@\@/m || $l =~ m/^()\@\@/m) {
  77                 ($to,$op,$esc,$l) = ($`,$1,$&,$');
  78                 add_perl($to);
  79                 if ($op =~ m/[ 0-9a-zA-Z_\;\)\}?]/ || $op eq '') {
  80                     $top= pop @oplist;
  81                     if (!@oplist) {
  82                         # And evaluate.
  83                         $expr.= $op unless $op =~ m/[?]/;
  84                         $value= eval_expr();
  85                         if ($top eq '<') {
  86                             process_file($value);
  87                         } elsif ($top eq '?') {
  88                             push @oplist, '?',':;'.!!$value;
  89                         } elsif ($top ne '-') {
  90                             output($value);
  91                         }
  92                         $expr='';
  93                     } else {
  94                         $substr.= $esc;
  95                     }
  96                 } elsif ($op =~ m/[\(\{]/) {
  97                     if (@oplist>1) { $substr.= $esc; }
  98                     push @oplist, $op;
  99                 } else {
 100                     err("bad escape sequence $op\@\@ in perl part");
 101                 }
 102             } else {
 103                 add_perl($l);
 104                 $l= '';
 105             }
 106         } else { # scanning text
 107             if ($l =~ m/\@\@(.|\n)/) {
 108                 ($to,$op,$esc,$l) = ($`,$1,$&,$');
 109                 add_text($to);
 110                 if ($op =~ m/[-< \$?]/) {
 111                     $substr.= $esc if @oplist;
 112                     push @oplist, $op;
 113                 } elsif ($op =~ m/[\)\}\;\:]/) {
 114                     err("unmatched closing \@\@$op") unless @oplist;
 115                     $want= pop @oplist;
 116                     if ($want =~ y/({/)}/) {
 117                         $wasyes=-1;
 118                         err("found \@\@$op but wanted \@\@$want")
 119                             unless $want eq $op;
 120                     } elsif ($want =~ m/^([:;]+)(1?)$/) {
 121                         ($want,$wasyes)=($1,$2);
 122                         err("found \@\@$op where not expected (wanted ".
 123                             join(' or ', map { "\@\@$_" } split //, $want).")")
 124                             unless $op =~ m/^[$want]$/;
 125                         '?' eq pop @oplist or die;
 126                         if ($wasyes) {
 127                             local ($l) = ($substr);
 128                             local ($substr,$expr,$to,$op);
 129                             process_input();
 130                         };
 131                         $substr='';
 132                         $esc='';
 133                         if ($op eq ':') {
 134                             push @oplist, '?',';'.!$wasyes;
 135                         }
 136                     } else {
 137                         die "internal /$want/ /$op/";
 138                     }
 139                     if (@oplist==1) {
 140                         # Just finished a substr.
 141                         $substri++;
 142                         $substrs[$substri]= $substr;
 143                         print DEBUG "S $fn:$lno:S$substri\`$substr'\n";
 144                         $expr.= ' GenericPrepTemplate::output(' if $op eq '}';
 145                         $expr.= " GenericPrepTemplate::process_i($substri) ";
 146                         $expr.= " );\n" if $op eq '}';
 147                         $substr='';
 148                     } else {
 149                         $substr.= $esc;
 150                     }
 151                 } else {
 152                     err("bad escape sequence \@\@$op in text part");
 153                 }
 154             } else {
 155                 add_text($l);
 156                 $l= '';
 157             }
 158         }
 159     }
 160 }
 161
 162 sub process_fh ($$) {
 163     local ($fh,$fn) = @_;
 164     local ($l,$lno, @oplist,$substr,$expr,$to,$op);
 165
 166     while (defined ($l= $fh->getline)) {
 167         next if $l =~ m,^\#\! ?/\S+/gpt\b, && $.==1;
 168         $lno= $.;
 169         process_input();
 170     }
 171     die "gpt: $fn: read error: $!" if $fh->error;
 172 }
 173
 174 sub output ($) {
 175     if (defined $outbuf) {
 176         print DEBUG "O \`$outbuf'+\`$_[0]'\n";
 177         $outbuf.= $_[0];
 178     } else {
 179         print DEBUG "O w\`$_[0]'\n";
 180         print STDOUT $_[0] or err("write stdout: $!");
 181     }
 182 }
 183
 184 sub process_i ($) {
 185     my ($i) = @_;
 186     local ($l,$fn,$lno) = ($substrs[$i], "$fn<sub#$i>", '');
 187     local ($outbuf, @oplist,$substr,$expr,$to,$op);
 188     $outbuf='';
 189     process_input();
 190     return $outbuf;
 191 }