use strict;
use warnings;
-our $VERSION = '1.17';
-$VERSION = eval $VERSION;
-our $AUTHORITY = 'cpan:STEVAN';
-
use Moose::Role;
requires qw( _adds_members );
-around _value_needs_copy => sub {
- shift;
+sub _inline_coerce_new_values {
+ my $self = shift;
+
+ return unless $self->associated_attribute->should_coerce;
+
+ return unless $self->_tc_member_type_can_coerce;
+
+ return (
+ '(' . $self->_new_members . ') = map { $member_coercion->($_) }',
+ $self->_new_members . ';',
+ );
+}
+
+sub _tc_member_type_can_coerce {
+ my $self = shift;
+
+ my $member_tc = $self->_tc_member_type;
+
+ return $member_tc && $member_tc->has_coercion;
+}
+
+sub _tc_member_type {
+ my $self = shift;
+
+ my $tc = $self->associated_attribute->type_constraint;
+ while ($tc) {
+ return $tc->type_parameter
+ if $tc->can('type_parameter');
+ $tc = $tc->parent;
+ }
+
+ return;
+}
+
+sub _writer_value_needs_copy {
my $self = shift;
return $self->_constraint_must_be_checked
&& !$self->_check_new_members_only;
-};
+}
-around _inline_tc_code => sub {
- shift;
- my ( $self, $potential_value ) = @_;
+sub _inline_tc_code {
+ my $self = shift;
+ my ($value, $tc, $coercion, $message, $is_lazy) = @_;
- return q{} unless $self->_constraint_must_be_checked;
+ return unless $self->_constraint_must_be_checked;
- if ( $self->_check_new_members_only ) {
- return q{} unless $self->_adds_members;
+ if ($self->_check_new_members_only) {
+ return unless $self->_adds_members;
- return $self->_inline_check_member_constraint( $self->_new_members );
+ return $self->_inline_check_member_constraint($self->_new_members);
}
else {
- return $self->_inline_check_coercion($potential_value) . "\n"
- . $self->_inline_check_constraint($potential_value);
+ return (
+ $self->_inline_check_coercion($value, $tc, $coercion, $is_lazy),
+ $self->_inline_check_constraint($value, $tc, $message, $is_lazy),
+ );
}
-};
+}
sub _check_new_members_only {
my $self = shift;
# constraint, so we need to check the whole value, not just the members.
return 1
if $self->_is_root_type( $tc->parent )
- && $tc->isa('Moose::Meta::TypeConstraint::Parameterized');
+ && ( $tc->isa('Moose::Meta::TypeConstraint::Parameterized')
+ || $tc->isa('Type::Constraint::Parameterized') );
return 0;
}
sub _inline_check_member_constraint {
- my ( $self, $new_value ) = @_;
+ my $self = shift;
+ my ($new_value) = @_;
my $attr_name = $self->associated_attribute->name;
- return '$member_tc->($_) || '
- . $self->_inline_throw_error(
- qq{"A new member value for '$attr_name' does not pass its type constraint because: "}
- . ' . $member_tc->get_message($_)',
- "data => \$_"
- ) . " for $new_value;";
+ my $check
+ = $self->_tc_member_type->can_be_inlined
+ ? '! (' . $self->_tc_member_type->_inline_check('$new_val') . ')'
+ : ' !$member_tc->($new_val) ';
+
+ return (
+ 'for my $new_val (' . $new_value . ') {',
+ "if ($check) {",
+ $self->_inline_throw_error(
+ '"A new member value for ' . $attr_name
+ . ' does not pass its type constraint because: "' . ' . '
+ . 'do { local $_ = $new_val; $member_message->($new_val) }',
+ 'data => $new_val',
+ ) . ';',
+ '}',
+ '}',
+ );
}
-around _inline_check_constraint => sub {
- my $orig = shift;
+sub _inline_get_old_value_for_trigger {
my $self = shift;
-
- return q{} unless $self->_constraint_must_be_checked;
-
- return $self->$orig( $_[0] );
-};
-
-around _inline_get_old_value_for_trigger => sub {
- shift;
- my ( $self, $instance ) = @_;
+ my ($instance, $old) = @_;
my $attr = $self->associated_attribute;
- return '' unless $attr->has_trigger;
+ return unless $attr->has_trigger;
- return
- 'my @old = '
- . $self->_inline_has($instance) . q{ ? }
- . $self->_inline_copy_old_value( $self->_inline_get($instance) )
- . ": ();\n";
-};
+ return (
+ 'my ' . $old . ' = ' . $self->_has_value($instance),
+ '? ' . $self->_copy_old_value($self->_get_value($instance)),
+ ': ();',
+ );
+}
around _eval_environment => sub {
my $orig = shift;
my $env = $self->$orig(@_);
- return $env
- unless $self->_constraint_must_be_checked
- && $self->_check_new_members_only;
+ my $member_tc = $self->_tc_member_type;
+
+ return $env unless $member_tc;
+
+ $env->{'$member_tc'} = \( $member_tc->_compiled_type_constraint );
+ $env->{'$member_coercion'} = \(
+ $member_tc->coercion->_compiled_type_coercion
+ ) if $member_tc->has_coercion;
+ $env->{'$member_message'} = \(
+ $member_tc->has_message
+ ? $member_tc->message
+ : $member_tc->_default_message
+ );
+
+ my $tc_env = $member_tc->inline_environment();
- $env->{'$member_tc'}
- = \( $self->associated_attribute->type_constraint->type_parameter
- ->_compiled_type_constraint );
+ $env = { %{$env}, %{$tc_env} };
return $env;
};