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