
package Text::Wigwam::Stash;

    use strict;
    use warnings;
    no warnings q/uninitialized/;

    our $VERSION = '0.01';

    use Scalar::Util( qw/ blessed reftype refaddr / );
    use Text::Wigwam::Stash::Metachar;
    use Text::Wigwam::Stash::Magic;
    use Text::Wigwam::Cast::Base;

sub new {
    my ( $class, %Opts ) = @_;
    my %opts = ();
    map { $opts{ lc $_ } = $Opts{$_} } keys %Opts;

    die "Invalid globals parameter"
      if    defined $opts{globals}
         && (!blessed $opts{globals}
         || !$opts{globals}->isa qw(Text::Wigwam::Globals))
    ;

    $opts{metachar} ||= Text::Wigwam::Stash::Metachar->new();
    die "Invalid metachar parameter"
      unless blessed $opts{metachar}
          && $opts{metachar}->isa qw(Text::Wigwam::Stash::Metachar::Base);

    $opts{magic} ||= Text::Wigwam::Stash::Magic->new();
    die "Invalid magic parameter"
      unless blessed $opts{magic}
          && $opts{magic}->isa qw(Text::Wigwam::Stash::Magic::Base);

    die "Invalid cast parameter"
      if defined $opts{cast}
         && !(
             blessed $opts{cast}
          && $opts{cast}->isa qw(Text::Wigwam::Cast::Base)
         )
    ;
    $opts{cast} ||= 'Text::Wigwam::Cast::Base';

    $opts{varspace} ||= {};
    die "Invalid varspace parameter"
      unless reftype($opts{varspace}) eq 'HASH';

    $opts{metachar} ||= Text::Wigwam::Stash::Metachar->new(
        HASH    => '.',
        ARRAY   => ':',
        MAGIC   => '`',
#        DEFAULT => 'HASH',
    );
    die "Invalid varspace parameter"
      unless blessed $opts{metachar}
          && $opts{metachar}->isa qw(Text::Wigwam::Stash::Metachar);

    return bless {
        VS => $opts{varspace},
        GL => $opts{globals},
        MC => $opts{metachar},
        MG => $opts{magic},
        CA => $opts{cast},
        ESCAPE => $opts{escape},
    }, ref($class) || $class;
}

sub varspace { $_[0]->{VS} }
sub globals  { $_[0]->{GL} }

sub _mc { $_[0]->{MC} }
sub _mg { $_[0]->{MG} }
sub _ca { $_[0]->{CA} }
sub _gl {
    my $gl = $_[0]->{GL}
      or die "Global lookups are disabled!";
    return $gl;
}

sub _metas {
    my ($stash) = @_;
    return $stash->{METAS} = join( "" => $stash->_mc->metas );
}

sub _do_global {
    my ($stash, $ref, $met, $var, $metas) = @_;
    my $gc = $stash->_mc->meta_type('ARRAY');
    if ( $var =~ /^$gc(.+?)(?:([$metas])(.+))?$/ ){
        $var = $3;
        $met = $2;
        $ref = $stash->_gl->get_global( lc $1 );
    }
    return ($ref, $met, $var);
}
sub _autoescape { $_[0]->{ESCAPE} }

sub interpolate {
    my ($stash, $str) = @_;
    my $vs = $stash->varspace;
    my $cast = $stash->_ca;
    my $hmc = $stash->_mc->meta_type('HASH'); # Hash meta char
    my $esc = $stash->_autoescape;
    1 while $str =~ s/
        (
            (?:
                [^\\]
              | \\.
            )*?
        )
        \[
        (
            (?:
                [^\[\]\\]
              | \\.
            )*?
        )
        \]
    /
        length $2
        ? $1.$cast->do_cast(
            String => (
                $esc
                 ?  $stash->escape(
                        $stash->_explicit_get_value(
                            $vs,
                            $hmc,
                            $2,
                        )
                    )
                 :  $stash->_explicit_get_value(
                        $vs,
                        $hmc,
                        $2,
                    )
            )
          )
        : $1
    /xeo;
    return $str;
}

sub escape {
    my ($stash, $var) = @_;
    my $metas = $stash->_metas;
    $var =~ s/([$metas\[\]\\])/\\$1/g;
    return $var;
}

