#!/usr/local/bin/perl -w 
# -*- perl -*-
######################################################################
# printvars.pl -- Print variables from soulstone
# Copyright (c) 2007 Tero Kivinen
# All Rights Reserved.
######################################################################
#         Program: printvars.pl
#	  $Source: /u/samba/nwn/bin/RCS/printvars.pl,v $
#	  Author : $Author: kivinen $
#
#	  (C) Tero Kivinen 2007 <kivinen@iki.fi>
#
#	  Creation          : 02:25 Aug 10 2007 kivinen
#	  Last Modification : 16:54 Nov 19 2007 kivinen
#	  Last check in     : $Date: 2008/01/06 19:47:55 $
#	  Revision number   : $Revision: 1.1 $
#	  State             : $State: Exp $
#	  Version	    : 1.97
#	  Edit time	    : 84 min
#
#	  Description       : Print variables from soulstone
#
#	  $Log: printvars.pl,v $
#	  Revision 1.1  2008/01/06 19:47:55  kivinen
#	  	Created.
#
#	  $EndLog$
#
#
#
#
######################################################################
# initialization

require 5.6.0;
package PrintVars;
use strict;
use Getopt::Long;
use File::Glob ':glob';
use Gff;
use GffRead;
use Pod::Usage;

$Opt::printall = 0;
$Opt::print_full_label = 0;

######################################################################
# Get version information

open(PROGRAM, "<$0") || die "Cannot open myself from $0 : $!";
undef $/;
$Prog::program = <PROGRAM>;
$/ = "\n";
close(PROGRAM);
if ($Prog::program =~ /\$revision:\s*([\d.]*)\s*\$/i) {
    $Prog::revision = $1;
} else {
    $Prog::revision = "?.?";
}

if ($Prog::program =~ /version\s*:\s*([\d.]*\.)*([\d]*)\s/mi) {
    $Prog::save_version = $2;
} else {
    $Prog::save_version = "??";
}

if ($Prog::program =~ /edit\s*time\s*:\s*([\d]*)\s*min\s*$/mi) {
    $Prog::edit_time = $1;
} else {
    $Prog::edit_time = "??";
}

$Prog::version = "$Prog::revision.$Prog::save_version.$Prog::edit_time";
$Prog::progname = $0;
$Prog::progname =~ s/^.*\///g;

$| = 1;
$Opt::verbose = 0;

######################################################################
# Read rc-file

if (defined($ENV{'HOME'})) {
    read_rc_file("$ENV{'HOME'}/.printvarsrc");
}

######################################################################
# Option handling

Getopt::Long::Configure("no_ignore_case");

if (!GetOptions("config=s" => \$Opt::config,
		"verbose|v+" => \$Opt::verbose,
		"help|h" => \$Opt::help,
		"filename|f" => \$Opt::filename,
		"basename|b" => \$Opt::basename,
		"all|a" => \$Opt::printall,
		"tag|t=s" => \$Opt::tag_regexp,
		"name|n=s" => \$Opt::name_regexp,
		"value=s" => \$Opt::value_regexp,
		"label|l" => \$Opt::print_full_label,
		"version|V" => \$Opt::version) || defined($Opt::help)) {
    usage();
}

if (defined($Opt::version)) {
    print("\u$Prog::progname version " .
	  "$Prog::version by Tero Kivinen.\n");
    exit(0);
}

while (defined($Opt::config)) {
    my($tmp);
    $tmp = $Opt::config;
    undef $Opt::config;
    if (-f $tmp) {
	read_rc_file($tmp);
    } else {
	die "Config file $Opt::config not found: $!";
    }
}

######################################################################
# Main loop

$| = 1;

my($i, $j, $k, $l, $name, $next, $file);

if (join(";", @ARGV) =~ /[*?]/) {
    my(@argv);
    foreach $i (@ARGV) {
	push(@argv, bsd_glob($i));
    }
    @ARGV = @argv;
}

