File Coverage

blib/lib/Class/XSReader.pm

Criterion	Covered	Total	%
statement	44	62	70.9
branch	22	46	47.8
condition	9	36	25.0
subroutine	7	9	77.7
pod			n/a
total	82	153	53.5

use 5.008008;
use strict;
use warnings;
use Class::XSConstructor ();

package Class::XSReader;

BEGIN {
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.023006';

	if ( eval { require Types::Standard; 1 } ) {
		Types::Standard->import(
			qw/ is_ArrayRef is_HashRef is_ScalarRef is_CodeRef is_Object /
		);
	}
	else {
		eval q|
			require Scalar::Util;
			sub is_ArrayRef  ($) { ref $_[0] eq 'ARRAY' }
			sub is_HashRef   ($) { ref $_[0] eq 'HASH' }
			sub is_ScalarRef ($) { ref $_[0] eq 'SCALAR' or ref $_[0] eq 'REF' }
			sub is_CodeRef   ($) { ref $_[0] eq 'CODE' }
			sub is_Object    ($) { !!Scalar::Util::blessed($_[0]) }
		|;
	}
};

sub import {
	my $class = shift;

	my $package;
	if ( 'SCALAR' eq ref $_[0] ) {
		$package = ${+shift};
	}
	$package ||= our($SETUP_FOR) || caller;

	while ( @_ ) {
		my $slot  = shift;
		my $thing = ref($_[0]) ? shift : {};
		my %spec;
		my $type;

		if ( is_ArrayRef $thing ) {
			%spec = @$thing;
		}
		elsif ( is_HashRef $thing ) {
			%spec = %$thing;
		}
		elsif ( is_CodeRef $thing ) {
			%spec = ( default => $thing );
		}
		else {
			Exporter::Tiny::_croak( "Expected ARRAY/HASH/CODE reference, not $thing" );
		}

		if ( $slot =~ /\A(.*)\!\z/ ) {
			$slot = $1;
			$spec{required} = !!1;
		}

		$spec{lazy} = 1 unless exists $spec{lazy};

		if ( is_Object $spec{isa} and $spec{isa}->can('compiled_check') ) {
			$type = $spec{isa};
			$spec{isa} = $type->compiled_check;
		}
		elsif ( is_Object $spec{isa} and $spec{isa}->can('check') ) {
			# Support it for compatibility with more basic Type::API::Constraint
			# implementations, but this will be slowwwwww!
			$type = $spec{isa};
			$spec{isa} = sub { !! $type->check($_[0]) };
		}

		if ( defined $spec{coerce} and !ref $spec{coerce} and $spec{coerce} eq 1 ) {
			my $c;
			if (
				$type->can('has_coercion')
				and $type->has_coercion
				and $type->can('coercion')
				and is_Object( $c = $type->coercion )
				and $c->can('compiled_coercion') ) {
				$spec{coerce} = $c->compiled_coercion;
			}
			elsif ( $type->can('coerce') ) {
				$spec{coerce} = sub { $type->coerce($_[0]) };
			}
		}

		my @unknown_keys = grep !/\A(isa|required|is|lazy|default|builder|coerce|init_arg|trigger|weak_ref|alias|slot_initializer|undef_tolerant|reader|clone|clone_on_write|clone_on_read)\z/, keys %spec;
		if ( @unknown_keys ) {
			_croak("Unknown keys in spec: %s", join ", ", sort @unknown_keys);
		}

		my $has_default = ( exists $spec{default} or defined $spec{builder} ) ? !!$spec{lazy} : 0;
		my $has_type    = exists $spec{isa};
		my $clone       = ( $spec{clone_on_read} or $spec{clone} );

		my @XS_args = (
			sprintf( '%s::%s', $package, exists($spec{reader}) ? $spec{reader} : $slot ),
			$slot,
			$has_default,
			$has_default ? Class::XSConstructor::_common_default( $spec{default} ) : 0,
			$has_default ? Class::XSConstructor->_canonicalize_defaults( \%spec ) : undef,
			$has_type ? Class::XSConstructor::_type_to_number( $type ) : 15,
			$has_type ? $spec{isa} : undef,
			$has_type ? $spec{coerce} : undef,
			$clone ? $clone : undef,
		);

		if (our $REDEFINE) {
			no warnings 'redefine';
			Class::XSConstructor::install_reader( @XS_args );
		}
		else {
			Class::XSConstructor::install_reader( @XS_args );
		}
	}
}

1;

__END__