
package Text::Wigwam::Cast::Base;

use strict;
use warnings;
no warnings q/uninitialized/;
our $VERSION = '0.01';

use Text::Wigwam::Const qw(:all);
use Scalar::Util( qw/ blessed reftype refaddr / );

 # Call the bit_cast method when specifying a bit-masked want type
sub bit_cast {
    my ($cast, $have, $needs, $data) = @_;
    my $want = $cast->_want($needs)
            || reftype($data)
            || 'String'
    ;
    return $cast->_qualifier($needs)->qualify($cast, $have, $needs, $want, $data);
}

 # Call the do_cast method when specifying a want type as text,
 # such as String, Scalar, Array or Hash.

sub do_cast {
    my ($cast, $want, $data) = @_;
    $data = $$data while ref($data) eq 'REF';
    return $cast->do_cast($want, $data->execute) # Potential infinite loop
      if $cast->is_expr($data);
    return $cast->do_cast($want, $data->())         # Potential infinite loop
      if $cast->is_code($data);
    $cast->_cast_subclass($want, $data)->cast($data);
}

sub _cast_subclass {
    my ($cast, $want, $data) = @_;
    my $class = $cast->_subclass(
        ucfirst lc reftype($data) || 'String',
        'To',
        ucfirst lc $want,
    );
    die "Unsupported cast method $class"
      unless $class->can( 'cast' );
    return $class;
}

     # Generalized/unified data type detection routines
sub is_hash {
    my ($self, $val) = @_;
    return !$self->is_expr($val)
        && UNIVERSAL::isa( $val, 'HASH' )
#        && reftype($val) eq 'HASH'
    ;
}
sub is_list {
    my ($self, $val) = @_;
    return !$self->is_expr($val)
        && UNIVERSAL::isa( $val, 'ARRAY' )
#        && reftype($val) eq 'ARRAY'
    ;
}
sub is_code { return reftype($_[1]) eq 'CODE' }
sub is_string { return !length( ref($_[1]) )  }
sub is_scalar { return reftype($_[1]) eq 'SCALAR'  }
sub is_glob { return reftype($_[1]) eq 'GLOB' }
sub is_expr {
    my ($self, $val) = @_;
    return
        blessed($val)
     && ($val->isa( q/Text::Wigwam::Expression/ ) )
    ;
}
sub is_num { return( $_[1] =~ /^[+-]?(\d+[.]?\d*|[.]\d+)([Ee][+-]?\d+)?$/ ) }
sub is_blessed { return blessed($_[1]) }

sub ref_type {
    my ($self, $val) = @_;
    return $self->is_expr($val) ? 'EXPR' : reftype($val)
}

sub _subclass {
    my ($cast, @subc) = @_;
    my $class = join(
        "::" =>
        ref($cast) || $cast,
        @subc,
    );
}

sub _want {
    my ($self, $needs) = @_;
    return $needs & STRING     ? 'String'
         : $needs & SCALAR ? 'Scalar'
         : $needs & ARRAY      ? 'Array'
         : $needs & HASH       ? 'Hash'
         : undef
    ;
}

sub _qualifier {
    my ($self, $needs) = @_;
    return
      $self->_subclass(
        Qualifier => 
        (    $needs & BOOLEAN ? 'Boolean'
           : $needs & NUM     ? 'Num'
           : $needs & STRICT  ? 'Strict'
           : $needs & CODE    ? 'Code'
           : $needs & BLESSED ? 'Blessed'
           :                    'DEFAULT'
        )
      )
    ;
}

sub _wrong_type {           # Qualifier specific
    my ($self, $needs, $want, $val) = @_;
    return 
        "Encountered ".(reftype($val)||'String')
      . "("
      . (
            ref($val)
            ? blessed($val)
              ? ref($val)
              : refaddr($val)
            : length($val)
              ? "$val"
              : "null string"
        )
      . ")"
      . " where ".$self->show_needs($needs)
      . " was expected"
    ;
}

sub show_needs {
    my ($self, $needs) = @_;
    my @types = ();
    push ( @types, 'ANY' )        if $needs & ANY;
    push ( @types, 'VAR' )        if $needs & VAR;
    push ( @types, 'VOID' )       if $needs & VOID;
    push ( @types, 'BLOCK' )      if $needs & BLOCK;
    push ( @types, 'OPTIONAL' )   if $needs & OPTIONAL;
    push ( @types, 'ITERATE' )    if $needs & ITERATE;
    push ( @types, 'STRICT' )     if $needs & STRICT;
    push ( @types, 'HASH' )       if $needs & HASH;
    push ( @types, 'NUM' )        if $needs & NUM;
    push ( @types, 'BOOLEAN' )    if $needs & BOOLEAN;
    push ( @types, 'ARRAY' )      if $needs & ARRAY;
    push ( @types, 'EXPR' )       if $needs & EXPR;
    push ( @types, 'STRING' )     if $needs & STRING;
    push ( @types, 'BLESSED' )    if $needs & BLESSED;
    push ( @types, 'CODE' )       if $needs & CODE;
    push ( @types, 'SCALAR' ) if $needs & SCALAR;
    return join( ' | ' => @types );
}

