File Coverage

blib/lib/Class/XSConstructor.pm

Criterion	Covered	Total	%
statement	238	275	86.5
branch	157	216	72.6
condition	78	165	47.2
subroutine	27	29	93.1
pod	1	6	16.6
total	501	691	72.5

use 5.008008;
use strict;
use warnings;

package Class::XSConstructor;

use Exporter::Tiny 1.000000 qw( mkopt _croak _carp );
use List::Util 1.45 qw( uniq );

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]) }
		|;
	}

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

our ( %META, %BUILD_CACHE, %DEMOLISH_CACHE );

sub import {
	my $class = shift;
	my ( $package, $methodname );
	if ( 'ARRAY' eq ref $_[0] ) {
		( $package, $methodname ) = @{+shift};
	}
	$package    ||= our($SETUP_FOR) || caller;
	$methodname ||= 'new';

	$META{$package} ||= { package => $package };

	my @XS_args = (
		"$package\::$methodname",
		"$package\::BUILDALL",
		"$package\::XSCON_CLEAR_CONSTRUCTOR_CACHE",
	);
	if (our $REDEFINE) {
		no warnings 'redefine';
		install_constructor( @XS_args );
	}
	else {
		install_constructor( @XS_args );
	}

	inheritance_stuff( $package );

	for my $pair (@{ mkopt \@_ }) {
		my ($name, $thing) = @$pair;
		my %spec;
		my $type;

		if ($name eq '!!') {
			$META{$package}{strict_params} = !!1;
			next;
		}

		if ( is_ArrayRef $thing ) {
			%spec = @$thing;
		}
		elsif ( is_HashRef $thing ) {
			%spec = %$thing;
		}
		elsif ( is_Object $thing and $thing->can('compiled_check') || $thing->can('check') ) {
			%spec = ( isa => $thing );
		}
		elsif ( is_CodeRef $thing ) {
			%spec = ( isa => $thing );
		}
		elsif ( defined $thing ) {
			_croak("What is %s???", $thing);
		}

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

		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]) };
			}
		}

		if ( $spec{required} and exists $spec{init_arg} and not defined $spec{init_arg} ) {
			_croak("Required attribute $name cannot have undef init_arg");
		}

		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 %meta_attribute = (
			name     => $name,
			spec     => \%spec,
			flags    => $class->_build_flags( $name, \%spec, $type ),
			required => !!$spec{required},
			init_arg => exists( $spec{init_arg} ) ? $spec{init_arg} : $name,
		);

		if ( is_CodeRef $spec{isa} ) {
			$meta_attribute{check} = $spec{isa};
		}

		if ( is_CodeRef $spec{trigger} ) {
			$meta_attribute{trigger} = $spec{trigger};
		}
		elsif ( defined $spec{trigger} and not ref $spec{trigger} ) {
			$meta_attribute{trigger} = $spec{trigger};
		}

		if ( is_CodeRef $spec{coerce} ) {
			$meta_attribute{coercion} = $spec{coerce};
		}

		if ( exists $spec{default} or defined $spec{builder} ) {
			$meta_attribute{default} = $class->_canonicalize_defaults( \%spec )
				unless $spec{lazy};
		}

		if ( is_Object $type and $type->isa('Type::Tiny') ) {
			$meta_attribute{type} = $type;
		}

		if ( is_ArrayRef $spec{alias} ) {
			$meta_attribute{aliases} = $spec{alias};
		}
		elsif ( $spec{alias} ) {
			$meta_attribute{aliases} = [ $spec{alias} ];
		}

		if ( is_CodeRef $spec{slot_initializer} ) {
			$meta_attribute{slot_initializer} = $spec{slot_initializer};
		}

		if ( exists $spec{undef_tolerant} ) {
			$meta_attribute{undef_tolerant} = !!$spec{undef_tolerant};
		}

		if ( $spec{clone_on_write} or $spec{clone} ) {
			$meta_attribute{clone_on_write} = $spec{clone_on_write} || $spec{clone};
		}

		# Add new attribute
		push @{ $META{$package}{params} ||= [] }, \%meta_attribute;
	}

	if ( my $p = $META{$package}{params} ) {
		# Dedupe by name, but keep *last* copy (reverse reverse!)
		my %already;
		@$p = reverse grep { not $already{$_->{name}}++ } reverse @$p;

		if ( $META{$package}{strict_params} ) {
			# Keep big list of all allowed init_args
			%already = ();
			$META{$package}{allow} = [
				'__no_BUILD__',
				grep { not $already{$_}++ }
				map {
					my @names;
					push @names, $_->{init_arg} if defined $_->{init_arg};
					push @names, @{$_->{aliases}} if ref $_->{aliases};
					@names;
				} @$p
			];
		}
	}
	else {
		$META{$package}{params} = [];
	}
}

sub _canonicalize_defaults {
	my $package = shift;
	my $spec = shift;
	if ( defined $spec->{builder} ) {
		return \$spec->{builder};
	}
	elsif ( is_CodeRef $spec->{default} ) {
		return $spec->{default};
	}
	elsif ( is_ScalarRef $spec->{default} ) {
		my $str = ${ $spec->{default} };
		return eval "sub { $str }";
	}
	else {
		return $spec->{default};
	}
}

