package QVar;
$QVar::VERSION='0.8';
use strict;
use warnings;
use File::Basename;
my $PGM = basename $0;
my $DEBUG = 1;
$|=1; # Autoflush on stdout.




################################################################################
# Package QVar::Utils
################################################################################
package QVar::Utils;
use Text::Wrap qw/wrap fill/;
use Config;
use XML::Simple;
use Data::Dumper;
$Data::Dumper::Indent = 1;



########################################
#
########################################
sub read_xml_file {
    my $file = shift;
    my $rval = XMLin( $file,
                      ContentKey => 'text', 
                      ForceArray => [ qw(choice) ], 
                      KeepRoot => 1,
                      );

    return $rval;
}



########################################
#
########################################
sub is_pow2
{
    my $x = shift;
    return if $x != int($x);
    
    my $nbits = 8 * $Config{intsize};
    
    my $count = 0;
    foreach (0..$nbits-1) {
        $count++ if ($x & (1 << $_));
    }
    return 1 == $count;
}


########################################
#
########################################
sub get_pkg_var {
    my ($pkg, $name, $type) = @_;
    die "get_package_var(...): illegal type '$type'"
        if ($type !~ /^(ARRAY|SCALAR|HASH)$/);
    return undef if (! exists $::{"${pkg}::"});
    no strict 'refs';
    local (*g) = \ *{"${pkg}::${name}"};
    return \ ${"g"} if ("SCALAR" eq $type and \ ${*g});
    return \ @{"g"} if ("ARRAY"  eq $type and \ @{*g});
    return \ %{"g"} if ("HASH"   eq $type and \ %{*g});
    use strict 'refs';
    return undef;
}


########################################
#
########################################
sub massage
{
    my ($p, $str) = @_;
    my $N = length($p);
    $str =~ s/\s+/ /gsm;
    
    # Look for HTML like paragraph breaks, i.e. '<p>'.
    my @a = split /\<p\>/, $str;
    foreach (@a) {
        s/^\s+//;
        s/\s+$//;
        $_ = ucfirst $_;
    }
    my $rval = '';
    @a = map { join("\n", wrap(' ' x $N, ' ' x $N, $_)) } @a;
    $a[0] = $p . substr($a[0], $N);
    return join("\n\n", @a) . "\n";
}



########################################
#
########################################
sub param_description_str
{
    my ($p, $str, $N, $COLS) = @_;
    $N ||= 20; 
    $COLS ||= 50;
    $Text::Wrap::columns  =  $COLS;
    $Text::Wrap::unexpand =  undef;
    if (length($p) == ($N-1)) {
        $p .= ' ';
    } elsif (length($p) == ($N-2)) {
        $p .= '. ';
    } elsif (length($p) > $N-3) {
        $p .= "\n" . (' ' x $N);
    } else {
        my $dots = '.' x ($N - (length($p)+2));
        $p .= " $dots ";
    }
    
    return QVar::Utils::massage($p, $str);
}


################################################################################
# Package QVar
################################################################################
package QVar;
use Carp;


########################################
#
########################################
sub new
{
    my $proto = shift;
    my $class = ref($proto) || $proto;
    croak "Constructor must have an even number of args"
        if (@_%2);
    my %h = @_;
    
    my $rh_props = {};
    foreach (keys %h) {
        if (! /^(name|alias|description|synopsis|value|default)$/) {
            $rh_props->{$_} = $h{$_};
        }
    }
    foreach (keys %$rh_props) {
        delete $h{$_};
    }
    
    $h{synopsis}	||= '';
    $h{value} 	  = $h{default} if (! defined $h{value});
    $h{description} 	||= $h{synopsis};
    $h{alias} 	||= $h{name};
    
    croak "Variable was given no name"
        if (! $h{name});
    croak "Variable $h{name} was given no default value"
        if (! defined $h{default} );
    croak "Variable $h{name} was given no 'synopsis'"
        if (! $h{synopsis});
    
    my $s = {
        ( name                    => undef,
          # Name is used in XML but alias is used for printing to user.
          alias                   => undef,  
          synopsis                => undef,
          description             => undef,
          value                   => undef,
          default                 => undef,
          (%h),
          #-----------------------
          rh_props                => $rh_props,
          xml_fmt                 => '<param name="%s" value="%s"/>',
          synopsis_fmt            => "[%s] %-15s  %15s  %s",
          #-----------------------
          description_wrap_cols         	=> 50,
          description_line1_indent_cols 	=> 20,
          description_lineN_indent_cols 	=> 20,
          #-----------------------
          ),
    };
    
    bless $s, $class;
    $s->init();
    
    $s->{default} = $s->map_setval( $h{default} );
    croak $s->set( $h{value} ) 
        if $s->set( $h{value} );
    return $s;
}


