File Coverage

blib/lib/Variable/Strongly/Typed.pm

Criterion	Covered	Total	%
statement	87	121	71.9
branch	6	26	23.0
condition	1	3	33.3
subroutine	25	30	83.3
pod	4	4	100.0
total	123	184	66.8

package Variable::Strongly::Typed;

use version; $VERSION = qv('1.1.0');

use warnings;
use strict;
use Carp;

# Tie any 'TYPE' attributes to me
use Attribute::Handlers;

# Our 3 friends for scalars & arrays & hashes
use Variable::Strongly::Typed::Scalar;
use Variable::Strongly::Typed::Array;
use Variable::Strongly::Typed::Hash;
use Variable::Strongly::Typed::Validators;
use Variable::Strongly::Typed::Code;

# Can't use Class::Std as it wants the 'ATTR' attribute
#   as does Attribute::Handlers...  Bummer
use Class::Std::Utils;
{
    # class variables
    my %actual_object_of;   # The actual object ref
    my %validator_sub_of;   # Validate subroutine
    my %type_of;            # Strong Type of this variable
    my %error_handler_of;   # Error handling function to call when
                            #   assignment/return goes wrong

    do {
        no warnings 'redefine';
        sub UNIVERSAL::TYPE : ATTR(SCALAR) {
            my ($package, $symbol, $referent, $attr, $data) = @_;

            tie $$referent, 'Variable::Strongly::Typed::Scalar', $data;
            return;
        }

        sub UNIVERSAL::TYPE : ATTR(ARRAY) {
            my ($package, $symbol, $referent, $attr, $data) = @_;

            tie @$referent, 'Variable::Strongly::Typed::Array', $data;
            return;
        }

        sub UNIVERSAL::TYPE : ATTR(HASH) {
            my ($package, $symbol, $referent, $attr, $data) = @_;

            tie %$referent, 'Variable::Strongly::Typed::Hash', $data;
            return;
        }

        sub UNIVERSAL::TYPE : ATTR(CODE) {
            my ($package, $symbol, $referent, $attr, $data) = @_;

            Variable::Strongly::Typed::Code->new($symbol, $referent, $data);
            return;

           }
    };

    # Set up our class variables
    sub _init {
        my($self, $object, $type) = @_;
        my $ident = ident $self;

        my $error_handler;

        if (ref $type eq 'ARRAY') {
            ($type, $error_handler) = @$type;
            croak("Error handler must be a CODE ref!")
                if (ref $error_handler ne 'CODE');
        }

        $actual_object_of   {$ident} = $object;
        $validator_sub_of   {$ident} = _make_validator_sub($type);
        $type_of            {$ident} = $type;
        $error_handler_of   {$ident} = $error_handler;

        return $self;
    }

    # Get actual object ref
    sub _get_object {
        my($self) = @_;
        return $actual_object_of{ident $self};
    }

    sub _get_type {
        my($self) = @_;
        return $type_of{ident $self};
    }

    sub _get_valid_sub {
        my($self) = @_;
        return $validator_sub_of{ident $self};
    }

    sub _get_error_handler {
        my($self) = @_;
        return $error_handler_of{ident $self};
    }

    sub _error {
        my($self, $val) = @_;
        my $eh = $self->_get_error_handler;

        if ($eh) {
            $eh->($val);
        } else {
            croak($self->_make_error_message($val));
        }
    }

    # Check if a value is okay...
    # IF this returns w/o croaking then all is okay...
    sub _check_values {
        my ($self, @values) = @_;

        my($valid_sub) = $self->_get_valid_sub;

        # if valid or failed sub says it's okay then ok
        #   otherwise undef
        # Note this works slightly differently then Tie::Constrained
        #   as we have no notion of an 'original' or 'default' value
        # 'failed' sub will croak if not valid...
        foreach my $val (@values) {

            # This'll croak (by default) if a value is not valid
            $valid_sub->($val) || $self->_error($val);
        }

        # if we got this far all must be good
        return \@values;
    }

    sub _make_error_message {
        my($self, $val) = @_;

        # 'num', 'string', 'IO::File' or CODE ref if user defined
        my $valid_type = $self->_get_type;

        # Scalar, Array, or Hash
        my ($variable_type) = $self =~ /:: ([^:=]+) =/xms;
        $variable_type = lc $variable_type;

        # String-ify value
        if (ref $val) {
            $val = (ref $val) . ' reference';
        } else {
            $val = "'$val'";
        }

        my $ww = $variable_type eq 'code' ? 'return' : 'assign';
        my $from_or_to = $variable_type eq 'code' ? 'from' : 'to';
        $variable_type = 'function or method' if $variable_type eq 'code';

        my $msg;
        if (ref $valid_type eq 'CODE') {
            $msg = "Cannot $ww $val $from_or_to a user-validated"
                . " $variable_type variable!";
        } else {
            $msg = "Cannot $ww $val $from_or_to a"
                . ($variable_type eq 'array' ? 'n' : '')
                . " $variable_type of type $valid_type!";
        }

        return $msg;
    }

    sub _make_validator_sub {
        my($val) = @_;

        # User supplied??
        return $val if ($val && (ref($val) eq 'CODE'));

        my $condition;

        # Stuff like 'int', 'string', 'float' ... 'primitive' types
        $condition = $Variable::Strongly::Typed::Validators::conditions{$val};

        unless ($condition) {
            # It's either SCALAR, ARRAY, HASH the exact object type
            #   or an isa...  A reference type basically
            $condition =
                'ref && ((ref eq ' . "'$val'" . ')'
                . ' || (ref ne "SCALAR" && ref ne "ARRAY"'
                .   ' && ref ne "HASH" && $_->isa(' . "'$val'" . ')))';
        }

        # Concoct validate sub
        my $sub =
            eval 'sub { local $_ = shift;' . ' !$_ || (' . $condition . ') }';

        if ($@) {
            croak("Unable to create a Strongly Typed $val!!");
        }

        return $sub;
    }

    # Clean Up, Clean Up, Everybody's Doing Some, Clean Up
    #   -Walter (26 months)
    sub DESTROY {
        my($self) = @_;
        my $ident = ident $self;

        my $obj = $self->_get_object;
        undef  $obj;
        delete $actual_object_of{$ident};
        delete $validator_sub_of{$ident};
        delete $type_of         {$ident};
    }

}

1; # Magic true value required at end of module
__END__