#!/usr/bin/perl -- -*-cperl-*-

## Check an interchange file for problems.
## Greg Sabino Mullane, greg@endpoint.com
## Created because Greg often uses [if foobar] instead of [if scratch foobar]...
## Add stuff to the DATA section as you find it...

use strict;
use warnings;
use Data::Dumper;
use Getopt::Long;

my $VERSION = '1.0.4';

## Set the default arguments
my $icarg =
	{
	verbose     => 0,
	dietag      => 0,
	warntagonce => 0,
	errorexit   => 1,
	};

GetOptions
    ($icarg,
     'verbose=i',
     'dietag=i',
     'warntagonce=i',
     'errorexit=i',
     'help',
);

help() if ! @ARGV or $icarg->{help};

sub help {
    warn qq{Usage: $0 [args] file1 [file2 file3 ...]
  verbose          -- detailed output (default=0)
  dietag           -- die on unknown tags (default=0)
  warntagonce      -- only show one warning per tag type (default=0)
  errorexit        -- exit as soon as a problem is found (default=1)
};
    exit 1;
}

my $DIE_ON_UNKNOWN_TAG  = $icarg->{dietag};
my $ONE_WARNING_PER_TAG = $icarg->{warntagonce};
my $DIE_ON_ERROR        = $icarg->{errorexit};
my $VERBOSE             = $icarg->{verbose};


my %error;

@ARGV or die qq{Usage: $0 file [file2 file3 ...]\n};

## Read in our tag information
my %tag;
while (<DATA>) {
	next unless /^(\w[\w\-]+)\s*(.*)/;
	my ($tag,$args) = ($1,$2);
	exists $tag{lc $tag} and die qq{Oops - tag defined twice: $tag\n};
	for my $arg (split /\s+/ => $args) {
		if ($arg =~ /(\w+)=(.+)/) {
			my ($c,$d) = ($1,$2);
			$tag{lc $tag}{$c} = ($d =~ /,/ or $c eq 'validargs') ? {map {$_,1} split/,/ => $d} : $d;
		}
		else {
			$tag{lc $tag}{$arg}++;
		}
	}
}
#die Dumper \%tag;

for my $file (@ARGV) {
	open my $f, '<', $file or die qq{Could not open "$file": $!\n};
	warn "Checking $file...\n";
	my $slurp;
	{ local $/; $slurp=<$f>; }
	## Perl blocks often have comments inside of them, so empty them out first:
	$slurp =~ s{(\[perl[^\]]*\]).*?(\[/perl\])}{$1$2}gsmi;

	## Empty out all comments, perl, calc, and calcn blocks
	$slurp =~ s{(\[comment[^\]]*\]).*?(\[/comment\])}{$1$2}gsmi;
	$slurp =~ s{(\[perl[^\]]*\]).*?(\[/perl\])}{$1$2}gsmi;
	$slurp =~ s{(\[calcn[^\]]*\]).*?(\[/calcn\])}{$1$2}gsmi;
	$slurp =~ s{(\[calc[^n\]]*\]).*?(\[/calc\])}{$1$2}gsmi;

	## Get temporary tags
	while ($slurp =~ m{\[(?:query|loop)[^\]\[]+prefix=(\w+)}gsmi) {
		my $prefix = $1;
		if (exists $tag{$prefix} and ! exists $tag{$prefix}{prefix}) {
			#error('query','prefix',qq{Bad prefix name used in query tag: "$prefix"});
		}
		$tag{$prefix}{prefix}=1;
	}

	## De-nest nested tags and parse them
	1 while $slurp =~ s/(\[[^\]]+?)\[([^\]]+?)\]/&parse_tag($2); $1/gsme;

	while ($slurp =~ /\[([^\]]+)\]/gsm) {
		parse_tag($1);
	}

	## Any tags not add up?
	for my $t (sort keys %tag) {
		next unless $tag{$t}{close};
		(!exists $tag{$t}{levels}  or $tag{$t}{levels} == 0)
			or error($t,'badlevel',qq{Bad number of levels: $tag{$t}{levels}});
	}

	close $f or warn qq{Could not close "$file": $!\n};
}