########################################
#
########################################
sub has_props {
    my $s = shift;
    return 1 if ( scalar keys %{$s->{rh_props}} );
}


########################################
#
########################################
sub synopsis_str
{
    my $s = shift;
    my %h = @_;
    my $letter = $h{letter};
    my @a_args = ($letter, $s->{value}, $s->{alias}, $s->{synopsis});
    return sprintf($s->{synopsis_fmt}, @a_args);
}


########################################
#
########################################
sub xml_str
{
    my $s = shift;
    return sprintf($s->{xml_fmt}, $s->{name}, $s->get());
}


########################################
#
#   These are virtual methods.
#
########################################
sub check      {       }
sub map_setval { $_[1] }
sub map_getval { $_[1] }
sub init       {       }    
    
########################################
#
# RETURN:
#   On success - undef
#   On failure -  an error msg. 
# 
########################################
sub set {
    my $s = shift;
    my $x = shift;
    $x = $s->map_setval($x);
    return $s->check( $x ) if ($s->check( $x ));
    $s->{value} = $x;
    return;
}


########################################
#
########################################
sub get {
    my $s = shift;
    return $s->map_getval( $s->{value} );
}



########################################
#
# RETURN:
#   On success - undef
#   On failure -  an error msg. 
#
########################################
sub reset
{
    my $s = shift;
    $s->{rh_props} = {};
    return $s->set( $s->{default} );
}


########################################
#
########################################
sub prop_set   { my ($s,$p,$v) = @_; $s->{rh_props}->{$p} = (defined $v ? $v : 1); }
sub prop_unset { my ($s,$p) = @_; delete $s->{rh_props}->{$p}; }
sub prop_get   { my ($s,$p) = @_; return $s->{rh_props}->{$p}; }



########################################
#
########################################
sub set_default {
    my $s = shift;
    my $default = shift;
    my $err = $s->check( $default );
    croak "$PGM:  illegal default value '$default': $err"
        if ( $err );
    $s->{default} = $s->map_setval( $default );
}


########################################
#
########################################
sub activate {
    my $s = shift;
    my $COLS = $s->{description_wrap_cols};
    my $INDENT = $s->{description_line1_indent_cols};

    print QVar::Utils::param_description_str('Parameter', $s->{alias}, $INDENT, $COLS);
    print QVar::Utils::param_description_str('Default Value', $s->map_getval( $s->{default} ), $INDENT, $COLS);
    print QVar::Utils::param_description_str('Description', $s->{description}, $INDENT, $COLS);
    my $rh_p = $s->{rh_props};
    my $nprops = 0;
    if (0 < scalar( keys %$rh_p )) {
        my $str = '';
        foreach ( qw/min max/ ) {
            next if !defined $rh_p->{$_};
            $str .= ($str ? ', ' : '') . "$_=$rh_p->{$_}";
            $nprops++;
        }
        foreach ( qw/pow2 non_neg non_pos non_zero/ ) {
            next if !defined $rh_p->{$_};
            $str .= ($str ? ', ' : '') . $_;
            $nprops++;
        }
        if (defined $rh_p->{rh_one_of}) {
            $str .= (($str ? ', ' : '') 
                     . 'one_of<' 
                     . join(',', sort {$a<=>$b} keys %{$rh_p->{rh_one_of}}) 
                     . ">");
            $nprops++;
        }

        if (0 < $nprops) {
            $str .= '.';
            print QVar::Utils::param_description_str('Properties', $str, $INDENT, $COLS);
        }
    }
    print "\n";
    print QVar::Utils::param_description_str('Current Value', $s->get(), $INDENT, $COLS);
}




################################################################################
# Package QVar::Bool
################################################################################
package QVar::Bool;
our @ISA = qw(QVar);


########################################
#
########################################
sub map_setval { 
    my ($s,$v) = @_;
    if (defined $s->{default}) {
        # We must convert the candidate value to the same boolean
        # value type (e.g. 'On', 'Off') that the default is set.
        my $x = $s->is_true( $s->{default} );
        my $y = $s->is_true( $v );
        
        if ($x && $y or !$x && !$y) {
            $v = $s->{default};
        } else {
            $v = $s->toggle_val( $s->{default} );
        }
    }
    return $v if ($v =~ /^(y|n|0|1)$/);
    $v = ucfirst( lc($v) );
    return $v;
}