foreach $i (@ARGV) {
    my($gff, %levels, $classstr, $cls, $lvl);
    if ($Opt::verbose) {
	print("Reading file $i...\n");
    }
    if (defined($Opt::basename)) {
	$PrintVars::file = $i . ": ";
	$PrintVars::file =~ s/.*[\/\\]//g;
    } elsif (defined($Opt::filename)) {
	$PrintVars::file = $i . ": ";
    } else {
	$PrintVars::file = '';
    }
    if ($Opt::printall) {
	$gff = GffRead::read(filename => $i);
    } else {
	$gff = GffRead::read(filename => $i,
			     include => '^/ItemList');
    }
    if ($Opt::verbose) {
	printf("Read done\n");
    }

    if ($Opt::printall) {
	$gff->find(find_label => '/VarTable\[\d+\]/$', #'
		   proc => \&print_vars);
    } else {
	%PrintVars::variable = ();
	%PrintVars::type = ();
	%PrintVars::printed = ();
	%PrintVars::arrayvars = ();
	
	$gff->find(find_label => '^/ItemList\[\d+\]/$', #'
		   proc => \&check_item);
	foreach $j (sort keys %PrintVars::variable) {
	    printf("%sCategory %s", $PrintVars::file, $j);
	    if (defined($PrintVars::variable{$j}{First}) &&
		defined($PrintVars::variable{$j}{Count})) {
		printf(" (Array with %d items)\n",
		       $PrintVars::variable{$j}{Count});
		$k = $PrintVars::variable{$j}{First};
		printf("%s%s::First = %s\n", $PrintVars::file, $j, $k);
		$PrintVars::printed{$j}{First} = 1;
		$PrintVars::printed{$j}{Count} = 1;
		while ($k ne '') {
		    if (!defined($PrintVars::arrayvars{$j}{$k})) {
			printf("%s[WARNING, Empty array] %s::%s\n",
			       $PrintVars::file, $j, $k);
		    } else {
			foreach $l (@{$PrintVars::arrayvars{$j}{$k}}) {
			    $name = sprintf("%d%s%s", length($k), $k, $l);
			    printf("%s%s::%s:%s = %s (%s) (var = %s)\n",
				   $PrintVars::file, $j, $k, $l,
				   $PrintVars::variable{$j}{$name},
				   $PrintVars::type{$j}{$name}, $name);
			    $PrintVars::printed{$j}{$name} = 1;
			}
		    }
		    $next = $PrintVars::variable{$j}{"n_" . $k};
		    printf("%s%s::%s:next = %s\n", $PrintVars::file, $j, $k, $next);
		    $PrintVars::printed{$j}{"n_" . $k} = 1;
		    $k = $next;
		}
		foreach $k (sort keys %{$PrintVars::variable{$j}}) {
		    next if (defined($PrintVars::printed{$j}{$k}));
		    printf("%s[ERROR, not in list] %s::%s = %s (%s)\n",
			   $PrintVars::file, $j, $k,
			   $PrintVars::variable{$j}{$k},
			   $PrintVars::type{$j}{$k});
		}
	    } else {
		print("\n");
		foreach $k (sort keys %{$PrintVars::variable{$j}}) {
		    printf("%s%s::%s = %s (%s)\n", $PrintVars::file, $j, $k,
			   $PrintVars::variable{$j}{$k},
			   $PrintVars::type{$j}{$k});
		}
	    }
	    printf("\n");
	}
    }
}

exit 0;

######################################################################
# check_item

sub check_item {
    my($gff, $full_label, $label, $value, $parent_gffs) = @_;

    if ($$gff{'Tag'} eq 'SoulStone') {
	my($vars, $i, $name, $category, $num, $len);
	$vars = $$gff{VarTable};
	for($i = $#$vars; $i >= 0 ; $i--) {
	    $name = $$vars[$i]{Name};
	    if (defined($Opt::name_regexp) &&
		$name !~ /$Opt::name_regexp/) {
		next;
	    }
	    if (defined($Opt::value_regexp) &&
		$$vars[$i]{Value} !~ /$Opt::value_regexp/) {
		next;
	    }
	    if ($name =~ /^([fis])([^_]*)_(.*)$/) {
		$category = $2;
		$name = $3;
		$PrintVars::variable{$category}{$name} = $$vars[$i]{Value};
		$PrintVars::type{$category}{$name} = $1;
		if ($name =~ /^(\d+)/) {
		    $num = $1;
		    $len = length($1);
		    if (!defined($PrintVars::arrayvars{$category}{substr($name, $len, $num)})) {
			$PrintVars::arrayvars{$category}{substr($name, $len, $num)} = ();
		    }
		    push(@{$PrintVars::arrayvars{$category}{substr($name, $len, $num)}}, 
			 substr($name, $num + $len));
		}
	    } elsif ($name eq 'owner' || $name eq 'Base' || $name eq 'Prop' ||
		     $name eq 'Description' || $name eq 'DescriptionWriter') {
	    } else {
		printf("%s[ERROR, invalid variable] %s = %s\n",
		       $PrintVars::file, $name, $$vars[$i]{Value});
	    }
	}
    }
}

######################################################################
# print_vars

