File Coverage

blib/lib/Type/Tiny/XS.pm

Criterion	Covered	Total	%
statement	96	109	88.0
branch	47	70	67.1
condition	11	21	52.3
subroutine	14	15	93.3
pod	3	3	100.0
total	171	218	78.4

use 5.008005;
use strict;
use warnings;
use XSLoader ();

package Type::Tiny::XS;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.024';

__PACKAGE__->XSLoader::load( $VERSION );

use Scalar::Util qw(refaddr);

my %names = (
	map +( $_ => __PACKAGE__ . "::$_" ), qw/
		Any ArrayRef Bool ClassName CodeRef Defined
		FileHandle GlobRef HashRef Int Num Object
		Ref RegexpRef ScalarRef Str Undef Value
		PositiveInt PositiveOrZeroInt NonEmptyStr
		ArrayLike HashLike CodeLike StringLike
		Map Tuple Enum AnyOf AllOf
		/
);
$names{Item} = $names{Any};

if ( $] lt '5.010000' ) {
	require MRO::Compat;
	*Type::Tiny::XS::Util::get_linear_isa = \&mro::get_linear_isa;

	my $overloaded = sub {
		require overload;
		overload::Overloaded( ref $_[0] or $_[0] )
			and overload::Method( ( ref $_[0] or $_[0] ), $_[1] );
	};

	no warnings qw( uninitialized redefine once );
	*StringLike = sub {
		defined( $_[0] ) && !ref( $_[0] )
			or Scalar::Util::blessed( $_[0] ) && $overloaded->( $_[0], q[""] );
	};
	*CodeLike = sub {
		ref( $_[0] ) eq 'CODE'
			or Scalar::Util::blessed( $_[0] ) && $overloaded->( $_[0], q[&{}] );
	};
	*HashLike = sub {
		ref( $_[0] ) eq 'HASH'
			or Scalar::Util::blessed( $_[0] ) && $overloaded->( $_[0], q[%{}] );
	};
	*ArrayLike = sub {
		ref( $_[0] ) eq 'ARRAY'
			or Scalar::Util::blessed( $_[0] ) && $overloaded->( $_[0], q[@{}] );
	};
} #/ if ( $] < '5.010000' [)

my %coderefs;

sub _know {
	my ( $coderef, $type ) = @_;
	$coderefs{ refaddr( $coderef ) } = $type;
}

sub is_known {
	my $coderef = shift;
	$coderefs{ refaddr( $coderef ) };
}

for ( reverse sort keys %names ) {
	no strict qw(refs);
	_know \&{ $names{$_} }, $_;
}

my $id = 0;