package Text::Wigwam::Cast::Base::Qualifier::DEFAULT;
    use strict;
    use warnings;
    sub qualify {
        my($self, $cast, $have, $needs, $want, $value) = @_;
        return $cast->do_cast($want, $value);
    }


package Text::Wigwam::Cast::Base::Qualifier::Boolean;
    use strict;
    use warnings;
    sub qualify {
        my($self, $cast, $have, $needs, $want, $value) = @_;
        my $val = $cast->do_cast(String => $value);
        return $cast->is_num($val)
               ? $val+0 ? 1 : 0
               : $val   ? 1 : 0
        ;
    }

package Text::Wigwam::Cast::Base::Qualifier::Num;
    use strict;
    use warnings;
    no warnings 'uninitialized';

    use Text::Wigwam::Const qw(STRICT NUM);
    sub qualify {
        my($self, $cast, $have, $needs, $want, $value) = @_;
        return $value if  ($have & NUM)
                       || $cast->is_num($value);
         # Cast null string  to 0 unless STRICT
        return 0 unless  length $value
                      || ($needs & STRICT); 
        my $val = $cast->do_cast(String => $value);
        return $val if $cast->is_num($val);
        die $cast->_wrong_type($needs, $want, $value);
    }

package Text::Wigwam::Cast::Base::Qualifier::Strict;
    use strict;
    use warnings;
    sub qualify {
        my($self, $cast, $have, $needs, $want, $value) = @_;
        die $cast->_wrong_type($needs, $want, $value);
    }

package Text::Wigwam::Cast::Base::Qualifier::Code;
    use strict;
    use warnings;
    sub qualify {
        my($self, $cast, $have, $needs, $want, $value) = @_;
        die $cast->_wrong_type($needs, $want, $value);
    }

package Text::Wigwam::Cast::Base::Qualifier::Blessed;
    use strict;
    use warnings;
    sub qualify {
        my($self, $cast, $have, $needs, $want, $value) = @_;
        die $cast->_wrong_type($needs, $want, $value);
    }

# Have GLOB

package Text::Wigwam::Cast::Base::Glob::To::Array;
    use strict;
    use warnings;
    sub cast { return \@{*{$_[1]}} }

package Text::Wigwam::Cast::Base::Glob::To::Hash;
    use strict;
    use warnings;
    sub cast { return \%{*{$_[1]}} }

package Text::Wigwam::Cast::Base::Glob::To::Scalar;
    use strict;
    use warnings;
    sub cast { return \${*{$_[1]}} }

package Text::Wigwam::Cast::Base::Glob::To::String;
    use strict;
    use warnings;
    sub cast { return ${*{$_[1]}} }

# Have ARRAY

package Text::Wigwam::Cast::Base::Array::To::Array;
    use strict;
    use warnings;
    sub cast { $_[1] }

package Text::Wigwam::Cast::Base::Array::To::Hash;
    use strict;
    use warnings;
    sub cast { return { @{$_[1]} } }  

package Text::Wigwam::Cast::Base::Array::To::Scalar;
    use strict;
    use warnings;
    sub cast { return \${ scalar @{$_[1]} } }

package Text::Wigwam::Cast::Base::Array::To::String;
    use strict;
    use warnings;
    sub cast { return scalar @{$_[1]} }


# Have HASH

package Text::Wigwam::Cast::Base::Hash::To::Hash;
    use strict;
    use warnings;
    sub cast { $_[1] }

package Text::Wigwam::Cast::Base::Hash::To::Array;
    use strict;
    use warnings;
    sub cast { return [ %{$_[1]} ] }

package Text::Wigwam::Cast::Base::Hash::To::Scalar;
    use strict;
    use warnings;
    sub cast { return \${ scalar keys %{$_[1]} } }

package Text::Wigwam::Cast::Base::Hash::To::String;
    use strict;
    use warnings;
    sub cast { return scalar keys %{$_[1]} }


# Have Scalar (reference)

package Text::Wigwam::Cast::Base::Scalar::To::Scalar;
    use strict;
    use warnings;
    sub cast { $_[1] }

package Text::Wigwam::Cast::Base::Scalar::To::Hash;
    use strict;
    use warnings;
    sub cast { return { value => ${$_[1]} } }

package Text::Wigwam::Cast::Base::Scalar::To::Array;
    use strict;
    use warnings;
    sub cast { return [ ${$_[1]} ] }

package Text::Wigwam::Cast::Base::Scalar::To::String;
    use strict;
    use warnings;
    sub cast { return ${$_[1]} }


# Have String

package Text::Wigwam::Cast::Base::String::To::String;
    use strict;
    use warnings;
    sub cast { $_[1] }

package Text::Wigwam::Cast::Base::String::To::Hash;
    use strict;
    use warnings;
    no warnings 'uninitialized';
    sub cast { return length $_[1] ? { value => $_[1] } : {} }

package Text::Wigwam::Cast::Base::String::To::Array;
    use strict;
    use warnings;
    no warnings 'uninitialized';
    sub cast { return length $_[1] ? [ $_[1] ] : [] }

package Text::Wigwam::Cast::Base::String::To::Scalar;
    use strict;
    use warnings;
    no warnings 'uninitialized';
    sub cast { \$_[1] }

1;