sub _is_bool ($) {
	my $value = shift;
	return !!0 unless defined $value;
	return !!0 if ref $value;
	return !!0 unless Scalar::Util::isdual( $value );
	return !!1 if  $value && "$value" eq '1' && $value+0 == 1;
	return !!1 if !$value && "$value" eq q'' && $value+0 == 0;
	return !!0;
}

sub _created_as_number ($) {
	my $value = shift;
	return !!0 if utf8::is_utf8($value);
	return !!0 unless defined $value;
	return !!0 if ref $value;
	require B;
	my $b_obj = B::svref_2object(\$value);
	my $flags = $b_obj->FLAGS;
	return !!1 if $flags & ( B::SVp_IOK() | B::SVp_NOK() ) and !( $flags & B::SVp_POK() );
	return !!0;
}

sub _created_as_string ($) {
	my $value = shift;
	defined($value)
		&& !ref($value)
		&& !_is_bool($value)
		&& !_created_as_number($value);
}

sub _type_to_number {
	my ( $type, $no_recurse ) = @_;

	if ( is_Object $type and $type->isa('Type::Tiny') ) {
		require Types::Common;
		if ( $type == Types::Common::Any() or $type == Types::Common::Item() ) {
			return XSCON_TYPE_BASE_ANY;
		}
		elsif ( $type == Types::Common::Defined() ) {
			return XSCON_TYPE_BASE_DEFINED;
		}
		elsif ( $type == Types::Common::Ref() ) {
			return XSCON_TYPE_BASE_REF;
		}
		elsif ( $type == Types::Common::Bool() ) {
			return XSCON_TYPE_BASE_BOOL;
		}
		elsif ( $type == Types::Common::Int() ) {
			return XSCON_TYPE_BASE_INT;
		}
		elsif ( $type == Types::Common::PositiveOrZeroInt() ) {
			return XSCON_TYPE_BASE_PZINT;
		}
		elsif ( $type == Types::Common::Num() ) {
			return XSCON_TYPE_BASE_NUM;
		}
		elsif ( $type == Types::Common::PositiveOrZeroNum() ) {
			return XSCON_TYPE_BASE_PZNUM;
		}
		elsif ( $type == Types::Common::Str() ) {
			return XSCON_TYPE_BASE_STR;
		}
		elsif ( $type == Types::Common::NonEmptyStr() ) {
			return XSCON_TYPE_BASE_NESTR;
		}
		elsif ( $type == Types::Common::ClassName() ) {
			return XSCON_TYPE_BASE_CLASSNAME;
		}
		elsif ( $type == Types::Common::Object() ) {
			return XSCON_TYPE_BASE_OBJECT;
		}
		elsif ( $type == Types::Common::ScalarRef() ) {
			return XSCON_TYPE_BASE_SCALARREF;
		}
		elsif ( $type == Types::Common::CodeRef() ) {
			return XSCON_TYPE_BASE_CODEREF;
		}
		elsif ( $type == Types::Common::ArrayRef() ) {
			return XSCON_TYPE_ARRAYREF;
		}
		elsif ( $type == Types::Common::HashRef() ) {
			return XSCON_TYPE_HASHREF;
		}
		elsif ( $type->is_parameterized and @{ $type->parameters } == 1 and (
			$type->parameterized_from == Types::Common::ArrayRef()
			or $type->parameterized_from == Types::Common::HashRef()
			) ) {
			return _type_to_number( $type->parameterized_from, 1 ) | _type_to_number( $type->type_parameter, 1 ) unless $no_recurse;
		}
	}

	# Returning 15 indicates an unknown type.
	# 31 will be an arrayref of some unknown type.
	# 47 will be an hashref of some unknown type.
	# Class::XSAccessor won't be able to do the type check internally.
	return XSCON_TYPE_OTHER;
}

sub _build_flags {
	my $package = shift;
	my $name = shift;
	my $spec = shift;
	my $type = shift;

	my $flags = 0;
	$flags |= XSCON_FLAG_REQUIRED              if $spec->{required};
	$flags |= XSCON_FLAG_HAS_TYPE_CONSTRAINT   if is_CodeRef $spec->{isa};
	$flags |= XSCON_FLAG_HAS_TYPE_COERCION     if is_CodeRef $spec->{coerce};
	$flags |= XSCON_FLAG_NO_INIT_ARG           if exists($spec->{init_arg}) && !defined($spec->{init_arg});
	$flags |= XSCON_FLAG_HAS_INIT_ARG          if defined($spec->{init_arg}) && ( $spec->{init_arg} ne $name );
	$flags |= XSCON_FLAG_HAS_TRIGGER           if $spec->{trigger};
	$flags |= XSCON_FLAG_WEAKEN                if $spec->{weak_ref};
	$flags |= XSCON_FLAG_HAS_ALIASES           if $spec->{alias};
	$flags |= XSCON_FLAG_HAS_SLOT_INITIALIZER  if $spec->{slot_initializer};
	$flags |= XSCON_FLAG_UNDEF_TOLERANT        if $spec->{undef_tolerant};
	$flags |= XSCON_FLAG_CLONE_ON_WRITE        if $spec->{clone_on_write} || $spec->{clone};

	unless ( $spec->{lazy} ) {
		$flags |= XSCON_FLAG_HAS_DEFAULT
			if exists($spec->{default})
			|| defined($spec->{builder});
		$flags |= ( _common_default($spec->{default}) << +XSCON_BITSHIFT_DEFAULTS )
			if exists($spec->{default});
	}

	if ( $type ) {
		my $has_common_type = _type_to_number( $type );
		$flags |= ( $has_common_type << +XSCON_BITSHIFT_TYPES );
	}
	elsif ( is_CodeRef $spec->{isa} ) {
		$flags |= ( 15 << +XSCON_BITSHIFT_TYPES );
	}

	return $flags;
}

