File Coverage

blib/lib/MooX/XSConstructor.pm

Criterion	Covered	Total	%
statement	100	110	90.9
branch	21	30	70.0
condition	11	15	73.3
subroutine	15	15	100.0
pod	3	3	100.0
total	150	173	86.7

use 5.008001;
use strict;
use warnings;

package MooX::XSConstructor;

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

use Class::Method::Modifiers 'install_modifier';
use Moo 2.004000 ();
use Moo::Object ();
use Hook::AfterRuntime;

# Options that either XSCON can handle, or have no effect on the
# constructor at all.
my $safe_spec = qr/\A(
	index |
	is | reader | writer | accessor | predicate | clearer |
	handles | handles_via |
	init_arg | required |
	isa | coerce |
	builder | default | lazy |
	trigger |
	weak_ref |
	documentation
)\z/x;

# Options that have no effect on the constructor at all, but need
# to be deleted so they don't confuse XSCON.
my $delete_from_spec = qr/\A(
	index |
	is | reader | writer | accessor | predicate | clearer |
	handles | handles_via |
	documentation
)\z/x;

sub is_suitable_class {
	my ( $self, $klass ) = @_;

	return unless Moo->is_class( $klass );

	my $constructor_maker = Moo->_constructor_maker_for( $klass );
	do {
		# If the class's constructor generator is Method::Generate::Constructor,
		# then we can predict its behaviour. If it's something unknown, we
		# don't know what it might do internally, so cannot safely replace
		# it with XSCON.
		my @allowed_constructor_makers = (
			'Method::Generate::Constructor',
		);

		# This is one trait that might be applied to the constructor maker
		# which we *know* we are able to handle.
		if ( $INC{'MooX/StrictConstructor/Role/Constructor/Late.pm'} ) {
			require Role::Tiny;
			require Method::Generate::Constructor;
			my $trait = 'MooX::StrictConstructor::Role::Constructor::Late';
			push @allowed_constructor_makers, map {
				Role::Tiny->create_class_with_roles( $_, $trait );
			} @allowed_constructor_makers;
		}

		my $maker_class = ref $constructor_maker;
		return unless grep { $maker_class eq $_ } @allowed_constructor_makers;
	};

	# Preliminary sanity check for accessor maker, because it is
	# used by the constructor genmerator to generate attribute set
	# statements. Just check it's theoretically sound here, but we
	# still need to check it for each attribute.
	my $accessor_maker = Moo->_accessor_maker_for( $klass );
	do {
		my $generated = $accessor_maker->_generate_core_set( q{$XXX}, 'yyy', {}, q{"zzz"} );
		my $expected  = q{$XXX->{"yyy"} = "zzz"};
		return if $generated ne $expected;
	};

	# Loop through attributes...
	my %spec = %{ $constructor_maker->all_attribute_specs };
	my @attributes = sort { $spec{$a}{index} <=> $spec{$b}{index} } keys %spec;
	for my $attr (@attributes) {
		# Check they don't have any options we don't understand.
		if (my @unsafe = grep { $_ !~ $safe_spec } keys %{ $spec{$attr} }) {
			return;
		}

		# Check that the accessor maker generates a predictable
		# attribute set statement for this attribute.
		require B;
		my $generated = $accessor_maker->_generate_core_set( q{$XXX}, $attr, $spec{$attr}, q{"zzz"} );
		my $expected  = sprintf q{$XXX->{%s} = "zzz"}, B::perlstring($attr);
		return if $generated ne $expected;
	}

	# If we got this far, we're good.
	return "yay!";
}

# Called by the import method.
sub setup_for {
	my ( $self, $klass ) = @_;

	return unless $self->is_suitable_class( $klass );

	# Get attribute specs
	my $maker = Moo->_constructor_maker_for( $klass );
	my %spec  = %{ $maker->all_attribute_specs };

	# Transform it into arguments which XSCON can handle
	my @args =
		map {
			my $slot = $_;
			my %xs_spec = %{ $spec{$slot} };
			for my $k ( keys %xs_spec ) {
				delete $xs_spec{$k} if $k =~ $delete_from_spec;
			}
			if ( $xs_spec{lazy} ) {
				delete $xs_spec{$_} for qw/ lazy builder default /;
			}
			( $slot => \%xs_spec );
		}
		sort { $spec{$a}{index} <=> $spec{$b}{index} }
		keys %spec;

	$maker->DOES( 'MooX::StrictConstructor::Role::Constructor::Late' )
		and push @args, '!!';

	# Keep track of old constructor, just in case.
	my $old = $klass->can( 'new' );

	# Call XSCON to replace the existing constructor method
	my $ok = eval {
		require Class::XSConstructor;
		Class::XSConstructor->VERSION( 0.018001 );
		local $Class::XSConstructor::REDEFINE = !!1;
		Class::XSConstructor->import( [ $klass, 'new' ], @args );
		1;
	};


	if ( $ok and my $meta = Class::XSConstructor::get_metadata( $klass ) ) {
		if ( defined $meta->{foreignclass}
		and ( $meta->{foreignclass} eq 'Moo::Object' or $self->is_suitable_class( $meta->{foreignclass} ) ) ) {
			delete $meta->{$_} for qw/
				foreignbuildall
				foreignconstructor
				foreignclass
				foreignbuildargs
			/;
		}
		if ( $meta->{buildargs} and $meta->{buildargs} == \&Moo::Object::BUILDARGS ) {
			$meta->{has_standard_buildargs} = !!1;
			delete $meta->{buildargs};
		}
		$klass->XSCON_CLEAR_CONSTRUCTOR_CACHE;
	}
	else {
		# If there was a failure, restore old constructor.
		no strict 'refs';
		no warnings 'redefine';
		*{"${klass}::new"} = $old;
		return;
	}

	if ( $klass->can('DEMOLISH') ) {
		require Class::XSDestructor;
		local $Class::XSDestructor::REDEFINE = !!1;
		Class::XSDestructor->import( [ $klass, 'DESTROY' ] );
	}

	return $klass;
}

sub import {
	my $self = shift;
	my $caller = caller;
	if ( @_ and $_[0] eq '-wrapconstructor' ) {
		after_runtime {
			install_modifier $caller => around => new => sub {
				my $pp_constructor = shift;
				my $object = $pp_constructor->( @_ );
				$self->setup_for( $caller );
				return $object;
			};
		};
	}
	else {
		after_runtime {
			$self->setup_for( $caller )
		};
	}
}

sub is_xs  {
	require B;
	!! B::svref_2object( shift )->XSUB;
}

__PACKAGE__
__END__