sub print_vars {
    my($gff, $full_label, $label, $value, $parent_gffs) = @_;
    my($parent, $tag);
    $parent = $$parent_gffs[-2];
    $tag = $$parent{Tag};
    $tag = '' if (!defined($tag));
    if (defined($Opt::tag_regexp) &&
	$tag !~ /$Opt::tag_regexp/) {
	return;
    }
    if (defined($Opt::name_regexp) &&
	$$gff{Name} !~ /$Opt::name_regexp/) {
	return;
    }
    if (defined($Opt::value_regexp) &&
	$$gff{Value} !~ /$Opt::value_regexp/) {
	return;
    }
    printf("%s%s%s:%s = %s\n", $PrintVars::file,
	   ($Opt::print_full_label ? ($full_label . ":") : ""),
	   $tag, $$gff{Name}, $$gff{Value});
}


######################################################################
# Read rc file

sub read_rc_file {
    my($file) = @_;
    my($next, $space);
    
    if (open(RCFILE, "<$file")) {
	while (<RCFILE>) {
	    chomp;
	    while (/\\$/) {
		$space = 0;
		if (/\s+\\$/) {
		    $space = 1;
		}
		s/\s*\\$//g;
		$next = <RCFILE>;
		chomp $next;
		if ($next =~ s/^\s+//g) {
		    $space = 1;
		}
		if ($space) {
		    $_ .= " " . $next;
		} else {
		    $_ .= $next;
		}
	    }
	    if (/^\s*([a-zA-Z0-9_]+)\s*$/) {
		eval('$Opt::' . lc($1) . ' = 1;');
	    } elsif (/^\s*([a-zA-Z0-9_]+)\s*=\s*\"([^\"]*)\"\s*$/) {
		my($key, $value) = ($1, $2);
		$value =~ s/\\n/\n/g;
		$value =~ s/\\t/\t/g;
		eval('$Opt::' . lc($key) . ' = $value;');
	    } elsif (/^\s*([a-zA-Z0-9_]+)\s*=\s*(.*)\s*$/) {
		my($key, $value) = ($1, $2);
		$value =~ s/\\n/\n/g;
		$value =~ s/\\t/\t/g;
		eval('$Opt::' . lc($key) . ' = $value;');
	    }
	}
	close(RCFILE);
    }
}


######################################################################
# Usage

sub usage {
    Pod::Usage::pod2usage(0);
}

=head1 NAME

printvars - Print variables

=head1 SYNOPSIS

printvars [B<--help>|B<-h>] [B<--version>|B<-V>] [B<--verbose>|B<-v>]
    [B<--config> I<config-file>]
    [B<--all>|B<-a>]
    [B<--basename>|B<-b>]
    [B<--tag>|B<-t> I<tag-regexp>]
    [B<--name>|B<-n> I<name-regexp>]
    [B<--value> I<value-regexp>]
    [B<--label>|B<-l>]
    I<filename> ...

printvars B<--help>

=head1 DESCRIPTION

B<printvars> prints variables from soulstone of the given character,
or if with --all option the print all variables on all objects.

=head1 OPTIONS

=over 4

=item B<--help> B<-h>

Prints out the usage information.

=item B<--version> B<-V>

Prints out the version information. 

=item B<--verbose> B<-v>

Enables the verbose prints. This option can be given multiple times,
and each time it enables more verbose prints. 

=item B<--config> I<config-file>

All options given by the command line can also be given in the
configuration file. This option is used to read another configuration
file in addition to the default configuration file. 

=item B<--all> B<-a>

Prints all variables, not only those from soulstone. 

=item B<--basename> B<-b>

Print basename of the file when printing data out.

=item B<--tag> B<-t> I<tag-regexp>

Print only data from objects whose tag match given regexp. Note, that
this option does not have any effect, if --all option is not given, as
when printing data from soulstone, we always check the soulstone tag. 

=item B<--name> B<-n> I<name-regexp>

Print only data from variables whose name match given regexp.

=item B<--value> I<value-regexp>

Print only data from variables whose value match given regexp.

=item B<--label> B<-l>

Print full label of the variable when printing it out.

=back

=head1 EXAMPLES

    printvars.pl *.bic

=head1 FILES

=over 6

=item ~/.printvarsrc

Default configuration file.

=back

=head1 SEE ALSO

gffmatch(1), gffprint(1), Gff(3), and GffRead(3).

=head1 AUTHOR

Tero Kivinen <kivinen@iki.fi>.

=head1 HISTORY

This program evolved when checking why Weby has invalid variable
structure in his character.