########################################
#
########################################
sub toggle_val { 
    my @a = (T => 'F', t => 'f', True => 'False',
             Y => 'N', y => 'n', Yes => 'No',
             '0' => 1,
             On => 'Off',);
    my %h = (@a, reverse(@a));
    my $s = shift;
    my $v = shift;
    die "Internal error; illegal value '$v'" if ! $h{$v};
    return $h{$v};
}



########################################
#
########################################
sub check {
    my $s = shift;
    my $x = shift;
    if ($x !~ /^(T|F|0|1|Y|N|y|n|Yes|No|True|False|On|Off)$/) {
        return "illegal value '$x'";
    }
    return;
}

########################################
#
########################################
sub is_true  { my ($s,$v) = @_; return 1 if ($v =~ /^(t|1|y|yes|true|on)$/i); }
sub is_false { my ($s,$v) = @_; return !$s->is_true($v); }


########################################
#
########################################
sub activate
{
    my $s = shift;
    $s->SUPER::activate();

    my $done;
    while ( ! $done) {
        print "\nChoose one of the following actions:\n";
        print "  [a] Toggle value.\n";
        print "  [b] Back to menu.\n";
        print "\n";
        print "Your choice [a]: ";
        my $x = <STDIN>;
        $x =~ s/^\s+//;
        $x =~ s/\s+$//;
        if (!$x || 'a' eq $x) {
            $s->set( $s->toggle_val( $s->{value} ) );
            printf "Parameter %s set to '%s'.\n", $s->{alias}, $s->get();
            $done = 1;
        } elsif ('b' eq $x) {
            # Do nothing.
            $done = 1;
            printf "\nParameter %s's value remains unchanged at '%s'.\n\n", $s->{alias}, $s->get();
        } else {
            print "\nHuh?  Please answer either 'a' or 'b'.\n\n";
        }
    }
}


################################################################################
# Package QVar::Int
################################################################################
package QVar::Int;
our @ISA = qw(QVar);
use Carp;
# Props: pow2, min, max, non_pos, non_neg, non_zero, rh_one_of.


########################################
#
########################################
sub check {
    my $s = shift;
    my $x = shift;
    
    my $rh_p = $s->{rh_props};
    return "value is undefined" 
        if (! defined $x);
    return "value '$x' is not an integer"
        if ($x != int($x));
    return "value '$x' is not an integer"
        if (0 != $x && $x !~ /^\-?\d+$/);
    return sprintf("value '%d' cannot be negative", $x)
        if (0>$x and $rh_p->{pow2} || $rh_p->{non_neg});
    return sprintf("value '%d' cannot be positive", $x)
        if (0<$x and $rh_p->{non_pos});
    return sprintf("value '%d' cannot be zero", $x)
        if (0==$x and $rh_p->{pow2} || $rh_p->{non_zero});
    return sprintf("value '%d' is not a power of two", $x)
        if ($rh_p->{pow2} && ! QVar::Utils::is_pow2($x));
    return sprintf("value '%d' is less than minimum value '%d'", $x, $rh_p->{min})
        if (defined $rh_p->{min} && $x < $rh_p->{min});
    return sprintf("value '%d' is more than maximum value '%d'", $x, $rh_p->{max})
        if (defined $rh_p->{max} && $x > $rh_p->{max});
    return sprintf("value '$x' must be one of {" . join(',', sort {$a<=>$b} keys %{$rh_p->{rh_one_of}}) . "}")
        if ($rh_p->{rh_one_of} && !defined $rh_p->{rh_one_of}->{"$x"});
}


########################################
#
########################################
sub map_setval { 
    my ($s,$x) = @_; 
    return sprintf('%d', $x || 0); 
}


########################################
#
########################################
sub map_getval { 
    my ($s,$x) = @_; 
    return sprintf('%d', $x);
}
        

########################################
#
########################################
sub activate {
    my $s = shift;
    $s->SUPER::activate();
    my $done;
    while ( ! $done) {
        printf "\nGive new value for %s [%d]: ", $s->{alias}, $s->get();
        my $x = <STDIN>;
        $x =~ s/^\s+//;
        $x =~ s/\s+$//;
        if (0 == length($x) || $x == $s->get()) {
            # Do nothing.
            $done = 1;
            printf "\nParameter %s's value remains unchanged at '%s'.\n\n", $s->{alias}, $s->get();
        } else {
            my $err = $s->check( $x );
            if ($err) {
                print "\nHuh?  " . ucfirst($err) . ".\n\n";
            } else {
                $s->set( $x );
                printf "Parameter %s set to '%s'.\n", $s->{alias}, $s->get();
                $done = 1;
            }
        }
    }
}



