File Coverage

blib/lib/Type/Tie.pm

Criterion	Covered	Total	%
statement	128	154	83.1
branch	26	40	65.0
condition	9	22	40.9
subroutine	31	35	88.5
pod	1	1	100.0
total	195	252	77.3

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.015';
	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.015';

	BEGIN {
		my $impl;
		$impl ||= eval { require Hash::FieldHash;               'Hash::FieldHash' };
		$impl ||= eval { require Hash::Util::FieldHash;         'Hash::Util::FieldHash' };
		$impl ||= do   { require Hash::Util::FieldHash::Compat; 'Hash::Util::FieldHash::Compat' };
		$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];
	}

	# store the $type for the exiting instances so the type can be set
	# (uncloned) in the clone too. A clone process could be cloning several
	# instances of this class, so use a hash to hold the types during
	# cloning. These types are reference counted, so the last reference to
	# a particular type deletes its key.
	my %tmp_clone_types;
	sub STORABLE_freeze {
		die "Scalar::Util is needed for cloning with Storage::dclone"
			unless eval { require Scalar::Util };
		my $self = shift;
		my $cloning = shift;

		die "Storage::freeze only supported for dclone-ing"
			unless $cloning;

		my $type = $TYPE{$self};
		my $refaddr = Scalar::Util::refaddr($type);
		$tmp_clone_types{$refaddr} ||= [ $type, 0 ];
		++$tmp_clone_types{$refaddr}[1];
		return (pack('j', $refaddr), $self);
	}

	sub STORABLE_thaw {
		my $self = shift;
		my $cloning = shift;
		my $packedRefaddr = shift;
		my $obj = shift;

		die "Storage::thaw only supported for dclone-ing"
			unless $cloning;

		$self->_STORABLE_thaw_update_from_obj($obj);
		my $refaddr = unpack('j', $packedRefaddr);
		my $type = $tmp_clone_types{$refaddr}[0];
		--$tmp_clone_types{$refaddr}[1]
			or delete $tmp_clone_types{$refaddr};
		$self->_set_type($type);
	}
};

BEGIN
{
	package Type::Tie::ARRAY;
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.015';
	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) );
	}

	sub _STORABLE_thaw_update_from_obj {
		my $self = shift;
		my $obj = shift;
		@$self = @$obj;
	}
};

BEGIN
{
	package Type::Tie::HASH;
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.015';
	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]));
	}

	sub _STORABLE_thaw_update_from_obj {
		my $self = shift;
		my $obj = shift;
		%$self = %$obj;
	}
};

BEGIN
{
	package Type::Tie::SCALAR;
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.015';
	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]) );
	}

	sub _STORABLE_thaw_update_from_obj {
		my $self = shift;
		my $obj = shift;
		$self = $obj;
	}
};

1;

__END__