sub get_coderef_for {
	my $type = $_[0];

	return do {
		no strict qw(refs);
		\&{ $names{$type} };
	} if exists $names{$type};

	my $made;

	if ( $type =~ /^ArrayRef\[(.+)\]$/ ) {
		my $child = get_coderef_for( $1 ) or return;
		$made = _parameterize_ArrayRef_for( $child );
	}

	elsif ( $] ge '5.010000' and $type =~ /^ArrayLike\[(.+)\]$/ ) {
		my $child = get_coderef_for( $1 ) or return;
		$made = _parameterize_ArrayLike_for( $child );
	}

	elsif ( $type =~ /^HashRef\[(.+)\]$/ ) {
		my $child = get_coderef_for( $1 ) or return;
		$made = _parameterize_HashRef_for( $child );
	}

	elsif ( $] ge '5.010000' and $type =~ /^HashLike\[(.+)\]$/ ) {
		my $child = get_coderef_for( $1 ) or return;
		$made = _parameterize_HashLike_for( $child );
	}

	elsif ( $type =~ /^Map\[(.+),(.+)\]$/ ) {
		my @children;
		if ( eval { require Type::Parser } ) {
			@children = map scalar( get_coderef_for( $_ ) ), _parse_parameters( $type );
		}
		else {
			push @children, get_coderef_for( $1 );
			push @children, get_coderef_for( $2 );
		}
		@children == 2 or return;
		defined        or return for @children;
		$made = _parameterize_Map_for( \@children );
	} #/ elsif ( $type =~ /^Map\[(.+),(.+)\]$/)

	elsif ( $type =~ /^(AnyOf|AllOf|Tuple)\[(.+)\]$/ ) {
		my $base = $1;
		my @children =
			map scalar( get_coderef_for( $_ ) ),
			( eval { require Type::Parser } )
			? _parse_parameters( $type )
			: split( /,/, $2 );
		defined or return for @children;
		my $maker = __PACKAGE__->can( "_parameterize_${base}_for" );
		$made = $maker->( \@children ) if $maker;
	} #/ elsif ( $type =~ /^(AnyOf|AllOf|Tuple)\[(.+)\]$/)

	elsif ( $type =~ /^Maybe\[(.+)\]$/ ) {
		my $child = get_coderef_for( $1 ) or return;
		$made = _parameterize_Maybe_for( $child );
	}

	elsif ( $type =~ /^InstanceOf\[(.+)\]$/ ) {
		my $class = $1;
		return unless Type::Tiny::XS::Util::is_valid_class_name( $class );
		$made = Type::Tiny::XS::Util::generate_isa_predicate_for( $class );
	}

	elsif ( $type =~ /^HasMethods\[(.+)\]$/ ) {
		my $methods = [ sort( split /,/, $1 ) ];
		/^[^\W0-9]\w*$/ or return for @$methods;
		$made = Type::Tiny::XS::Util::generate_can_predicate_for( $methods );
	}

	# Type::Tiny::Enum > 1.010003 double-quotes its enums
	elsif ( $type =~ /^Enum\[".*"\]$/ ) {
		if ( eval { require Type::Parser } ) {
			my $parsed = Type::Parser::parse( $type );
			if ( $parsed->{type} eq "parameterized" ) {
				my @todo = $parsed->{params};
				my @strings;
				my $bad;
				while ( my $todo = shift @todo ) {
					if ( $todo->{type} eq 'list' ) {
						push @todo, @{ $todo->{list} };
					}
					elsif ( $todo->{type} eq "expression"
						&& $todo->{op}->type eq Type::Parser::COMMA() )
					{
						push @todo, $todo->{lhs}, $todo->{rhs};
					}
					elsif ( $todo->{type} eq "primary" && $todo->{token}->type eq "QUOTELIKE" ) {
						push @strings, eval( $todo->{token}->spelling );
					}
					else {
						# Unexpected entry in the parse-tree, bail out
						$bad = 1;
					}
				} #/ while ( my $todo = shift ...)
				$made = _parameterize_Enum_for( \@strings ) unless $bad;
			} #/ if ( $parsed->{type} eq...)
		} #/ if ( eval { require Type::Parser...})
	} #/ elsif ( $type =~ /^Enum\[".*"\]$/)

	elsif ( $type =~ /^Enum\[(.+)\]$/ ) {
		my $strings = [ sort( split /,/, $1 ) ];
		$made = _parameterize_Enum_for( $strings );
	}

	if ( $made ) {
		no strict qw(refs);
		my $slot = sprintf( '%s::AUTO::TC%d', __PACKAGE__, ++$id );
		$names{$type} = $slot;
		_know( $made, $type );
		*$slot = $made;
		return $made;
	}

	return;
} #/ sub get_coderef_for

sub get_subname_for {
	my $type = $_[0];
	get_coderef_for( $type ) unless exists $names{$type};
	$names{$type};
}

sub _parse_parameters {
	my $got = Type::Parser::parse( @_ );
	$got->{params} or return;
	_handle_expr( $got->{params} );
}

sub _handle_expr {
	my $e = shift;

	if ( $e->{type} eq 'list' ) {
		return map _handle_expr( $_ ), @{ $e->{list} };
	}
	if ( $e->{type} eq 'parameterized' ) {
		my ( $base ) = _handle_expr( $e->{base} );
		my @params = _handle_expr( $e->{params} );
		return sprintf( '%s[%s]', $base, join( q[,], @params ) );
	}
	if ( $e->{type} eq 'expression' and $e->{op}->type eq Type::Parser::COMMA() ) {
		return _handle_expr( $e->{lhs} ), _handle_expr( $e->{rhs} );
	}
	if ( $e->{type} eq 'primary' ) {
		return $e->{token}->spelling;
	}

	'****';
} #/ sub _handle_expr

1;

__END__