sub _inline_set_value {
my $self = shift;
- my ($instance, $value) = @_;
+ my ($instance, $value, $tc, $tc_obj, $for_constructor) = @_;
- my $old = '@old';
- my $copy = '$val';
+ my $old = '@old';
+ my $copy = '$val';
+ $tc ||= '$type_constraint';
+ $tc_obj ||= '$type_constraint_obj';
my @code;
if ($self->_writer_value_needs_copy) {
$value = $copy;
}
+ # constructors already handle required checks
+ push @code, $self->_inline_check_required
+ unless $for_constructor;
+
+ push @code, $self->_inline_tc_code($value, $tc, $tc_obj);
+
+ # constructors do triggers all at once at the end
+ push @code, $self->_inline_get_old_value_for_trigger($instance, $old)
+ unless $for_constructor;
+
push @code, (
- $self->_inline_check_required,
- $self->_inline_tc_code($value),
- $self->_inline_get_old_value_for_trigger($instance, $old),
$self->SUPER::_inline_set_value($instance, $value),
$self->_inline_weaken_value($instance, $value),
- $self->_inline_trigger($instance, $value, $old),
);
+ # constructors do triggers all at once at the end
+ push @code, $self->_inline_trigger($instance, $value, $old)
+ unless $for_constructor;
+
return @code;
}
sub _inline_check_coercion {
my $self = shift;
- my ($value) = @_;
+ my ($value, $tc, $tc_obj) = @_;
return unless $self->should_coerce && $self->type_constraint->has_coercion;
- return $value . ' = $type_constraint_obj->coerce(' . $value . ');';
+ return $value . ' = ' . $tc_obj . '->coerce(' . $value . ');';
}
sub _inline_check_constraint {
my $self = shift;
- my ($value) = @_;
+ my ($value, $tc, $tc_obj) = @_;
return unless $self->has_type_constraint;
my $attr_name = quotemeta($self->name);
return (
- 'if (!$type_constraint->(' . $value . ')) {',
+ 'if (!' . $tc . '->(' . $value . ')) {',
$self->_inline_throw_error(
'"Attribute (' . $attr_name . ') does not pass the type '
. 'constraint because: " . '
- . '$type_constraint_obj->get_message(' . $value . ')',
+ . $tc_obj . '->get_message(' . $value . ')',
'data => ' . $value
) . ';',
'}',
sub _inline_get_value {
my $self = shift;
- my ($instance) = @_;
+ my ($instance, $tc, $tc_obj) = @_;
my $slot_access = $self->_inline_instance_get($instance);
+ $tc ||= '$type_constraint';
+ $tc_obj ||= '$type_constraint_obj';
return (
- $self->_inline_check_lazy($instance),
+ $self->_inline_check_lazy($instance, $tc, $tc_obj),
$self->_inline_return_auto_deref($slot_access),
);
}
sub _inline_check_lazy {
my $self = shift;
- my ($instance, $default) = @_;
+ my ($instance, $tc, $tc_obj) = @_;
return unless $self->is_lazy;
return (
'if (!' . $slot_exists . ') {',
- $self->_inline_init_from_default($instance, '$default', 'lazy'),
+ $self->_inline_init_from_default($instance, '$default', $tc, $tc_obj, 'lazy'),
'}',
);
}
sub _inline_init_from_default {
my $self = shift;
- my ($instance, $default, $for_lazy) = @_;
+ my ($instance, $default, $tc, $tc_obj, $for_lazy) = @_;
if (!($self->has_default || $self->has_builder)) {
$self->throw_error(
# to do things like possibly only do member tc checks, which isn't
# appropriate for checking the result of a default
$self->has_type_constraint
- ? ($self->_inline_check_coercion($default, $for_lazy),
- $self->_inline_check_constraint($default, $for_lazy))
+ ? ($self->_inline_check_coercion($default, $tc, $tc_obj, $for_lazy),
+ $self->_inline_check_constraint($default, $tc, $tc_obj, $for_lazy))
: (),
$self->_inline_init_slot($instance, $default),
);
sub _inline_slot_initializer {
my $self = shift;
- my ($attr, $index) = @_;
+ my ($attr, $idx) = @_;
- my @source = ('## ' . $attr->name);
-
- push @source, $self->_inline_check_required_attr($attr);
-
- if (defined $attr->init_arg) {
- push @source,
- 'if (exists $params->{\'' . $attr->init_arg . '\'}) {',
- $self->_inline_init_attr_from_constructor($attr, $index),
- '}';
- if (my @default = $self->_inline_init_attr_from_default($attr, $index)) {
- push @source,
- 'else {',
- @default,
- '}';
- }
- }
- else {
- if (my @default = $self->_inline_init_attr_from_default($attr, $index)) {
- push @source,
- '{', # _init_attr_from_default creates variables
- @default,
- '}';
- }
- }
-
- return @source;
+ return (
+ '## ' . $attr->name,
+ $self->_inline_check_required_attr($attr),
+ $self->SUPER::_inline_slot_initializer(@_),
+ );
}
sub _inline_check_required_attr {
sub _inline_init_attr_from_constructor {
my $self = shift;
- my ($attr, $index) = @_;
-
- return (
- 'my $val = $params->{\'' . $attr->init_arg . '\'};',
- $self->_inline_slot_assignment($attr, $index, '$val'),
+ my ($attr, $idx) = @_;
+
+ my @initial_value = $attr->_inline_set_value(
+ '$instance',
+ '$params->{\'' . $attr->init_arg . '\'}',
+ '$type_constraint_bodies[' . $idx . ']',
+ '$type_constraints[' . $idx . ']',
+ 'for constructor',
);
-}
-
-sub _inline_init_attr_from_default {
- my $self = shift;
- my ($attr, $index) = @_;
- my $default = $self->_inline_default_value($attr, $index);
- return unless $default;
+ push @initial_value, (
+ '$attrs->[' . $idx . ']->set_initial_value(',
+ '$instance,',
+ $attr->_inline_instance_get('$instance'),
+ ');',
+ ) if $attr->has_initializer;
- return (
- 'my $val = ' . $default . ';',
- $self->_inline_slot_assignment($attr, $index, '$val'),
- );
+ return @initial_value;
}
-sub _inline_slot_assignment {
- my $self = shift;
- my ($attr, $index, $value) = @_;
-
- my @source;
-
- push @source, $self->_inline_type_constraint_and_coercion(
- $attr, $index, $value,
- );
-
- if ($attr->has_initializer) {
- push @source, (
- '$attrs->[' . $index . ']->set_initial_value(',
- '$instance' . ',',
- $value . ',',
- ');'
- );
- }
- else {
- push @source, (
- $attr->_inline_instance_set('$instance', $value) . ';',
- );
- }
-
- return @source;
-}
-
-sub _inline_type_constraint_and_coercion {
+sub _inline_init_attr_from_default {
my $self = shift;
- my ($attr, $index, $value) = @_;
-
- return unless $attr->can('has_type_constraint')
- && $attr->has_type_constraint;
-
- my @source;
+ my ($attr, $idx) = @_;
- if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
- push @source => $self->_inline_type_coercion(
- '$type_constraints[' . $index . ']',
- $value,
- $value,
- );
- }
+ my $default = $self->_inline_default_value($attr, $idx);
+ return unless $default;
- push @source => $self->_inline_type_constraint_check(
- $attr,
- '$type_constraint_bodies[' . $index . ']',
- '$type_constraints[' . $index . ']',
- $value,
+ my @initial_value = (
+ 'my $default = ' . $default . ';',
+ $attr->_inline_set_value(
+ '$instance',
+ '$default',
+ '$type_constraint_bodies[' . $idx . ']',
+ '$type_constraints[' . $idx . ']',
+ 'for constructor',
+ ),
);
- return @source;
-}
-
-sub _inline_type_coercion {
- my $self = shift;
- my ($tc_obj, $value, $return_value) = @_;
- return $return_value . ' = ' . $tc_obj . '->coerce(' . $value . ');';
-}
+ push @initial_value, (
+ '$attrs->[' . $idx . ']->set_initial_value(',
+ '$instance,',
+ $attr->_inline_instance_get('$instance'),
+ ');',
+ ) if $attr->has_initializer;
-sub _inline_type_constraint_check {
- my $self = shift;
- my ($attr, $tc_body, $tc_obj, $value) = @_;
- return (
- $self->_inline_throw_error(
- '"Attribute (' . quotemeta($attr->name) . ') '
- . 'does not pass the type constraint because: " . '
- . $tc_obj . '->get_message(' . $value . ')'
- ),
- 'unless ' . $tc_body . '->(' . $value . ');'
- );
+ return @initial_value;
}
sub _inline_extra_init {
my $self = shift;
my @trigger_calls;
- my @attrs = $self->get_all_attributes;
+ my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes;
for my $i (0 .. $#attrs) {
my $attr = $attrs[$i];
'sub {',
'my ' . $inv . ' = shift;',
$self->_inline_curried_arguments,
- $self->_inline_check_lazy($inv),
+ $self->_inline_check_lazy($inv, '$type_constraint', '$type_constraint_obj'),
# get
'if (@_ == 1) {',
$self->_inline_check_var_is_valid_index('$_[0]'),
sub _inline_tc_code {
my $self = shift;
- my ($potential_value) = @_;
return unless $self->_constraint_must_be_checked;
}
else {
return (
- $self->_inline_check_coercion($potential_value),
- $self->_inline_check_constraint($potential_value),
+ $self->_inline_check_coercion(@_),
+ $self->_inline_check_constraint(@_),
);
}
}
'sub {',
'my ' . $inv . ' = shift;',
$self->_inline_curried_arguments,
- $self->_inline_check_lazy($inv),
+ $self->_inline_check_lazy($inv, '$type_constraint', '$type_constraint_obj'),
# get
'if (@_ == 1) {',
$self->_inline_check_var_is_valid_key('$_[0]'),
$self->_inline_check_argument_count,
$self->_inline_process_arguments($inv, $slot_access),
$self->_inline_check_arguments,
- $self->_inline_check_lazy($inv),
+ $self->_inline_check_lazy($inv, '$type_constraint', '$type_constraint_obj'),
$self->_inline_return_value($slot_access),
);
}
$self->_inline_check_argument_count,
$self->_inline_process_arguments($inv, $slot_access),
$self->_inline_check_arguments('for writer'),
- $self->_inline_check_lazy($inv),
+ $self->_inline_check_lazy($inv, '$type_constraint', '$type_constraint_obj'),
);
if ($self->_return_value($slot_access)) {
push @code, (
$self->_inline_coerce_new_values,
$self->_inline_copy_native_value(\$potential),
- $self->_inline_tc_code($potential),
+ $self->_inline_tc_code($potential, '$type_constraint', '$type_constraint_obj'),
$self->_inline_get_old_value_for_trigger($inv, $old),
$self->_inline_capture_return_value($slot_access),
$self->_inline_set_new_value($inv, $potential, $slot_access),
around _inline_tc_code => sub {
my $orig = shift;
my $self = shift;
- my ($value, $for_lazy) = @_;
+ my ($value, $tc, $tc_obj, $for_lazy) = @_;
return unless $for_lazy || $self->_constraint_must_be_checked;
sub _inline_check_coercion {
my $self = shift;
- my ($value) = @_;
+ my ($value, $tc, $tc_obj) = @_;
my $attr = $self->associated_attribute;
return unless $attr->should_coerce && $attr->type_constraint->has_coercion;
# We want to break the aliasing in @_ in case the coercion tries to make a
# destructive change to an array member.
- return $value . ' = $type_constraint_obj->coerce(' . $value . ');';
+ return $value . ' = ' . $tc_obj . '->coerce(' . $value . ');';
}
around _inline_check_constraint => sub {
my $orig = shift;
my $self = shift;
- my ($value, $for_lazy) = @_;
+ my ($value, $tc, $tc_obj, $for_lazy) = @_;
return unless $for_lazy || $self->_constraint_must_be_checked;
projects / gitmo/Moose.git / commitdiff