sub parse_tag {

	my $section = shift;

	## Collapse it into a single line
	$section =~ s/[\n\r]/ /g;

	## Is this a closing tag?
	my $close = $section =~ s{^\s*/}{} ? 1 : 0;

	## Grab the first word as the tag name
	$section =~ s/^\s*(\w+)\s*// or die qq{Weird section: $section\n};
	my $tag = lc $1;
	$section =~ s/\s*$//;
	$VERBOSE and printf "Checking tag $tag %s\n", exists $tag{$tag}{levels} ? $tag{$tag}{levels} : '';

	## Do we know about this tag yet?
	if (!exists $tag{$tag}) {
		warn qq{Unknown tag "$tag"\n};
		exit if $DIE_ON_UNKNOWN_TAG;
		$tag{$tag}{unknown} = 1;
	}
	return if $tag{$tag}{unknown};

	## If this is a named prefix, swap to prefix checking
	if ($tag{$tag}{prefix}) {
		$tag = 'prefix';
	}

	## If closeable, track opens and closes for a final count
	if ($section !~ /^-/) {
		if ($tag{$tag}{close}) {
			$tag{$tag}{levels} += $close ? -1 : +1;
		}
		## If not closeable, yell if we see a closing tag for it
		elsif ($close and !$tag{$tag}{closeok}) {
			error($tag,'close',q{Closing tag is not allowed});
		}
	}
	## From this point forward, ignore closing tags
	return if $close;

	## Check validargs if they exists
	if ($tag{$tag}{validargs}) {
		$section =~ /(\w+)/
			or error($tag,'validargs',q{Arguments required, but not found}) and return;
		my $arg = $1;
		if (!exists $tag{$tag}{validargs}{$arg} and !exists $tag{$arg}{prefix}) {
			error($tag,'validargs',qq{Invalid argument "$arg"});
			return;
		}
	}

	## Does it meet the minimum number of arguments?
	my @words = split /\s+/ => $section;
	my $words = @words;

	if ($tag{$tag}{minargs}) {
		$words >= $tag{$tag}{minargs}
			or error($tag,'minargs',qq{Minimum number of arguments not reached: found $words, need $tag{$tag}{minargs}});
	}

	## Does it allow args at all (rare)
	if ($tag{$tag}{noargs} and $words and $section !~ /^-/) {
		error($tag,'noargs',qq{No arguments to tag allowed ($section)});
	}

	return;

} ## end of parsetag


sub error {

	my ($tag,$type,$msg) = @_;

	$error{$tag}{$type}++;
	return if $ONE_WARNING_PER_TAG and $error{$tag}{$type} > 1;

	warn qq{ERROR: Tag: "$tag" Problem: $msg\n};
	exit if $DIE_ON_ERROR;

	return;

} # end of error

__DATA__
## Lines starting with '#' like this one are skipped
## Format: TAGNAME ATTRIBS
## Case does not matter
## Possible attribs:
## close - tag must be closed explicitly
## validargs: list of valid first args, comma-separated
## minargs: minimum number of arguments inside of the tag
## noargs: no arguments are allowed
## closeok - may or may not need a closing tag (e.g. prefixes)

## Basic control
if           close minargs=1 validargs=scratch,variable,cgi,type,value,items,session,item,discount,errors,explicit,sql,loop,config,inner,data,module,acclist,file,ordered
then         close noargs
either       close
else         close
elsif        close minargs=1 validargs=scratch,variable,cgi,type,value,items,session
unless       close
condition    close noargs
and          minargs=1
or           mt

## Blocks and variables
calc         close noargs
calcn        close xvalidargs=a,b
tmp          close
tmpn         close
perl         close
sql          close
scratch      minargs=1
scratchd     minargs=1
set          close minargs=1
seti         close minargs=1
cgi          minargs=1

## Looping
loop         close validargs=list,code,param,option,lr,pos,data,no,calc,filter,prefix,acclist,search,alternate,random
on-match     close
no-match     close

## Debugging
catch        close minargs=1
comment      close
dump         mt
log          close minargs=1 validargs=type
try          close validargs=label minargs=1

## Jumping around
bounce       validargs=page,href minargs=1
goto         minargs=1 validargs=name,

## Shipping related
currency     close
delivery     validargs=shipmode,cutoff,extra_days,date minargs=1
fly-tax      mt
handling     mt
item         close
quantity     noargs
shipping     mt
subtotal     noargs
total        mt

## HTML
area         mt
button       close minargs=2 validargs=name,text,src,form
form         mt
image        mt
page         minargs=1
selected     minargs=1

## Unsorted
assign       validargs=clear,
banner       close
control      mt
convert      close minargs=1 validargs=date,
convert_date close minargs=1 validargs=days,fmt
data         minargs=2 validargs=session,table,base,products
display      validargs=table,name
email        close minargs=1 validargs=to,from,subject
error        validargs=name,all,std_label,auto
filter       close minargs=1
include      minargs=1
label        minargs=1
list         close noargs
modifier     close minargs=1
more         noargs
no           close noargs
process      mt
query        close
read         minargs=1
setup        noargs
table        close
timed        close
userdb       minargs=1
value        minargs=1
var          minargs=1

## Special case:
prefix       closeok minargs=1

## Local/unknown tags:
managed-content mt
fancy           mt
cms             mt
promo           mt
city            noclose
pagepop         mt
map             mt
cities          close
uk              mt

