Extended the test suite to make sure the inlining works as well.
* Moose::Object now has stubs for BUILD and DEMOLISH, so they can be safely
wrapped in roles without needing to provide your own stubs. (doy)
+ * Moose::Meta::Method::Delegation
+ * Moose::Meta::Attribute
+ - Delegations are now inlined on make_immutable and have file/line set
+ to the point at which the delegation was defined. (pdcawley)
+
0.94 Mon, Jan 18, 2010
[API CHANGES]
sub install_accessors {
my $self = shift;
$self->SUPER::install_accessors(@_);
- $self->install_delegation if $self->has_handles;
+ $self->install_delegation(@_);
return;
}
sub install_delegation {
my $self = shift;
+ my $inline = shift;
+
+ return unless $self->has_handles;
# NOTE:
# Here we canonicalize the 'handles' option
my $class_name = $associated_class->name;
my $name = "${class_name}::${handle}";
- (!$associated_class->has_method($handle))
- || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
+ if ($associated_class->has_method($handle)) {
+ $self->throw_error(
+ "You cannot overwrite a locally defined method ($handle) with a delegation",
+ method_name => $handle
+ ) unless $inline;
+ }
# NOTE:
# handles is not allowed to delegate
#cluck("Not delegating method '$handle' because it is a core method") and
next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
- my $method = $self->_make_delegation_method($handle, $method_to_call);
+ my $method = $self->_make_delegation_method($handle, $method_to_call, $inline);
$self->associated_class->add_method($method->name, $method);
$self->associate_method($method);
sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
sub _make_delegation_method {
- my ( $self, $handle_name, $method_to_call ) = @_;
+ my ( $self, $handle_name, $method_to_call, $is_inline ) = @_;
my @curried_arguments;
attribute => $self,
delegate_to_method => $method_to_call,
curried_arguments => \@curried_arguments,
+ is_inline => $is_inline,
);
}
# Moose always does this when an attribute is created
inline_accessors => 0,
+ inline_delegations => 1,
@args,
);
}
+sub _install_inlined_code {
+ my ( $self, %args ) = @_;
+
+ $self->SUPER::_install_inlined_code(%args);
+ $self->_inline_delegations(%args) if $args{inline_delegations};
+}
+
+sub _inline_delegations {
+ my $self = shift;
+ foreach my $attr_name ( $self->get_attribute_list ) {
+ my $attr = $self->get_attribute($attr_name);
+ $attr->install_delegation(1) if $attr->can('install_delegation');
+ }
+}
+
sub create {
my ($self, $package_name, %options) = @_;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::Method',
- 'Class::MOP::Method::Generated';
+ 'Class::MOP::Method::Inlined';
sub new {
sub delegate_to_method { (shift)->{'delegate_to_method'} }
+sub is_inline {
+ (shift)->{is_inline}
+}
+
+sub definition_context {
+ exists $_[0]->{definition_context} ? $_[0]->{definition_context}
+ : ($_[0]->{definition_context} = $_[0]->_generate_definition_context);
+}
+
+sub _generate_definition_context {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+ my $ctx = $attr->definition_context;
+ return unless $ctx;
+
+ my $desc = "delegation of "
+ . $self->name
+ . ' to '
+ . $attr->name
+ . '->'
+ . $self->delegate_to_method;
+
+ return { %$ctx, description => $desc };
+}
+
sub _initialize_body {
my $self = shift;
return $self->{body} = $method_to_call
if ref $method_to_call;
+ return $self->{body} = $self->is_inline
+ ? $self->_generate_body_inline
+ : $self->_generate_body;
+}
+
+sub _generate_body_inline {
+ my $self = shift;
+ my $method_to_call = $self->delegate_to_method;
+ my $attr = $self->associated_attribute;
+ my $attr_name = $attr->name;
+ my $meta_instance = $attr->associated_class->instance_metaclass;
+ my $handle_name = $self->name;
+
+ my ( $code, $e ) = $self->_compile_code(
+ environment => {
+ '@curried_arguments' => $self->curried_arguments,
+ '$method' => \$self,
+ },
+ code => (
+ 'sub {'."\n"
+ . 'my $instance = shift; '."\n"
+ . 'my $proxy = '
+ . $meta_instance->inline_get_slot_value('$instance',$attr_name)
+ . ';'."\n"
+ . 'my $error '."\n"
+ . ' = !defined $proxy ? q{ is not defined} '."\n"
+ . q{ : ref($proxy) && !Scalar::Util::blessed($proxy) ? qq{ is not an object (got '$proxy')} }."\n"
+ . ' : undef;'."\n"
+ . 'if ($error) {'."\n"
+ . ' $method->throw_error('."\n"
+ . ' "Cannot delegate '. $handle_name.' to '.$method_to_call
+ . ' because the value of '
+ . $attr_name
+ . '" . $error, '."\n"
+ . ' method_name => q{'.$method_to_call.'}, '."\n"
+ . ' object => $instance, '."\n"
+ . ');}'."\n"
+ . ($self->curried_arguments
+ ? 'unshift @_, @{curried_arguments};'."\n"
+ : '')
+ . '$proxy->'.$method_to_call.'(@_);'."\n"
+ . '};'
+ ),
+ );
+ confess "Could not generate inline accessor because : $e" if $e;
+
+ return $code;
+}
+
+sub _generate_body {
+ my $self = shift;
+
+ my $method_to_call = $self->delegate_to_method;
+
my $accessor = $self->_get_delegate_accessor;
my $handle_name = $self->name;
# all... the only thing that would end up different would be
# interpolating in $method_to_call, and a bunch of things in the
# error handling that mostly never gets called - doy
- $self->{body} = sub {
+ return sub {
my $instance = shift;
my $proxy = $instance->$accessor();
sub baz { 42 }
+ sub quux { confess }
+
package Bar;
use Moose;
handles => {
'foo_bar' => 'bar',
foo_baz => 'baz',
+ foo_quux => 'quux',
'foo_bar_to_20' => [ bar => 20 ],
},
);
}
-my $bar = Bar->new;
-isa_ok($bar, 'Bar');
+sub test_hash_handles {
+ my $bar = shift;
+ isa_ok($bar, 'Bar');
-ok($bar->foo, '... we have something in bar->foo');
-isa_ok($bar->foo, 'Foo');
+ ok($bar->foo, '... we have something in bar->foo');
+ isa_ok($bar->foo, 'Foo');
-my $meth = Bar->meta->get_method('foo_bar');
-isa_ok($meth, 'Moose::Meta::Method::Delegation');
-is($meth->associated_attribute->name, 'foo',
- 'associated_attribute->name for this method is foo');
+ my $meth = Bar->meta->get_method('foo_bar');
+ isa_ok($meth, 'Moose::Meta::Method::Delegation');
+ is($meth->associated_attribute->name, 'foo',
+ 'associated_attribute->name for this method is foo');
-is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
+ is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
-can_ok($bar, 'foo_bar');
-is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
+ can_ok($bar, 'foo_bar');
+ is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
-# change the value ...
+ # change the value ...
-$bar->foo->bar(30);
+ $bar->foo->bar(30);
-# and make sure the delegation picks it up
+ # and make sure the delegation picks it up
-is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
-is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
+ is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
+ is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
-# change the value through the delegation ...
+ # change the value through the delegation ...
-$bar->foo_bar(50);
+ $bar->foo_bar(50);
-# and make sure everyone sees it
+ # and make sure everyone sees it
-is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
-is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
+ is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
+ is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
-# change the object we are delegating too
+ # change the object we are delegating too
-my $foo = Foo->new(bar => 25);
-isa_ok($foo, 'Foo');
+ my $foo = Foo->new(bar => 25);
+ isa_ok($foo, 'Foo');
-is($foo->bar, 25, '... got the right foo->bar');
+ is($foo->bar, 25, '... got the right foo->bar');
-lives_ok {
- $bar->foo($foo);
-} '... assigned the new Foo to Bar->foo';
+ lives_ok {
+ $bar->foo($foo);
+ } '... assigned the new Foo to Bar->foo';
+
+ is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
+
+ is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
+ is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
-is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
+ # curried handles
+ $bar->foo_bar_to_20;
+ is($bar->foo_bar, 20, '... correctly curried a single argument');
+}
+
+# Works with a mutable class
-is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
-is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
+{
+ test_hash_handles(Bar->new);
+}
-# curried handles
-$bar->foo_bar_to_20;
-is($bar->foo_bar, 20, '... correctly curried a single argument');
+# Works with an immutable class and provides a meaningful backtrace
+
+{
+ Bar->meta->make_immutable;
+ my $filename = __FILE__;
+ my $bar = Bar->new;
+ test_hash_handles($bar);
+ throws_ok { $bar->foo_quux } qr/delegation of foo_quux to foo->quux/,
+ 'error location describes the delegation';
+ throws_ok { $bar->foo_quux } qr/defined at $filename line \d+/,
+ '... and points at where the handler is defined';
+}
# -------------------------------------------------------------------
# ARRAY handles
options
)
],
+ 'Moose::Meta::Method::Delegation' => [ 'definition_context', 'is_inline' ],
'Moose::Meta::Method::Destructor' => [ 'initialize_body', 'options' ],
'Moose::Meta::Role' => [
qw( alias_method
projects / gitmo/Moose.git / commitdiff