goto $handler;
}
+sub _inline_throw_error {
+ my ( $self, $msg, $args ) = @_;
+ "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard
+}
+
sub new {
my ($class, $name, %options) = @_;
$class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
}
}
+sub _inline_set_value {
+ my $self = shift;
+ my ($instance, $value) = @_;
+
+ my $old = '@old';
+ my $copy = '$val';
+
+ my @code;
+ if ($self->_writer_value_needs_copy) {
+ push @code, $self->_inline_copy_value($value, $copy);
+ $value = $copy;
+ }
+
+ 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),
+ );
+
+ return @code;
+}
+
+sub _writer_value_needs_copy {
+ my $self = shift;
+ return $self->should_coerce;
+}
+
+sub _inline_copy_value {
+ my $self = shift;
+ my ($value, $copy) = @_;
+
+ return 'my ' . $copy . ' = ' . $value . ';'
+}
+
+sub _inline_check_required {
+ my $self = shift;
+
+ return unless $self->is_required;
+
+ my $attr_name = quotemeta($self->name);
+
+ return (
+ 'if (@_ < 2) {',
+ $self->_inline_throw_error(
+ '"Attribute (' . $attr_name . ') is required, so cannot '
+ . 'be set to undef"' # defined $_[1] is not good enough
+ ) . ';',
+ '}',
+ );
+}
+
+sub _inline_tc_code {
+ my $self = shift;
+ return (
+ $self->_inline_check_coercion(@_),
+ $self->_inline_check_constraint(@_),
+ );
+}
+
+sub _inline_check_coercion {
+ my $self = shift;
+ my ($value) = @_;
+
+ return unless $self->should_coerce && $self->type_constraint->has_coercion;
+
+ return $value . ' = $type_constraint_obj->coerce(' . $value . ');';
+}
+
+sub _inline_check_constraint {
+ my $self = shift;
+ my ($value) = @_;
+
+ return unless $self->has_type_constraint;
+
+ my $attr_name = quotemeta($self->name);
+
+ return (
+ 'if (!$type_constraint->(' . $value . ')) {',
+ $self->_inline_throw_error(
+ '"Attribute (' . $attr_name . ') does not pass the type '
+ . 'constraint because: " . '
+ . '$type_constraint_obj->get_message(' . $value . ')',
+ 'data => ' . $value
+ ) . ';',
+ '}',
+ );
+}
+
+sub _inline_get_old_value_for_trigger {
+ my $self = shift;
+ my ($instance, $old) = @_;
+
+ return unless $self->has_trigger;
+
+ return (
+ 'my ' . $old . ' = ' . $self->_inline_instance_has($instance),
+ '? ' . $self->_inline_instance_get($instance),
+ ': ();',
+ );
+}
+
+sub _inline_weaken_value {
+ my $self = shift;
+ my ($instance, $value) = @_;
+
+ return unless $self->is_weak_ref;
+
+ my $mi = $self->associated_class->get_meta_instance;
+ return (
+ $mi->inline_weaken_slot_value($instance, $self->name, $value),
+ 'if ref ' . $value . ';',
+ );
+}
+
+sub _inline_trigger {
+ my $self = shift;
+ my ($instance, $value, $old) = @_;
+
+ return unless $self->has_trigger;
+
+ return '$attr->trigger->(' . $instance . ', ' . $value . ', ' . $old . ');';
+}
+
sub _weaken_value {
my ( $self, $instance ) = @_;
}
}
+sub _inline_get_value {
+ my $self = shift;
+ my ($instance) = @_;
+
+ my $slot_access = $self->_inline_instance_get($instance);
+
+ return (
+ $self->_inline_check_lazy($instance),
+ $self->_inline_return_auto_deref($slot_access),
+ );
+}
+
+sub _inline_check_lazy {
+ my $self = shift;
+ my ($instance, $default) = @_;
+
+ return unless $self->is_lazy;
+
+ my $slot_exists = $self->_inline_instance_has($instance);
+
+ return (
+ 'if (!' . $slot_exists . ') {',
+ $self->_inline_init_from_default($instance, '$default', 'lazy'),
+ '}',
+ );
+}
+
+sub _inline_init_from_default {
+ my $self = shift;
+ my ($instance, $default, $for_lazy) = @_;
+
+ if (!($self->has_default || $self->has_builder)) {
+ $self->throw_error(
+ 'You cannot have a lazy attribute '
+ . '(' . $self->name . ') '
+ . 'without specifying a default value for it',
+ attr => $self,
+ );
+ }
+
+ return (
+ $self->_inline_generate_default($instance, $default),
+ # intentionally not using _inline_tc_code, since that can be overridden
+ # 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_init_slot($instance, $default),
+ );
+}
+
+sub _inline_generate_default {
+ my $self = shift;
+ my ($instance, $default) = @_;
+
+ if ($self->has_default) {
+ return 'my ' . $default . ' = $attr->default(' . $instance . ');';
+ }
+ elsif ($self->has_builder) {
+ return (
+ 'my ' . $default . ';',
+ 'if (my $builder = ' . $instance . '->can($attr->builder)) {',
+ $default . ' = ' . $instance . '->$builder;',
+ '}',
+ 'else {',
+ 'my $class = ref(' . $instance . ') || ' . $instance . ';',
+ 'my $builder_name = $attr->builder;',
+ 'my $attr_name = $attr->name;',
+ $self->_inline_throw_error(
+ '"$class does not support builder method '
+ . '\'$builder_name\' for attribute \'$attr_name\'"'
+ ) . ';',
+ '}',
+ );
+ }
+ else {
+ $self->throw_error(
+ "Can't generate a default for " . $self->name
+ . " since no default or builder was specified"
+ );
+ }
+}
+
+sub _inline_init_slot {
+ my $self = shift;
+ my ($inv, $value) = @_;
+
+ if ($self->has_initializer) {
+ return '$attr->set_initial_value(' . $inv . ', ' . $value . ');';
+ }
+ else {
+ return $self->_inline_instance_set($inv, $value) . ';';
+ }
+}
+
+sub _inline_return_auto_deref {
+ my $self = shift;
+
+ return 'return ' . $self->_auto_deref(@_) . ';';
+}
+
+sub _auto_deref {
+ my $self = shift;
+ my ($ref_value) = @_;
+
+ return $ref_value unless $self->should_auto_deref;
+
+ my $type_constraint = $self->type_constraint;
+
+ my $sigil;
+ if ($type_constraint->is_a_type_of('ArrayRef')) {
+ $sigil = '@';
+ }
+ elsif ($type_constraint->is_a_type_of('HashRef')) {
+ $sigil = '%';
+ }
+ else {
+ $self->throw_error(
+ 'Can not auto de-reference the type constraint \''
+ . $type_constraint->name
+ . '\'',
+ type_constraint => $type_constraint,
+ );
+ }
+
+ return 'wantarray '
+ . '? ' . $sigil . '{ (' . $ref_value . ') || return } '
+ . ': (' . $ref_value . ')';
+}
+
## installing accessors
sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
return;
}
-sub _inline_set_value {
- my $self = shift;
- my ($instance, $value) = @_;
-
- my $mi = $self->associated_class->get_meta_instance;
-
- my @code = ($self->SUPER::_inline_set_value(@_));
-
- push @code, (
- $mi->inline_weaken_slot_value($instance, $self->name, $value),
- 'if ref ' . $value . ';',
- ) if $self->is_weak_ref;
-
- return @code;
-}
-
sub install_delegation {
my $self = shift;
};
}
-sub _generate_accessor_method_inline {
- my $self = shift;
-
- my $inv = '$_[0]';
- my $slot_access = $self->_get_value($inv);
- my $value = $self->_value_needs_copy ? '$val' : '$_[1]';
- my $old = '@old';
-
- $self->_compile_code([
- 'sub {',
- $self->_inline_pre_body(@_),
- 'if (scalar(@_) >= 2) {',
- $self->_inline_copy_value($value),
- $self->_inline_check_required,
- $self->_inline_tc_code($value),
- $self->_inline_get_old_value_for_trigger($inv, $old),
- $self->_inline_store_value($inv, $value),
- $self->_inline_trigger($inv, $value, $old),
- '}',
- $self->_inline_check_lazy($inv),
- $self->_inline_post_body(@_),
- $self->_inline_return_auto_deref($slot_access),
- '}',
- ]);
-}
-
-sub _generate_writer_method_inline {
- my $self = shift;
-
- my $inv = '$_[0]';
- my $value = $self->_value_needs_copy ? '$val' : '$_[1]';
- my $old = '@old';
-
- $self->_compile_code([
- 'sub {',
- $self->_inline_pre_body(@_),
- $self->_inline_copy_value($value),
- $self->_inline_check_required,
- $self->_inline_tc_code($value),
- $self->_inline_get_old_value_for_trigger($inv, $old),
- $self->_inline_store_value($inv, $value),
- $self->_inline_post_body(@_),
- $self->_inline_trigger($inv, $value, $old),
- '}',
- ]);
-}
-
-sub _generate_reader_method_inline {
- my $self = shift;
-
- my $inv = '$_[0]';
- my $slot_access = $self->_get_value($inv);
-
- $self->_compile_code([
- 'sub {',
- $self->_inline_pre_body(@_),
- 'if (@_ > 1) {',
- $self->_inline_throw_error(
- '"Cannot assign a value to a read-only accessor"',
- 'data => \@_'
- ) . ';',
- '}',
- $self->_inline_check_lazy($inv),
- $self->_inline_post_body(@_),
- $self->_inline_return_auto_deref($slot_access),
- '}',
- ]);
-}
-
-sub _inline_copy_value {
- my $self = shift;
- my ($value) = @_;
-
- return unless $self->_value_needs_copy;
- return 'my ' . $value . ' = $_[1];'
-}
-
-sub _value_needs_copy {
- my $self = shift;
- return $self->associated_attribute->should_coerce;
-}
-
sub _instance_is_inlinable {
my $self = shift;
return $self->associated_attribute->associated_class->instance_metaclass->is_inlinable;
: $self->SUPER::_generate_clearer_method(@_);
}
-sub _inline_pre_body { return }
-sub _inline_post_body { return }
+sub _writer_value_needs_copy {
+ shift->associated_attribute->_writer_value_needs_copy(@_);
+}
sub _inline_tc_code {
- my $self = shift;
- return (
- $self->_inline_check_coercion(@_),
- $self->_inline_check_constraint(@_),
- );
+ shift->associated_attribute->_inline_tc_code(@_);
}
sub _inline_check_constraint {
- my $self = shift;
- my ($value) = @_;
-
- my $attr = $self->associated_attribute;
- return unless $attr->has_type_constraint;
-
- my $attr_name = quotemeta($attr->name);
-
- return (
- 'if (!$type_constraint->(' . $value . ')) {',
- $self->_inline_throw_error(
- '"Attribute (' . $attr_name . ') does not pass the type '
- . 'constraint because: " . '
- . '$type_constraint_obj->get_message(' . $value . ')',
- 'data => ' . $value
- ) . ';',
- '}',
- );
-}
-
-sub _inline_check_coercion {
- my $self = shift;
- my ($value) = @_;
-
- my $attr = $self->associated_attribute;
- return unless $attr->should_coerce && $attr->type_constraint->has_coercion;
-
- return $value . ' = $type_constraint_obj->coerce(' . $value . ');';
-}
-
-sub _inline_check_required {
- my $self = shift;
-
- my $attr = $self->associated_attribute;
- return unless $attr->is_required;
-
- my $attr_name = quotemeta($attr->name);
-
- return (
- 'if (@_ < 2) {',
- $self->_inline_throw_error(
- '"Attribute (' . $attr_name . ') is required, so cannot '
- . 'be set to undef"' # defined $_[1] is not good enough
- ) . ';',
- '}',
- );
+ shift->associated_attribute->_inline_check_constraint(@_);
}
sub _inline_check_lazy {
- my $self = shift;
- my ($instance, $default) = @_;
-
- my $attr = $self->associated_attribute;
- return unless $attr->is_lazy;
-
- my $slot_exists = $self->_has_value($instance);
-
- return (
- 'if (!' . $slot_exists . ') {',
- $self->_inline_init_from_default($instance, '$default', 'lazy'),
- '}',
- );
-}
-
-sub _inline_init_from_default {
- my $self = shift;
- my ($instance, $default, $for_lazy) = @_;
-
- my $attr = $self->associated_attribute;
-
- if (!($attr->has_default || $attr->has_builder)) {
- $self->throw_error(
- 'You cannot have a lazy attribute '
- . '(' . $attr->name . ') '
- . 'without specifying a default value for it',
- attr => $attr,
- );
- }
-
- return (
- $self->_inline_generate_default($instance, $default),
- # intentionally not using _inline_tc_code, since that can be overridden
- # to do things like possibly only do member tc checks, which isn't
- # appropriate for checking the result of a default
- $attr->has_type_constraint
- ? ($self->_inline_check_coercion($default, $for_lazy),
- $self->_inline_check_constraint($default, $for_lazy))
- : (),
- $self->_inline_init_slot($attr, $instance, $default),
- );
-}
-
-sub _inline_generate_default {
- my $self = shift;
- my ($instance, $default) = @_;
-
- my $attr = $self->associated_attribute;
-
- if ($attr->has_default) {
- return 'my ' . $default . ' = $attr->default(' . $instance . ');';
- }
- elsif ($attr->has_builder) {
- return (
- 'my ' . $default . ';',
- 'if (my $builder = ' . $instance . '->can($attr->builder)) {',
- $default . ' = ' . $instance . '->$builder;',
- '}',
- 'else {',
- 'my $class = ref(' . $instance . ') || ' . $instance . ';',
- 'my $builder_name = $attr->builder;',
- 'my $attr_name = $attr->name;',
- $self->_inline_throw_error(
- '"$class does not support builder method '
- . '\'$builder_name\' for attribute \'$attr_name\'"'
- ) . ';',
- '}',
- );
- }
- else {
- $self->throw_error(
- "Can't generate a default for " . $attr->name
- . " since no default or builder was specified"
- );
- }
-}
-
-sub _inline_init_slot {
- my $self = shift;
- my ($attr, $inv, $value) = @_;
-
- if ($attr->has_initializer) {
- return '$attr->set_initial_value(' . $inv . ', ' . $value . ');';
- }
- else {
- return $self->_inline_store_value($inv, $value);
- }
+ shift->associated_attribute->_inline_check_lazy(@_);
}
sub _inline_store_value {
- my $self = shift;
- my ($inv, $value) = @_;
-
- return $self->associated_attribute->_inline_set_value($inv, $value);
+ shift->associated_attribute->_inline_instance_set(@_) . ';';
}
sub _inline_get_old_value_for_trigger {
- my $self = shift;
- my ($instance, $old) = @_;
-
- my $attr = $self->associated_attribute;
- return unless $attr->has_trigger;
-
- return (
- 'my ' . $old . ' = ' . $self->_has_value($instance),
- '? ' . $self->_get_value($instance),
- ': ();',
- );
+ shift->associated_attribute->_inline_get_old_value_for_trigger(@_);
}
sub _inline_trigger {
- my $self = shift;
- my ($instance, $value, $old) = @_;
-
- my $attr = $self->associated_attribute;
- return unless $attr->has_trigger;
-
- return '$attr->trigger->(' . $instance . ', ' . $value . ', ' . $old . ');';
-}
-
-sub _inline_return_auto_deref {
- my $self = shift;
-
- return 'return ' . $self->_auto_deref(@_) . ';';
+ shift->associated_attribute->_inline_trigger(@_);
}
-# expressions
-
sub _get_value {
- my ($self, $instance) = @_;
-
- return $self->associated_attribute->_inline_instance_get($instance);
+ shift->associated_attribute->_inline_instance_get(@_);
}
sub _has_value {
- my ($self, $instance) = @_;
-
- return $self->associated_attribute->_inline_instance_has($instance);
-}
-
-sub _auto_deref {
- my $self = shift;
- my ($ref_value) = @_;
-
- my $attr = $self->associated_attribute;
- return $ref_value unless $attr->should_auto_deref;
-
- my $type_constraint = $attr->type_constraint;
-
- my $sigil;
- if ($type_constraint->is_a_type_of('ArrayRef')) {
- $sigil = '@';
- }
- elsif ($type_constraint->is_a_type_of('HashRef')) {
- $sigil = '%';
- }
- else {
- $self->throw_error(
- 'Can not auto de-reference the type constraint \''
- . $type_constraint->name
- . '\'',
- type_constraint => $type_constraint,
- );
- }
-
- return 'wantarray '
- . '? ' . $sigil . '{ (' . $ref_value . ') || return } '
- . ': (' . $ref_value . ')';
+ shift->associated_attribute->_inline_instance_has(@_);
}
1;
return (
'sub {',
- $self->_inline_pre_body(@_),
'my ' . $inv . ' = shift;',
$self->_inline_curried_arguments,
$self->_inline_check_lazy($inv),
# set
'else {',
$self->_inline_writer_core($inv, $slot_access),
- $self->_inline_post_body(@_),
'}',
'}',
);
return;
}
-sub _value_needs_copy {
+sub _writer_value_needs_copy {
my $self = shift;
return $self->_constraint_must_be_checked
return (
'sub {',
- $self->_inline_pre_body(@_),
'my ' . $inv . ' = shift;',
$self->_inline_curried_arguments,
$self->_inline_check_lazy($inv),
# set
'else {',
$self->_inline_writer_core($inv, $slot_access),
- $self->_inline_post_body(@_),
'}',
'}',
);
return (
'sub {',
- $self->_inline_pre_body(@_),
'my ' . $inv . ' = shift;',
$self->_inline_curried_arguments,
$self->_inline_reader_core($inv, $slot_access, @_),
$self->_inline_process_arguments($inv, $slot_access),
$self->_inline_check_arguments,
$self->_inline_check_lazy($inv),
- $self->_inline_post_body(@extra),
$self->_inline_return_value($slot_access),
);
}
return (
'sub {',
- $self->_inline_pre_body(@_),
'my ' . $inv . ' = shift;',
$self->_inline_curried_arguments,
'if (@_ == 1 || @_ == 2) {',
'}',
'elsif (@_ == 3) {',
$self->_inline_writer_core($inv, $slot_access),
- $self->_inline_post_body(@_),
'}',
'else {',
$self->_inline_check_argument_count,
return (
'sub {',
- $self->_inline_pre_body(@_),
'my ' . $inv . ' = shift;',
$self->_inline_curried_arguments,
$self->_inline_writer_core($inv, $slot_access),
- $self->_inline_post_body(@_),
'}',
);
}
sub _inline_coerce_new_values { return }
-sub _value_needs_copy {
+sub _writer_value_needs_copy {
my $self = shift;
return $self->_constraint_must_be_checked;
my $self = shift;
my ($potential_ref) = @_;
- return unless $self->_value_needs_copy;
+ return unless $self->_writer_value_needs_copy;
my $code = 'my $potential = ' . ${$potential_ref} . ';';
my $self = shift;
return $self->_inline_store_value(@_)
- if $self->_value_needs_copy
+ if $self->_writer_value_needs_copy
|| !$self->_slot_access_can_be_inlined
|| !$self->_get_is_lvalue;
}
else {
push @source, (
- $attr->_inline_set_value('$instance', $value),
+ $attr->_inline_instance_set('$instance', $value) . ';',
);
}
projects / gitmo/Moose.git / commitdiff