+#!/usr/bin/perl
+
+package GenericPrepTemplate;
+
+#BEGIN {
+# use Exporter ();
+# use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+# $VERSION= 1.00;
+# @ISA= qw(Exporter);
+# @EXPORT= qw(&process_input);
+# %EXPORT_TAGS= ();
+# @EXPORT_OK= qw();
+#}
+#use vars @EXPORT_OK;
+#use vars qw($fh);
+
+use IO::Handle;
+use IO::File;
+
+open DEBUG, ">&4";
+
+$fh= new IO::Handle;
+$fh->fdopen(fileno(STDIN),'r') or die;
+process_fh($fh,'<standard input>');
+close STDOUT or die "gpt: close stdout: $!\n";
+exit 0;
+
+sub err ($) { die "gpt: $fn:$lno: $_[0]\n"; }
+
+sub add_perl ($) {
+ my ($str) = @_;
+ if (@oplist>1) { $substr.= $str; }
+ else { $expr.= $str; }
+}
+
+sub add_text ($) {
+ my ($str) = @_;
+ if (@oplist) { $substr.=$str; }
+ else { output($str); }
+}
+
+sub process_input () {
+ my ($esc,$top,$want,$fh,$value);
+ while (length $l) {
+ print DEBUG "L $fn:$lno:",join('',@oplist),
+ ":`$l' e\`$expr' s\`$substr'\n";
+ if (@oplist & 1) { # scanning perl
+ if ($l =~ m/(.)\@\@/m || $l =~ m/^()\@\@/m) {
+ ($to,$op,$esc,$l) = ($`,$1,$&,$');
+ add_perl($to);
+ if ($op =~ m/[ 0-9a-zA-Z_\;\)\}]/ || $op eq '') {
+ $top= pop @oplist;
+ if (!@oplist) {
+ # And evaluate.
+ $expr.= $op;
+ $@='';
+ print DEBUG "E $fn:$lno:e\`$expr'\n";
+ $value= do {
+ package main;
+ eval $GenericPrepTemplate::expr;
+ };
+ if (length $@) {
+ chomp $@; err("error: $@");
+ }
+ print DEBUG "E $fn:$lno:v\`$value'\n";
+ if ($top eq '<') {
+ $fh= new IO::File $value,'r'
+ or err("cannot open file \`$value': $!");
+ process_fh($fh,$value);
+ $fh->close;
+ } elsif ($top ne '-') {
+ output($value);
+ }
+ $expr='';
+ } else {
+ $substr.= $esc;
+ }
+ } elsif ($op =~ m/[\(\{]/) {
+ if (@oplist>1) { $substr.= $esc; }
+ push @oplist, $op;
+ } else {
+ err("bad escape sequence $op\@\@ in perl part");
+ }
+ } else {
+ add_perl($l);
+ $l= '';
+ }
+ } else { # scanning text
+ if ($l =~ m/\@\@(.|\n)/) {
+ ($to,$op,$esc,$l) = ($`,$1,$&,$');
+ add_text($to);
+ if ($op =~ m/[-< \$]/) {
+ $substr.= $esc if @oplist;
+ push @oplist, $op;
+ } elsif ($op =~ m/[\)\}]/) {
+ err("unmatched closing \@\@$op") unless @oplist;
+ my ($want);
+ $want= $oplist[$#oplist] eq '(' ? ')' : '}';
+ err("found \@\@$op but wanted \@\@$want")
+ unless $want eq $op;
+ pop @oplist;
+ if (@oplist==1) {
+ # Just finished a substr.
+ $substri++;
+ $substrs[$substri]= $substr;
+ print DEBUG "S $fn:$lno:S$substri\`$substr'\n";
+ $expr.= ' GenericPrepTemplate::output(' if $op eq '}';
+ $expr.= " GenericPrepTemplate::process_i($substri) ";
+ $expr.= " );\n" if $op eq '}';
+ $substr='';
+ } else {
+ $substr.= $esc;
+ }
+ } else {
+ err("bad escape sequence \@\@$op in text part");
+ }
+ } else {
+ add_text($l);
+ $l= '';
+ }
+ }
+ }
+}
+
+sub process_fh ($$) {
+ local ($fh,$fn) = @_;
+ local ($l,$lno, @oplist,$substr,$expr,$to,$op);
+
+ while (defined ($l= $fh->getline)) {
+ next if $l =~ m,^\#\! ?/\S+/gpt\b, && $.==1;
+ $lno= $.;
+ process_input();
+ }
+ die "gpt: $fn: read error: $!" if $fh->error;
+}
+
+sub output ($) {
+ if (defined $outbuf) {
+ print DEBUG "O \`$outbuf'+\`$_[0]'\n";
+ $outbuf.= $_[0];
+ } else {
+ print DEBUG "O w\`$_[0]'\n";
+ print STDOUT $_[0] or err("write stdout: $!");
+ }
+}
+
+sub process_i ($) {
+ my ($i) = @_;
+ local ($l,$fn,$lno) = ($substrs[$i], "$fn<sub#$i>", '');
+ local ($outbuf, @oplist,$substr,$expr,$to,$op);
+ $outbuf='';
+ process_input();
+ return $outbuf;
+}