#!/usr/bin/perl

#
#                          =====deeper=nesting===>>
#
#                     end of Perl fragment
#                      \n@@ \_@@  ;@@ )@@ }@@  \w@@
#                   <------------------------------------
#
#                   ------------------------------------>
#                      if    eval    eval+     eval+
#                       @@?   @@\_   ignore    include
#                             @@$     @@-      file
#    ___                      @@\n              @@<
#  ,'   `
#  |      processing                                       processing
#  `--->  as TEXT                                          as PERL
#  endif
#   @@;     vA      <------------------------------------
#           ||         then
#   comment ||          ?@@
#       @@# \/
#           /\       included text fragment as
#      else ||         string value    code to write out
#       @@: ||          (@@             {@@
#           ||      <------------------------------------
#           `'
#                   ------------------------------------>
#                     end of included text fragment
#                       @@)  @@}
#
#                          <<====deeper=nesting====
#

# gpt - a generic preprocessing tool
#  
#  This file is
#    Copyright (C) 2001 Ian Jackson <ian@davenant.greenend.org.uk>
#  
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2, or (at your option)
#  any later version.
#  
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#  
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software Foundation,
#  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 

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, ">/dev/null" or die "gpt: /dev/null: $!\n";

while ($main::ARGV[0] =~ m/^-/) {
    $_= shift @main::ARGV;
    next if m/^--$/;
    while (m/^-./) {
	if (s/^-d/-/) {
	    open DEBUG, ">&2" or die "gpt: debug to stderr: $!\n";
	} else {
	    die "gpt: unknown option \`$_'\n";
	}
    }
}

$fn= '<command line>';
if (!@main::ARGV) {
    $lno= '<empty>';
    $fh= new IO::Handle;
    $fh->fdopen(fileno(STDIN),'r') or err("fdopen stdin: $!");
    process_fh($fh,'<standard input>');
    $fh->close or err("close stdin: $!\n");
} else {
    for ($i=0; $i<@main::ARGV; $i++) {
	$lno= '<arg#'.($i+1).'>';
	process_file($main::ARGV[$i]);
    }
}
close STDOUT or die "gpt: close stdout: $!\n";
exit 0;

sub process_file ($) {
    my ($value) = @_;
    $fh= new IO::File $value,'r' or err("cannot open file \`$value': $!");
    process_fh($fh,$value);
    $fh->close or err("gpt: cannot close file \`$value': $!");
}

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 eval_expr () {		
    my ($value);
    $@='';
    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";
    $value;
}

sub process_input () {
    my ($esc,$top,$want,$fh,$value,$wasyes);
    while (length $l) {
	print DEBUG "L $fn:${lno}_",join('',@oplist),
	            "_`$l' e\`$expr' s\`$substr'\n";
	if (@oplist & 1) { # scanning perl
	    if ($l =~ m/^()\@\@/ || $l =~ m/([^\000])\@\@/) {
		($to,$op,$esc,$l) = ($`,$1,$&,$');
		add_perl($to);
		if ($op =~ m/[ \t\n0-9a-zA-Z_\;\)\}?]/ || $op eq '') {
		    $top= pop @oplist;
		    if ($top eq '?') {
			$op eq '?' or err("expected ?\@\@, got \@\@");
		    } else {
			$op ne '?' or err("found ?\@\@ not after \@\@?");
		    }
		    if (!@oplist) {
			# And evaluate.
			$expr.= $op unless $op eq '?';
			$value= eval_expr();
			if ($top eq '<') {
			    process_file($value);
			} elsif ($top eq '?') {
			    push @oplist, '?',':;'.!!$value;
			} 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/[-< \$?\n]/) {
		    if (!@oplist) {
			add_perl($op) if $op =~ m/[\$]/;
		    } else {
			$substr.= $esc;
		    }
		    push @oplist, $op;
		} elsif ($op =~ m/[\)\}\;\:]/) {
		    err("unmatched closing \@\@$op") unless @oplist;
		    $want= pop @oplist;
		    if ($want =~ y/({/)}/) {
			$wasyes=-1;
			err("found \@\@$op but wanted \@\@$want")
			    unless $want eq $op;
		    } elsif ($want =~ m/^([:;]+)(1?)$/) {
			($want,$wasyes)=($1,$2);
			err("found \@\@$op where not expected (wanted ".
			    join(' or ', map { "\@\@$_" } split //, $want).")")
			    unless $op =~ m/^[$want]$/;
			'?' eq pop @oplist or die;
			if ($wasyes) {
			    local ($l) = ($substr);
			    local ($substr,$expr,$to,$op);
			    process_input();
			};
			$substr='';
			$esc='';
			if ($op eq ':') {
			    push @oplist, '?',';'.!$wasyes;
			}
		    } else {
			die "internal /$want/ /$op/";
		    }
		    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;
		    }
		} elsif ($op eq '#') {
		    $l =~ s/^[^\n]*//; $l =~ s/^\n//;
		} else {
		    err("bad escape sequence \@\@$op in text part");
		}
	    } else {
		add_text($l);
		$l= '';
	    }
	}
    }
}

sub close_nesteds () {
    my ($op);
    while (@oplist) {
	$op= $oplist[$#oplist];
	if (@oplist & 1) {
	    err("unterminated \@\@?") if $op eq '?';
	    $l=' @@';
	} else {
	    if ($op =~ y/({/)}/) {
		$l= '@@'.$op;
	    } elsif ($op =~ m/^[;:]+/) {
		$l= '@@;';
	    } else {
		die "intern /@oplist/";
	    }
	}
	process_input();
    }
}

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;
    close_nesteds();
}

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();
    close_nesteds();
    return $outbuf;
}