################################################################################
# Package QVar::Enum
################################################################################
package QVar::Enum;
our @ISA = qw(QVar);
use Text::Wrap qw/wrap fill/;
use Carp;
# Props: rh_enums


########################################
#
########################################
sub init {
    my $s = shift;
    my $ra = $s->{rh_props}->{ra_enums};
    my $rh = $s->{rh_props}->{rh_enums} = {};
    foreach  ( @$ra ) {
        my $x = $_->{value};
        $rh->{$x} = 1;
    }
}


########################################
#
########################################
sub check {
    my $s = shift;
    my $x = shift;
    return "value '$x' is not one of the allowed choices"
        if (! $s->{rh_props}->{rh_enums}->{$x} );
}


########################################
#
########################################
sub activate {
    my $s = shift;
    $s->SUPER::activate();
    my $done;
    my $ra = $s->{rh_props}->{ra_enums};
    my $QLETTERS  = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPRSTUVWXYZ0123456789";
    my @A_LETTERS = split //, $QLETTERS;
    my $SPACE_LEN = 4;
    my $FMT = "  [%1.1s]  ";

    while ( ! $done) {
        my $enum_max_len = 0;
        foreach my $rh ( @$ra ) {
            $enum_max_len = length($rh->{enum})
                if ($enum_max_len < length($rh->{enum} || ''));
        }
        $enum_max_len++;
        $enum_max_len = 20 if (20 < $enum_max_len);
        my $idx = 0;
        foreach my $rh ( @$ra ) {
            my $leader = sprintf($FMT, $A_LETTERS[$idx++]);
            my $enum   = $rh->{enum};
            my $description  = $rh->{description} || '';
            if (0 == length($description)) {
                printf $leader . $enum . "\n";
                next;
            }
            $enum .= ' ';
            if ( $enum_max_len < length($enum) ) {
                print $leader;
                print "$enum\n";
                my $n = $enum_max_len + length('... ');
                print join("\n", wrap($n,$n,$description));
                print "\n";

            } else {
                $enum .= '.' x ($enum_max_len - length($enum));
                $enum .= '... ';
                $Text::Wrap::columns  =  $s->{description_wrap_cols};
                $Text::Wrap::unexpand =  undef;
                my $str = QVar::Utils::massage($leader . $enum, $description);
                print $str;
                # print "\n";
            }
        }

        my $cur_val = $s->{value};
        my $default_letter;
        $idx = 0;
        foreach ( @$ra ) {
            if ($_->{enum} eq $cur_val) {
                $default_letter = $A_LETTERS[$idx];
                last;
            }
            $idx++;
        }
        die "internal error" if (! $default_letter);
        printf "\nChoose letter [%s]: ", $default_letter;

        my $x = <STDIN>;
        $x =~ s/^\s+//;
        $x =~ s/\s+$//;
        if (0 == length($x) || $default_letter eq $x) {
            # Do nothing.
            $done = 1;
            printf "\nParameter %s's value remains unchanged at '%s'.\n\n", $s->{alias}, $s->get();
        } else {
            $idx = index($QLETTERS, $x);
            if (0 > $idx || $idx >= scalar(@$ra)) {
                print "\nHuh?  You cannot choose '$x'.  Please try again.\n\n";
            } else {
                $x = $ra->[$idx]->{enum};
                $s->set( $x );
                printf "Parameter %s set to '%s'.\n", $s->{alias}, $s->get();
                $done = 1;
            }
        }
    }
}


################################################################################
# Package QVar::Collection
################################################################################
package QVar::Collection;
our @ISA = qw(QVar);
use Carp;

sub new
{
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $var_defs_file = shift;
    my $s = {
        die_on_var_redefine => 1,
        die_on_set_default_for_undefined_var => 1,
        die_on_set_value_for_undefined_var => 0,
        ra_vars => [],
        rh_vars => {},
    };
    bless $s, $class;
    return $s;
}


