#!/usr/local/bin/perl
#  Copyright (C) 2001 David M. Turner <novalis-cfgcgi@novalis.org>

#  CFGCGI 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 of the License, or (at your option) any later version.

#  CFGCGI 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.

#  Requires 5.6, but I don't know why.  Well, I know about the open my $fh 
#  stuff, but even when I remove that, it still breaks under 5.005_004
  
use CGI;
use Data::Dumper;
use strict;

$CGI::POST_MAX=1024 * 100;  # max 100K posts
$CGI::DISABLE_UPLOADS = 1;  # no uploads

#an alternation
package alt;
use Data::Dumper;
sub new {
    my ($class, @items) = @_;
    my $self = {};
    push @{$self->{items}}, @items;
    bless $self, $class;
    return $self;
}


sub produce {
    my ($self, $oldgrammar, $grammar, $depth) = @_;
    my $i = int rand @{$self->{items}};
    my $item = $self->{items}->[$i];
    return $item->produce ($oldgrammar, $grammar, $depth + 1);
}

#a concatenation
package cat;
use Data::Dumper;
sub new {
    my ($class, @items) = @_;
    my $self;
    if (@items > 1) {
	$self = {};	
	push @{$self->{items}}, @items;
	bless $self, $class;
    } else {
	$self = $items[0];
    }
    return $self;
}

sub produce {
    my ($self, $oldgrammar, $grammar, $depth) = @_;
    my $item;

    foreach (@{$self->{items}}) {
	$item .= $_->produce ($oldgrammar, $grammar, $depth + 1);
    }
    return $item;
}

package term;
use Data::Dumper;
sub new {
    my ($class, $text) = @_;
    my $self = {text => $text};
;
    bless $self, $class;
    return $self;
}

sub produce {
    my ($self, $grammar, $funcgrammar, $depth) = @_;
    $main::showprod &&	print "&nbsp;" x $depth . "Terminal $self->{text} <BR>\n";
    return $self->{text};
}

package funcall;
sub new {
    my ($class, $func, @args) = @_;
    my $self;
    $self = { func => $func, args => \@args};	
    bless $self, $class;
    return $self;
}

sub produce {
    my ($self, $oldgrammar, $grammar, $depth) = @_;
    my %newgrammar = %$grammar;

    $main::showprod &&	print "&nbsp;" x $depth . "Function call $self->{func} <BR>\n";
    my @formals = $grammar->{$self->{func}}->formalparams;
    if (@formals != @{$self->{args}}) {
	die "Wrong number of formal parameters to func $self->{func}.  Expected " . scalar @formals . ", got " . scalar @{$self->{args}};
    }
    for (my $i = 0; $i < @formals; $i++) {
	$newgrammar{$formals [$i]} = $self->{args}->[$i];
    }
    $grammar->{$self->{func}}->produce ($grammar, \%newgrammar, $depth);
}


package func;

sub new {
    my ($class, $contents, @formalparams) = @_;
    my $self = {formalparams => \@formalparams, 
		contents => $contents,
	    };
    bless $self, $class;
    return $self;
}

sub formalparams {
    my $self = shift;
    return @{$self->{formalparams}};
}

sub produce {
    my ($self, $oldgrammar, $grammar, $depth) = @_;
    $self->{contents}->produce ($oldgrammar, $grammar, $depth + 1);
}


package nonterm;
use Data::Dumper;
sub new {
    my ($class, $text) = @_;
    my $self = {text => $text};
    bless $self, $class;
    return $self;
}

sub produce {
    my ($self, $oldgrammar, $grammar, $depth) = @_;
    if ($depth > 1000) {
	die "Too deep recursion.  You probably have an infinite loop.  I was trying to produce nonterminal <b>$self->{text}</b>, but the error might be in some terminal which produces <b>$self->{text}</b>.  Try turning trace on." ;
    }
    my $nonterm = $self->{text};
    $main::showprod &&	print "&nbsp;" x $depth . "Nonterminal $nonterm <BR>\n";
    unless (defined ($grammar->{$nonterm})) {
	die "Reference to undefined nonterminal '$nonterm'";
    }
    return $grammar->{$nonterm}->produce ($oldgrammar, $oldgrammar, $depth + 1);
}

sub text {
    return shift->{text};
}

package token;

sub new {
    my ($class, $text, $charpos) = @_;
    my $self = {text => $text, charpos => $charpos};
    bless $self, $class;
    return $self;
}

sub text {
    return shift->{text};
}

sub charpos {
    return shift->{charpos};
}

