use Try::Tiny;
-our $VERSION = '1.19';
-$VERSION = eval $VERSION;
-our $AUTHORITY = 'cpan:STEVAN';
-
use base 'Moose::Meta::Method',
'Class::MOP::Method::Accessor';
sub _eval_environment {
my $self = shift;
- my $attr = $self->associated_attribute;
- my $type_constraint_obj = $attr->type_constraint;
-
- return {
- '$attr' => \$attr,
- '$meta' => \$self,
- '$type_constraint_obj' => \$type_constraint_obj,
- '$type_constraint' => \(
- $type_constraint_obj
- ? $type_constraint_obj->_compiled_type_constraint
- : undef
- ),
- };
-}
+ my $env = { };
-sub _generate_accessor_method_inline {
- my $self = shift;
-
- my $inv = '$_[0]';
- my $slot_access = $self->_inline_get($inv);
- my $value = $self->_value_needs_copy ? '$val' : '$_[1]';
- my $old = '@old';
- my $default = '$default';
-
- $self->_compile_code([
- 'sub {',
- $self->_inline_pre_body(@_),
- 'if (scalar(@_) >= 2) {',
- $self->_inline_copy_value($value),
- $self->_inline_check_required,
- $self->_inline_check_coercion($value),
- $self->_inline_check_constraint($value),
- $self->_inline_get_old_value_for_trigger($inv, $old),
- $self->_inline_store($inv, $value),
- $self->_inline_trigger($inv, $value, $old),
- '}',
- $self->_inline_check_lazy($inv, $default),
- $self->_inline_post_body(@_),
- 'return ' . $self->_inline_auto_deref($slot_access) . ';',
- '}',
- ]);
-}
+ my $attr = $self->associated_attribute;
-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_check_coercion($value),
- $self->_inline_check_constraint($value),
- $self->_inline_get_old_value_for_trigger($inv, $old),
- $self->_inline_store($inv, $value),
- $self->_inline_post_body(@_),
- $self->_inline_trigger($inv, $value, $old),
- '}',
- ]);
-}
+ $env->{'$trigger'} = \($attr->trigger)
+ if $attr->has_trigger;
+ $env->{'$default'} = \($attr->default)
+ if $attr->has_default;
-sub _generate_reader_method_inline {
- my $self = shift;
-
- my $inv = '$_[0]';
- my $slot_access = $self->_inline_get($inv);
- my $default = '$default';
-
- $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, $default),
- $self->_inline_post_body(@_),
- 'return ' . $self->_inline_auto_deref($slot_access) . ';',
- '}',
- ]);
-}
+ if ($attr->has_type_constraint) {
+ my $tc_obj = $attr->type_constraint;
-sub _inline_copy_value {
- my $self = shift;
- my ($value) = @_;
+ # is this going to be an issue? it's currently only used for the tc
+ # message. is there a way to inline that too?
+ $env->{'$type_constraint_obj'} = \$tc_obj;
- return '' unless $self->_value_needs_copy;
- return 'my ' . $value . ' = $_[1];'
-}
+ $env->{'$type_constraint'} = \(
+ $tc_obj->_compiled_type_constraint
+ ) unless $tc_obj->can_be_inlined;
+ $env->{'$type_coercion'} = \(
+ $tc_obj->coercion->_compiled_type_coercion
+ ) if $tc_obj->has_coercion;
-sub _value_needs_copy {
- my $self = shift;
- return $self->associated_attribute->should_coerce;
+ $env = { %$env, %{ $tc_obj->inline_environment } };
+ }
+
+ # XXX ugh, fix these
+ $env->{'$attr'} = \$attr
+ if $attr->has_initializer;
+ $env->{'$meta'} = \$self;
+
+ return $env;
}
sub _instance_is_inlinable {
: $self->SUPER::_generate_clearer_method(@_);
}
-sub _inline_pre_body { '' }
-sub _inline_post_body { '' }
-
-sub _inline_check_constraint {
- my $self = shift;
- my ($value) = @_;
+sub _writer_value_needs_copy {
+ shift->associated_attribute->_writer_value_needs_copy(@_);
+}
- 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_tc_code {
+ shift->associated_attribute->_inline_tc_code(@_);
}
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 . ');';
+ shift->associated_attribute->_inline_check_coercion(@_);
}
-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
- ) . ';',
- '}';
+sub _inline_check_constraint {
+ 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->_inline_has($instance);
-
- return 'if (!' . $slot_exists . ') {',
- $self->_inline_init_from_default($instance, $default),
- '}';
-}
-
-sub _inline_init_from_default {
- my $self = shift;
- my ($instance, $default) = @_;
-
- my $attr = $self->associated_attribute;
- # XXX: should this throw an error instead?
- return $self->_inline_init_slot($attr, $instance, 'undef')
- unless $attr->has_default || $attr->has_builder;
-
- return $self->_inline_generate_default($instance, $default),
- $attr->has_type_constraint
- ? ($self->_inline_check_coercion($default),
- $self->_inline_check_constraint($default))
- : (),
- $self->_inline_init_slot($attr, $instance, $default);
+ shift->associated_attribute->_inline_check_lazy(@_);
}
-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($inv, $value) . ';';
- }
-}
-
-sub _inline_store {
- my $self = shift;
- my ($instance, $value) = @_;
-
- return $self->associated_attribute->inline_set( $instance, $value ) . ';';
+sub _inline_store_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->_inline_has($instance)
- . ' ? ' . $self->_inline_get($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 sprintf('$attr->trigger->(%s, %s, %s);', $instance, $value, $old);
-}
-
-# expressions
-
-sub _inline_get {
- my ($self, $instance) = @_;
-
- return $self->associated_attribute->inline_get($instance);
+ shift->associated_attribute->_inline_trigger(@_);
}
-sub _inline_has {
- my ($self, $instance) = @_;
-
- return $self->associated_attribute->inline_has($instance);
+sub _get_value {
+ shift->associated_attribute->_inline_instance_get(@_);
}
-sub _inline_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,
- );
- }
-
- "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
+sub _has_value {
+ shift->associated_attribute->_inline_instance_has(@_);
}
1;
+# ABSTRACT: A Moose Method metaclass for accessors
+
__END__
=pod
-=head1 NAME
-
-Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors
-
=head1 DESCRIPTION
This class is a subclass of L<Class::MOP::Method::Accessor> that
See L<Moose/BUGS> for details on reporting bugs.
-=head1 AUTHOR
-
-Stevan Little E<lt>stevan@iinteractive.comE<gt>
-
-Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2006-2010 by Infinity Interactive, Inc.
-
-L<http://www.iinteractive.com>
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
=cut
projects / gitmo/Moose.git / blobdiff