sub _common_default {
	die unless @_ == 1;
	my $default = shift;

	return XSCON_DEFAULT_UNDEF        if ( not defined $default );
	return XSCON_DEFAULT_ZERO         if ( _created_as_number $default and $default == 0 );
	return XSCON_DEFAULT_ONE          if ( _created_as_number $default and $default == 1 );
	return XSCON_DEFAULT_FALSE        if ( _is_bool $default and not $default );
	return XSCON_DEFAULT_TRUE         if ( _is_bool $default and $default );
	return XSCON_DEFAULT_EMPTY_STR    if ( _created_as_string $default and $default eq '' );
	return XSCON_DEFAULT_EMPTY_ARRAY  if ( is_ScalarRef $default and $$default eq '[]' );
	return XSCON_DEFAULT_EMPTY_HASH   if ( is_ScalarRef $default and $$default eq '{}' );

	return 0;
}

sub inheritance_stuff {
	my $package = shift;

	require( $] >= 5.010 ? "mro.pm" : "MRO/Compat.pm" );

	my @isa = @{ mro::get_linear_isa($package) };
	shift @isa;  # discard $package itself
	return unless @isa;

	for my $parent ( @isa ) {
		no strict 'refs';
		no warnings 'once';
		# Moo will sometimes not have a constructor in &{"${parent}::new"}
		# when by all that is good and holy, it should.
		if ( $INC{'Moo.pm'} and $Moo::MAKERS{$parent} ) {
			Moo->_constructor_maker_for( $parent )->install_delayed;
			Sub::Defer::undefer_sub( \&{"${parent}::new"} );
		}
		if ( defined &{"${parent}::new"} ) {
			if ( not $META{$parent} ) {
				# We are inheriting from a foreign class.
				$META{$package}{foreignclass}         = $parent;
				$META{$package}{foreignconstructor}   = \&{"${parent}::new"};
				$META{$package}{foreignbuildall}      = $parent->can('BUILDALL');
			}
			last;
		}
	}

	my @attrs;
	for my $parent ( reverse @isa ) {
		my $p_attrs = $META{$parent}{params} or next;
		push @attrs, @$p_attrs;
	}

	$META{$package}{params} = \@attrs;
}

sub populate_demolish {
	my $package = ref($_[0]) || $_[0];
	my $klass   = ref($_[1]) || $_[1];

	if (!$klass->can('DEMOLISH')) {
		$DEMOLISH_CACHE{$klass} = 0;
		return;
	}

	require( $] >= 5.010 ? "mro.pm" : "MRO/Compat.pm" );
	no strict 'refs';
	no warnings 'once';

	$DEMOLISH_CACHE{$klass} = [
		reverse
		map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () }
		map { "$_\::DEMOLISH" }
		reverse @{ mro::get_linear_isa($klass) }
	];

	return;
}

sub populate_build {
	my $package = ref($_[0]) || $_[0];
	my $klass   = ref($_[1]) || $_[1];

	if (!$klass->can('BUILD')) {
		$BUILD_CACHE{$klass} = 0;
		return;
	}

	require( $] >= 5.010 ? "mro.pm" : "MRO/Compat.pm" );
	no strict 'refs';
	no warnings 'once';

	$BUILD_CACHE{$klass} = [
		map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () }
		map { "$_\::BUILD" }
		reverse @{ mro::get_linear_isa($klass) }
	];

	return;
}

sub get_metadata {
	my $klass = ref($_[0]) || $_[0];
	my $meta  = $META{$klass} or return;

	$meta->{buildargs} ||= $klass->can('BUILDARGS')
		unless $meta->{has_standard_buildargs};

	$meta->{foreignbuildargs} ||= $klass->can('FOREIGNBUILDARGS')
		if $meta->{foreignconstructor} && !$meta->{foreignbuildall};

	return $meta;
}

sub get_build_methods {
	my $klass = ref($_[0]) || $_[0];
	__PACKAGE__->populate_build( $klass );
	return @{ $BUILD_CACHE{$klass} or [] };
}

sub get_demolish_methods {
	my $klass = ref($_[0]) || $_[0];
	__PACKAGE__->populate_demolish( $klass );
	return @{ $DEMOLISH_CACHE{$klass} or [] };
}

__PACKAGE__
__END__