From d0a23a28764f62522461516baf582705c21bb007 Mon Sep 17 00:00:00 2001
From: ian <ian>
Date: Thu, 5 Jul 2001 13:25:51 +0000
Subject: [PATCH 1/1] Found.

---
 gpt | 154 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 154 insertions(+)
 create mode 100755 gpt

diff --git a/gpt b/gpt
new file mode 100755
index 0000000..7fca9c5
--- /dev/null
+++ b/gpt
@@ -0,0 +1,154 @@
+#!/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;
+}
-- 
2.30.2