# Complains if passed an invalid variable, silent otherwise
sub invalid_var {
    my ($stash, $var) = @_;
    $var =~ s/( \\. )//xg; # Remove escaped chars.
    return "$var has a dangling escape character"
      if $var =~ /\\$/;

    # Remove innermost bracket pairs
    1 while $var =~ s/\[(?:\\.|[^\[])*?\]//g;

    return "Unbalanced brackets in variable" if $var =~ /[\[\]]/;
    return; # valid
}

sub is_global {
    my ($stash, $var) = @_;
    my $gc = $stash->_mc->meta_type('ARRAY');
    return $stash->interpolate($var) =~ /^$gc/ ? 1 : 0;
}

sub get_value  {
    my ($stash, $var) = @_;
    $stash->_explicit_get_value(
        $stash->varspace,
        $stash->_mc->meta_type('HASH'),
        $stash->interpolate($var),
    );
}

sub set_alias  {
    my ($stash, $var, $val) = @_;
    $stash->explicit_set_alias(
        $stash->varspace,
        $stash->_mc->meta_type('HASH'),
        $var,
        $val,
    );
}

sub undefine {
    my ($stash, $var) = @_;
    $stash->explicit_undefine(
        $stash->varspace,
        $stash->_mc->meta_type('HASH'),
        $var,
    )
}

sub is_defined {
    my ($stash, $var) = @_;
    return
        ref $var
     || $stash->explicit_is_defined(
            $stash->varspace,
            $stash->_mc->meta_type('HASH'),
            $var,
        )
    ;
}

sub set_value {
    my ($stash, $var, $val) = @_;
    return $stash->explicit_set_alias(
      $stash->varspace,
      $stash->_mc->meta_type('HASH'),
      $var,
       # Make copies of unblessed hash & array references
      ref $val eq 'HASH'
          ? {%$val}
          : ref $val eq 'ARRAY'
            ? [@$val]
            : $val
    );
}

sub explicit_set_alias {
    my ($stash, $ref, $met, $var, $val) = @_;
    my $rvar = $var = $stash->interpolate($var);
    my $mgc = $stash->_mg;
    my $metas = $stash->_metas;
    my $level = 0;
    ($ref, $met, $var) = $stash->_do_global($ref, $met, $var, $metas);

    eval {
        ($met, $ref) = $stash->_mc->set($met, $mgc, $ref, $1, $2, $level++)
          while $var =~ s/^((?:[^\\]|\\.)*?)([$metas])//;
        $var =~ s/\\(.)/$1/g;
        $stash->_mc->meta_type($met) eq 'ARRAY'
               ? $ref->[$var] = $val
               : $ref->{$var} = $val
        ;
    };
    if( $@ ){
        die "Error while parsing component $level of variable '$rvar' - $@";
    }
    return $val;
}

sub explicit_get_value {
    my ($stash, $ref, $met, $var) = @_;
    $stash->_explicit_get_value($ref, $met, $stash->interpolate($var) )
}

sub _explicit_get_value {
    my ($stash, $ref, $met, $var) = @_;
    local $^W;

    my $metas = $stash->_metas;
    ($ref, $met, $var) = $stash->_do_global($ref, $met, $var, $metas);

    my $level = 0;
    $var = "$met$var";
    my $rref = ref $ref ? $ref : \$ref;
    my $mgc = $stash->_mg;
    eval {
        while (
            $var =~ /
                ([$metas]) # Meta char
                (
                    (?:\\.|[^\\$metas])*  # Meat chars
                )
            /gxo
        ) {
            ($ref, $rref) = $stash->_mc->get($1, $mgc, $ref, $2, $rref, $level++)
              or return;
         }
    };
    if( $@ ){
        die "Error while parsing component $level of variable '$var' - $@";
    }
    return wantarray ? ( $ref, $rref )
                     : $ref
    ;
}

sub explicit_undefine {
    my ($stash, $ref, $met, $var) = @_;

    $var = $stash->interpolate($var);
    return unless length $var;

    my $metas = $stash->_metas;
    ($ref, $met, $var) = $stash->_do_global($ref, $met, $var, $metas);
    $var = "$met$var";

     # Extract final two list elements into $fvar/$fmet.
    my ($fvar, $fmet, @parts) = reverse $var =~ /
        ([$metas]) # Meta char
        (
            (?:\\.|[^\\$metas])*  # Meat chars
        )
    /gxo;
     # restore list to original order
    @parts = reverse @parts;
    my $mgc = $stash->_mg;
    my $level = 0;
    while ( ($met, $var, @parts) = @parts ) {
         # bail if undef is encountered during traversal
        ($ref) = $stash->_mc->def($met, $mgc, $ref, $var, $level++) or return;
    }
    $fmet = reftype($ref) eq 'ARRAY'
            ? $stash->_mc->meta_type('ARRAY')
            : $stash->_mc->meta_type('HASH')
      if $fmet eq $stash->_mc->meta_type('MAGIC')
    ;
    $fvar =~ s/\\(.)/$1/g;
    delete $ref->{$fvar} if $stash->_mc->meta_type($fmet) eq 'HASH';
    delete $ref->[$fvar] if $stash->_mc->meta_type($fmet) eq 'ARRAY';
    return;
}

sub explicit_is_defined {
    my ($stash, $ref, $met, $var) = @_;
    $var = $stash->interpolate($var);
    return defined $ref unless length $var;

    my $metas = $stash->_metas;
    ($ref, $met, $var) = $stash->_do_global($ref, $met, $var, $metas);
    $var = "$met$var";
    my $mgc = $stash->_mg;
    my $level = 0;
    while (
        $var =~ /
            ([$metas]) # Meta char
            (
                (?:\\.|[^\\$metas])*  # Meat chars
            )
        /gxo
    ) {
           # bail if undef is encountered during traversal
          ($ref) = $stash->_mc->def($1, $mgc, $ref, $2, $level++) or return;
    }
    return defined $ref;
}

1;
