File Coverage

blib/lib/Type/Tie.pm

Criterion	Covered	Total	%
statement	134	134	100.0
branch	31	38	81.5
condition	9	16	56.2
subroutine	48	48	100.0
pod	1	1	100.0
total	223	237	94.0

use 5.008001;
use strict;
use warnings;

use Carp ();
use Exporter::Tiny ();
use Scalar::Util ();

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

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

	$VERSION =~ tr/_//d;

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

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

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

	$VERSION =~ tr/_//d;

	# Type::Tie::BASE is an array-based object. If you need to subclass it
	# and store more attributes, use $yourclass->SUPER::_NEXT_SLOT to find
	# the next available slot, then override _NEXT_SLOT so that other people
	# can subclass your class too.
	#
	sub _REF       { $_[0][0] }                                      # ro
	sub _TYPE      { ( @_ == 2 ) ? ( $_[0][1] = $_[1] ) : $_[0][1] } # rw
	sub _CHECK     { ( @_ == 2 ) ? ( $_[0][2] = $_[1] ) : $_[0][2] } # rw
	sub _COERCE    { ( @_ == 2 ) ? ( $_[0][3] = $_[1] ) : $_[0][3] } # rw
	sub _NEXT_SLOT { 4 }

	sub type       { shift->_TYPE }
	sub _INIT_REF  { $_[0][0] ||= $_[0]->_DEFAULT }

	{
		my $try_xs =
			exists( $ENV{PERL_TYPE_TINY_XS} ) ? !!$ENV{PERL_TYPE_TINY_XS} :
			exists( $ENV{PERL_ONLY} )         ? !$ENV{PERL_ONLY} :
			!!1;
		eval {
			require Class::XSAccessor::Array;
			'Class::XSAccessor::Array'->import(
				replace   => !!1,
				getters   => { _REF => 0, type => 1 },
				accessors => { _TYPE => 1, _CHECK => 2, _COERCE => 3 },
			);
		} if $try_xs;
	}

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

		$self->_TYPE( $type );

		if ( Scalar::Util::blessed( $type ) and $type->isa( 'Type::Tiny' ) ) {
			$self->_CHECK( $type->compiled_check );
			$self->_COERCE(
				$type->has_coercion
					? $type->coercion->compiled_coercion
					: undef
			);
		}
		else {
			$self->_CHECK(
				$type->can( 'compiled_check' )
					? $type->compiled_check
					: sub { $type->check( $_[0] ) }
			);
			$self->_COERCE(
				$type->can( 'has_coercion' ) && $type->can( 'coerce' ) && $type->has_coercion
					? sub { $type->coerce( $_[0] ) }
					: undef
			);
		}
	}

	# Only used if the type has no get_message method
	sub _dd {
		require Type::Tiny;
		goto \&Type::Tiny::_dd;
	}

	sub coerce_and_check_value {
		my $self   = shift;
		my $check  = $self->_CHECK;
		my $coerce = $self->_COERCE;

		my @vals = map {
			my $val = $coerce ? $coerce->( $_ ) : $_;
			if ( not $check->( $val ) ) {
				my $type = $self->_TYPE;
				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 {
		my ( $o, $cloning ) = @_;
		Carp::croak( "Storable::freeze only supported for dclone-ing" )
			unless $cloning;

		my $type = $o->_TYPE;
		my $refaddr = Scalar::Util::refaddr( $type );
		$tmp_clone_types{$refaddr} ||= [ $type, 0 ];
		++$tmp_clone_types{$refaddr}[1];

		return ( $refaddr, $o->_REF );
	}

	sub STORABLE_thaw {
		my ( $o, $cloning, $refaddr, $o2 ) = @_;
		Carp::croak( "Storable::thaw only supported for dclone-ing" )
			unless $cloning;

		$o->_THAW( $o2 ); # implement in child classes

		my $type = $tmp_clone_types{$refaddr}[0];
		--$tmp_clone_types{$refaddr}[1]
			or delete $tmp_clone_types{$refaddr};
		$o->_set_type($type);
	}
};

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

	$VERSION =~ tr/_//d;

	sub TIEARRAY   {
		my $class = shift;
		my $self  = bless( [ $class->_DEFAULT ], $class );
		$self->_set_type( $_[0] );
		$self;
	}
	sub _DEFAULT   { [] }
	sub FETCHSIZE  { scalar @{ $_[0]->_REF } }
	sub STORESIZE  { $#{ $_[0]->_REF } = $_[1] }
	sub STORE      { $_[0]->_REF->[ $_[1] ] = $_[0]->coerce_and_check_value( $_[2] ) }
	sub FETCH      { $_[0]->_REF->[ $_[1] ] }
	sub CLEAR      { @{ $_[0]->_REF } = () }
	sub POP        { pop @{ $_[0]->_REF } }
	sub PUSH       { my $s = shift; push @{$s->_REF}, $s->coerce_and_check_value( @_ ) }
	sub SHIFT      { shift @{ $_[0]->_REF } }
	sub UNSHIFT    { my $s = shift; unshift @{$s->_REF}, $s->coerce_and_check_value( @_ ) }
	sub EXISTS     { exists $_[0]->_REF->[ $_[1] ] }
	sub DELETE     { delete $_[0]->_REF->[ $_[1] ] }
	sub EXTEND     {}
	sub SPLICE     {
		my $o   = shift;
		my $sz  = scalar @{$o->_REF};
		my $off = @_ ? shift : 0;
		$off   += $sz if $off < 0;
		my $len = @_ ? shift : $sz-$off;
		splice @{$o->_REF}, $off, $len, $o->coerce_and_check_value( @_ );
	}
	sub _THAW      { @{ $_[0]->_INIT_REF } = @{ $_[1] } }
};

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

	$VERSION =~ tr/_//d;

	sub TIEHASH    {
		my $class = shift;
		my $self  = bless( [ $class->_DEFAULT ], $class );
		$self->_set_type( $_[0] );
		$self;
	}
	sub _DEFAULT   { +{} }
	sub STORE      { $_[0]->_REF->{ $_[1] } = $_[0]->coerce_and_check_value( $_[2] ) }
	sub FETCH      { $_[0]->_REF->{ $_[1] } }
	sub FIRSTKEY   { my $a = scalar keys %{ $_[0]->_REF }; each %{ $_[0]->_REF } }
	sub NEXTKEY    { each %{ $_[0]->_REF } }
	sub EXISTS     { exists $_[0]->_REF->{ $_[1] } }
	sub DELETE     { delete $_[0]->_REF->{ $_[1] } }
	sub CLEAR      { %{ $_[0]->_REF } = () }
	sub SCALAR     { scalar %{ $_[0]->_REF } }
	sub _THAW      { %{ $_[0]->_INIT_REF } = %{ $_[1] } }
};

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

	$VERSION =~ tr/_//d;

	sub TIESCALAR  {
		my $class = shift;
		my $self  = bless( [ $class->_DEFAULT ], $class );
		$self->_set_type($_[0]);
		$self;
	}
	sub _DEFAULT   { my $x; \$x }
	sub STORE      { ${ $_[0]->_REF } = $_[0]->coerce_and_check_value( $_[1] ) }
	sub FETCH      { ${ $_[0]->_REF } }
	sub _THAW      { ${ $_[0]->_INIT_REF } = ${ $_[1] } }
};

1;

__END__