package main;

#Given a token ("terminal" or nonterminal), returns the appropriate 
#parse tree element
sub t_nt {
    my ($element) = @_;
    if ($element =~ /^"(.*)"$/) {
	return new term ($1);
    } else {
	return new nonterm ($element);
    }
}

sub parse {
    my ($items) = @_;
    my $state = 'init';
    my (@cat, @alts, @params, $func);

    while (@$items) {
	my $tok = shift @$items;
	my $i = $tok->text;

	if ($state eq 'init') {
	    if ($i eq '|') {
		die $tok->charpos . " Token Unexpected |"; 
	    } elsif ($i eq ')') {
		die $tok->charpos . " Token Unmatched )"; 
	    } elsif ($i eq ']') {
		die $tok->charpos . " Token Unmatched ]";
	    } elsif ($i eq '(') {
		push @cat, parse ($items);
		$state = 'cat';
	    } elsif ($i eq '[') {
		die $tok->charpos . " Token [ before nonterminal"; 
	    } else {
		push @cat, t_nt ($i);
		$state = 'cat';
	    }
	} elsif ($state eq 'cat') {
	    if ($i eq '|') {
		push @alts, new cat (@cat);
		@cat = ();
	    } elsif ($i eq ')') {
		if (!@cat) {
		    die $tok->charpos . " Token ) following | or ( makes no sense";
		}
		push @alts, new cat (@cat);
		return new alt (@alts);
	    } elsif ($i eq '(') {
		push @cat, parse ($items);
	    } elsif ($i eq '[') {
		my $func = pop @cat;
		if (ref ($func) ne 'nonterm') {
		    die $tok->charpos . " Token [ must follow nonterminal, not " . ref ($func);
		}
		$func = $func->text;
		push @cat, new funcall ($func,  parse ($items));
	    } elsif ($i eq ']') {
		push @alts, new cat (@cat);
		push @params, new alt (@alts);
		return @params;
	    } elsif ($i eq ',') {
		push @alts, new cat (@cat);
		push @params, new alt (@alts);
		@alts = @cat = ();
	    } else {
		push @cat, t_nt ($i);
	    }
	}
    }
    push @alts, new cat (@cat);
    return new alt (@alts);
}

