File Coverage

blib/lib/Type/Tie.pm

Criterion	Covered	Total	%
statement	100	121	82.6
branch	19	32	59.3
condition	7	17	41.1
subroutine	27	30	90.0
pod	1	1	100.0
total	154	201	76.6

use 5.008005;
use strict;
use warnings;

use Carp ();
use Exporter::Tiny ();
use Tie::Array ();
use Tie::Hash ();
use Tie::Scalar ();

++$Carp::CarpInternal{"Type::Tie::$_"} for qw( BASE SCALAR ARRAY HASH );

BEGIN
{
	package Type::Tie;
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.014';
	our @ISA       = qw( Exporter::Tiny );
	our @EXPORT    = qw( ttie );

	sub ttie (\[$@%]@)#>&%*/&<%\$[]^!@;@)
	{
		my ($ref, $type, @vals) = @_;

		if (ref($ref) eq "HASH")
		{
			tie(%$ref, "Type::Tie::HASH", $type);
			%$ref = @vals if @vals;
		}
		elsif (ref($ref) eq "ARRAY")
		{
			tie(@$ref, "Type::Tie::ARRAY", $type);
			@$ref = @vals if @vals;
		}
		else
		{
			tie($$ref, "Type::Tie::SCALAR", $type);
			$$ref = $vals[-1] if @vals;
		}
		return $ref;
	}
};

BEGIN
{
	package Type::Tie::BASE;
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.014';

	BEGIN {
		my $impl;
		$impl ||= eval { require Hash::FieldHash;       'Hash::FieldHash' };
		$impl ||= do   { require Hash::Util::FieldHash; 'Hash::Util::FieldHash' };
		$impl->import('fieldhash');
	};

	fieldhash(my %TYPE);
	fieldhash(my %COERCE);
	fieldhash(my %CHECK);

	sub _set_type
	{
		my $self = shift;
		my $type = $_[0];

		$TYPE{$self} = $type;

		if ($type->isa('Type::Tiny'))
		{
			$CHECK{$self} = $type->compiled_check;
			$COERCE{$self} = undef;
			$COERCE{$self} = $type->coercion->compiled_coercion
				if $type->has_coercion;
		}
		else
		{
			$CHECK{$self} = $type->can('compiled_check')
				? $type->compiled_check
				: sub { $type->check($_[0]) };
			$COERCE{$self} = undef;
			$COERCE{$self} = sub { $type->coerce($_[0]) }
				if $type->can("has_coercion")
				&& $type->can("coerce")
				&& $type->has_coercion;
		}
	}

	sub type
	{
		my $self = shift;
		$TYPE{$self};
	}

	sub _dd
	{
		my $value = @_ ? $_[0] : $_;
		!defined $value ? 'Undef' :
		!ref $value     ? sprintf('Value %s', B::perlstring($value)) :
		do {
			require Data::Dumper;
			local $Data::Dumper::Indent   = 0;
			local $Data::Dumper::Useqq    = 1;
			local $Data::Dumper::Terse    = 1;
			local $Data::Dumper::Sortkeys = 1;
			local $Data::Dumper::Maxdepth = 2;
			Data::Dumper::Dumper($value)
		}
	}

	sub coerce_and_check_value
	{
		my $self   = shift;
		my $check  = $CHECK{$self};
		my $coerce = $COERCE{$self};

		my @vals = map {
			my $val = $coerce ? $coerce->($_) : $_;
			if (not $check->($val)) {
				my $type = $TYPE{$self};
				Carp::croak(
					$type && $type->can('get_message')
						? $type->get_message($val)
						: sprintf("%s does not meet type constraint %s", _dd($_), $type||'Unknown')
				);
			}
			$val;
		} (my @cp = @_);  # need to copy @_ for Perl < 5.14

		wantarray ? @vals : $vals[0];
	}
};

BEGIN
{
	package Type::Tie::ARRAY;
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.014';
	our @ISA       = qw( Tie::StdArray Type::Tie::BASE );

	sub TIEARRAY
	{
		my $class = shift;
		my $self = $class->SUPER::TIEARRAY;
		$self->_set_type($_[0]);
		return $self;
	}

	sub STORE
	{
		my $self = shift;
		$self->SUPER::STORE($_[0], $self->coerce_and_check_value($_[1]));
	}

	sub PUSH
	{
		my $self = shift;
		$self->SUPER::PUSH( $self->coerce_and_check_value(@_) );
	}

	sub UNSHIFT
	{
		my $self = shift;
		$self->SUPER::UNSHIFT( $self->coerce_and_check_value(@_) );
	}

	sub SPLICE
	{
		my $self = shift;
		my ($start, $len, @rest) = @_;
		$self->SUPER::SPLICE($start, $len, $self->coerce_and_check_value(@rest) );
	}
};

BEGIN
{
	package Type::Tie::HASH;
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.014';
	our @ISA       = qw( Tie::StdHash Type::Tie::BASE );

	sub TIEHASH
	{
		my $class = shift;
		my $self = $class->SUPER::TIEHASH;
		$self->_set_type($_[0]);
		return $self;
	}

	sub STORE
	{
		my $self = shift;
		$self->SUPER::STORE($_[0], $self->coerce_and_check_value($_[1]));
	}
};

BEGIN
{
	package Type::Tie::SCALAR;
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.014';
	our @ISA       = qw( Tie::StdScalar Type::Tie::BASE );

	sub TIESCALAR
	{
		my $class = shift;
		my $self = $class->SUPER::TIESCALAR;
		$self->_set_type($_[0]);
		return $self;
	}

	sub STORE
	{
		my $self = shift;
		$self->SUPER::STORE( $self->coerce_and_check_value($_[0]) );
	}
};

1;

__END__