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