sub parsegrammar {
    my $input = shift;
    my (@tokens, @params);
    my ($grammar, $nonterm, $pos, $nextnonterm);
    my $state = "readtokens";

    #break the grammar down into tokens consisting of
    #a string or a word or a symbol |=(){}[] or a comment #...
    while ($input =~ m/("(?:[^"\\]*(?:\\")*)*"|[[:alpha:]]+|\d+|[][,{}|()=\#])/gs) {
	my $tok = $1;
#	print "$tok\n";
	#in any state
	if ($tok eq '#') {
	    #comment
	    $input =~ m/$/smg;
	    next;
	}
	if ($state eq "readtokens") {
	    if ($tok eq '{') {
		$state = "readformals";
		$nextnonterm = (pop @tokens)->text;

	    } elsif ($tok eq '=') {
		#new production
		$nextnonterm = (pop @tokens)->text;
		if ($nextnonterm !~ /^\w+$/) {
		    die pos ($input) . " Token Item before = was not a valid nonterminal. Did you use {} when you meant to use []?";
		}
	    } else {
		#ordinary token
		push @tokens, new token ($tok, pos ($input));
	    }
	    if ($tok eq '=' || $tok eq '{') {
		if (@tokens) {
		    if (@params) {
			$grammar->{$nonterm} = new func (parse (\@tokens), @params);
			@params = ();
		    } else {
			$grammar->{$nonterm} = parse (\@tokens);
		    }
		    
		    if (@tokens) {
			die pos ($input) . " Token Tokens were left on stack";
		    }
		}
		$nonterm = $nextnonterm;
	    }
	} elsif ($state eq "readformals") {
	    if ($tok eq '=') {
		#new production
		$state = "readtokens";
	    } elsif ($tok eq '}' || $tok eq ',') {
		#ignore
	    } elsif ($tok eq '[' || $tok eq ']' || $tok eq '[' || $tok eq '|') {
		die  pos ($input) . " Token Unexpected token $tok in formal parameter list";
	    } else {
		#formal param
		push @params, $tok;
	    }
	}
        $pos = pos ($input);
    }
    pos $input = $pos;
    if (@tokens) {
	if (@params) {
	    $grammar->{$nonterm} = new func (parse (\@tokens), @params);
	    @params = ();
	} else {
	    $grammar->{$nonterm} = parse (\@tokens);
	}
	
	if (@tokens) {
	    die pos ($input) . " Token Tokens were left on stack";
	}
    }
    if ($input=~ /\G\s*\S/gs) {
	die pos ($input) . " Unprocessed input remains";
    }
    unless (exists $grammar->{S}) {
	die "0 No start state.  Please add a state named 'S'";
    }

    print "<!--\n";
    print Dumper $grammar;
    print "\n-->\n";
    return $grammar;
}

#a template looks like:
#
#section1:
#blah
#blah
#section2:
#more
#stuff
#...
#This returns { section1 => "blah\nblah", section2 => "more\nstuff"}
sub parsetemplate {
    my $file = shift;
    my ($section, $template) = "__COMMENTS";
    -s $file || die "Can't open template $template";
    open my $fh, $file || die "Can't open template $template";
    while (<$fh>) {
	if (/^(\w+):/) {
	    $section = $1;
	} else {
	    $template->{$section} .= $_;
	}      
    }
    close $fh;
    $template;
}

#prints a specific section of a template with the supplied set of variable bindings
sub printsect {
    my ($template, $bindings, @sect) = @_;
    foreach my $sect (@sect) {
	my $output = $template->{$sect};
	$output =~ s/\$\$(\w+)/$bindings->{$1}/g;
	print $output;
    }
}

sub escape {
    my $text = shift;
    $text =~ s/"/\%22/g; #";
    $text =~ s/>/\%3e/g;
    $text =~ s/</\%3c/g;
    return $text;
}
sub unescape {
    my $text = shift;
    $text =~ s/\%([a-fA-F0-9]{2})/chr(hex($1))/eg; ;
    return $text;
}

my $q = new CGI;
if ($q->param ("showprod")) {
    $main::showprod = 1;
}

my $tmpl = parsetemplate ("cfg.html");
print "Content-Type: text/html\n\n\n";
#print Dumper $tmpl;
printsect ($tmpl, {}, 'head');

my $newgram = $q->param ('newgram');
my $oldgram = $q->param ('oldgram');
my $submit = $q->param ('Submit');

if ($submit eq 'Revert') {
    $newgram = unescape ($oldgram);
}

if ($newgram !~ /\S/s) {
    open my $fh, "grammar";
    $newgram = join '', <$fh>;
    close $fh;
    $oldgram = escape ($newgram);
}

my $grammar = eval {
    parsegrammar ($newgram);
};
    
if ($@) {
    my ($pos, $token, $err) = ($@ =~ /^(\d+)\s*((?:Token)?)\s*(.*)/);
    $err = $@;
    $err =~ s/at .*? line \d+\.$//;
    $pos -= ($token ? 1 : 0);
    my $errgram = substr ($newgram, 0, $pos) . '<b><font color="red">';
    my $rest = substr ($newgram, $pos);

    if ($token) { #If it's a token error
	$rest =~ m/("(?:[^"\\]*(?:\\")*)*"|[[:alpha:]]+|\d+|[][,{}|()=\#])(.*)/s;
	$errgram .= "$1</font></b>$2";
    } else {
	$errgram .= "HERE</font></b>$rest";
    }
    $errgram = "<pre>$errgram</pre>";
    printsect ($tmpl, {err => $err, errgram => $errgram}, 'error');
    printsect ($tmpl, {newgram => $newgram, 
		       oldgram => $oldgram, 
		       showprod => $main::showprod ? "CHECKED" : "" }, 
	       'edit', 'foot');
    exit 0;
}

printsect ($tmpl, {newgram => $newgram, 
		   oldgram => $oldgram, 
		   showprod => $main::showprod ? "CHECKED" : "" },
	   'edit', 'sample');
my $err;
for (1..15) {
    my $sample;
    eval {
	print "<hr>Nonterminal S<br>\n" if $main::showprod;
	$sample = $grammar->{S}->produce ($grammar, $grammar);
    };
    if ($@) {
	$err = $@;
	$err =~ s/at .*? line \d+\.$//;
	print "Error during production stage: $err";
	last;
    } else {
	printsect ($tmpl, {sample => $sample}, 'sampleitem', );
    }
}
if (!$err && $submit eq 'Save') {
    my $tmpgrammar = join '', map { ('a'..'z')[rand 26]} (1..10);
    `cp grammar grammars/$tmpgrammar`;
    open my $fh, ">grammar";
    print $fh $newgram;
    close $fh;
}
printsect ($tmpl, {}, 'endsample', 'foot');