sub load_xml_file
{
    my $s = shift;
    my $file = shift;
    my $rh = QVar::Utils::read_xml_file( $file );
    croak "$PGM:  ERROR: Error when trying to read XML file '$file'.\n"
        if (! $rh);

    my $root = (%$rh) && [keys %$rh]->[0];
    $rh = $rh->{$root};

    if ('qvar_definitions' eq $root) {
        croak "$PGM:  ERROR: A 'qvar_definition' xml tree can only have 'qvar' elements"
            if (1 != keys %$rh or 'qvar' ne [keys %$rh]->[0]);
        $rh = $rh->{qvar};
        my @a_vars = sort keys %$rh;
        foreach my $v ( @a_vars ) {
            my $rh_xml_var  = $rh->{$v};
            my $type     	= $rh_xml_var->{type};
            my $default  	= $rh_xml_var->{default};
            my $synopsys 	= $rh_xml_var->{synopsis};
            my $value 		= $rh_xml_var->{value};
            my $description = $rh_xml_var->{description};
            croak "$PGM:  ERROR: No type was specified for variable '$v'"
                if !$type;
            croak "$PGM:  ERROR: Variable '$v' has unknown type '$type'"
                if ($type !~ /^(bool|int|enum)$/);
            croak "$PGM:  ERROR: Variable '$v' has no default"  
                if !$default;
            croak "$PGM:  ERROR: Variable '$v' has no synopsys" 
                if !$synopsys;
            croak "$PGM:  ERROR: Variable '$v' cannot have a value in a definition file" 
                if defined $value;


            my @a_attrs = (name => $v, 
                           alias => $rh_xml_var->{alias}, 
                           default => $default, 
                           synopsis => $synopsys,
                           description => $description,
                           );

            # Var Attrs: name alias description synopsis value default
            my $rh_var;
            if ('bool' eq $type) {
                $rh_var = QVar::Bool->new( @a_attrs );

            } elsif ('int' eq $type) {
                # Props: pow2, min, max, non_pos, non_neg, non_zero, rh_one_of.
                $rh_var = QVar::Int->new( @a_attrs,  );

            } elsif ('enum' eq $type) {
                $rh_var = QVar::Enum->new( @a_attrs, ra_enums => $rh_xml_var->{enum}, );

            } else {
                die 'internal error';
            }
            die "Could not create variable '$v'" if !$rh_var;
            print "[$v]\n" if ($DEBUG);

            push @{$s->{ra_vars}}, $rh_var;
            $s->{rh_vars}->{$v} = $rh_var;
            $rh_var->{rh_xml} = $rh_xml_var;
        }
    } elsif ('qvar_defaults' eq $root) {
        die 'not yet implemented';
    } elsif ('qvar_values' eq $root) {
        die 'not yet implemented';
    } else {
        croak "$PGM:  ERROR: XML file '$file' has invalid root '$root'";
    }
    push @{ $s->{ra_var_files} }, $file;
    $s->{rh_var_files}->{$file} = $rh;
}



################################################################################
# Package main
################################################################################
#package main;
my $qvars = QVar::Collection->new();
$qvars->load_xml_file('qdefs.xml');

## my $c = QVar::Bool->new(
##                         default  => 'off', 
##                         value    => 'True', 
##                         name     => '0123456789012345678', 
##                         synopsis => "assert a non-zero filter, but only if there is some funkyness involved\n\n and even in that case, when dogs are living with cats although paying their bills.",
##                        );
## 
## my $d = QVar::Enum->new( default => 'spud-boy',
##                         value => 'bananarama',
##                         name => "SPUGSY",
##                         synopsis => "assert a non-zero filter, but only if there is some funkyness involved\n\n and even in that case, when dogs are living with cats although paying their bills.",
##                         ra_enums => [ 
##                                    { value => 'cowboay', description => 'gotta be a cowboy baby, trying to get to a scond line', },
##                                    { value => 'zoomboobafoo', description => "assert a non-zero filter, but only if there is some funkyness involved\n\n and even in that case, when dogs are living with cats although paying their bills.", },
##                                    { value => 'spud-boy', description => 'blah blaqh blah', },
##                                    { value => 'crazy yet stable', description => "assert a non-zero filter, but only if there is some funkyness involved\n\n and even in that case, when dogs are living with cats although paying their bills.", },
##                                    { value => 'bananarama', description => 'if you can read this you are too close', },
##                                    { value => 'slippery', description => 'now is the time,...', },
##                                        ],
##                       );
## 
## $d->activate();
## 
## 
## 
## my $X = "assert a non-zero filter, but only if there is some funkyness involved\n\n and even in that case, when dogs are living with cats although paying their bills. <p> and if only she saw the spectacular breathtaking underwhelming woof";
## if (0) {
##     print QVar::Utils::param_description_str('012345678901234567890', $X);
##     print QVar::Utils::param_description_str('01234567890123456789', $X);
##     print QVar::Utils::param_description_str('0123456789012345678', $X);
##     print QVar::Utils::param_description_str('012345678901234567', $X);
##     print QVar::Utils::param_description_str('01234567890123456', $X);
##     print QVar::Utils::param_description_str('0123456789012345', $X);
##     print QVar::Utils::param_description_str('012345678901234', $X);
## }
## 

=head1 AUTHOR INFORMATION

Copyright 2007, James E Quinlan.  All rights reserved.  

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.