Permalink
Browse files

Return different meta method instances for each invocation of the met…

…hod keyword.
  • Loading branch information...
1 parent fe1ad1b commit b4790733dcaebe0fabe86735c441c8c9603e4cb6 @rafl committed Aug 27, 2009
Showing with 47 additions and 50 deletions.
  1. +8 −6 lib/MooseX/Method/Signatures.pm
  2. +38 −42 lib/MooseX/Method/Signatures/Meta/Method.pm
  3. +1 −2 t/closure.t
@@ -217,7 +217,7 @@ sub _parser {
$args{prototype_injections} = $self->prototype_injections->{injections};
}
- my $method = MooseX::Method::Signatures::Meta::Method->wrap(%args);
+ my $proto_method = MooseX::Method::Signatures::Meta::Method->wrap(%args);
my $after_block = ')';
@@ -232,18 +232,20 @@ sub _parser {
$after_block = $name_arg . $after_block . q{;};
}
- my $inject = $method->injectable_code;
+ my $inject = $proto_method->injectable_code;
$inject = $self->scope_injector_call($after_block) . $inject;
$ctx->inject_if_block($inject, "(sub ${attrs} ");
my $create_meta_method = sub {
my ($code, $pkg, $meth_name, @args) = @_;
subname $pkg . "::" .$meth_name, $code;
- $method->_set_actual_body($code);
- $method->_set_package_name($pkg);
- $method->_set_name($meth_name);
- $method->_adopt_trait_args(@args);
+ my $method = $proto_method->clone(
+ actual_body => $code,
+ package_name => $pkg,
+ name => $meth_name,
+ trait_args => \@args,
+ );
return $method;
};
@@ -95,7 +95,6 @@ has _return_type_constraint => (
has actual_body => (
is => 'ro',
isa => CodeRef,
- writer => '_set_actual_body',
predicate => '_has_actual_body',
);
@@ -126,14 +125,28 @@ around name => sub {
return $ret;
};
-sub _set_name {
- my ($self, $name) = @_;
- $self->{name} = $name;
-}
+sub _wrapped_body {
+ my ($class, $self, %args) = @_;
+
+ if (exists $args{return_signature}) {
+ return sub {
+ my @args = ${ $self }->validate(\@_);
+ return preserve_context { ${ $self }->actual_body->(@args) }
+ after => sub {
+ if (defined (my $msg = ${ $self }->_return_type_constraint->validate(\@_))) {
+ confess $msg;
+ }
+ };
+ };
+ }
+
+ my $actual_body;
+ return sub {
+ @_ = ${ $self }->validate(\@_);
+ $actual_body ||= ${ $self }->actual_body;
+ goto &{ $actual_body };
+ };
-sub _set_package_name {
- my ($self, $package_name) = @_;
- $self->{package_name} = $package_name;
}
sub wrap {
@@ -142,26 +155,9 @@ sub wrap {
$args{actual_body} = delete $args{body}
if exists $args{body};
- my ($to_wrap, $self);
+ my $self;
+ my $to_wrap = $class->_wrapped_body(\$self, %args);
- if (exists $args{return_signature}) {
- $to_wrap = sub {
- my @args = $self->validate(\@_);
- return preserve_context { $self->actual_body->(@args) }
- after => sub {
- if (defined (my $msg = $self->_return_type_constraint->validate(\@_))) {
- confess $msg;
- }
- };
- };
- } else {
- my $actual_body;
- $to_wrap = sub {
- @_ = $self->validate(\@_);
- $actual_body ||= $self->actual_body;
- goto &{ $actual_body };
- };
- }
if ($args{traits}) {
my @traits = map {
@@ -191,21 +187,21 @@ sub wrap {
return $self;
}
-# ok, this is a little lame, as you can't really rely on the normal attribute
-# initialisation within your traits. I suppose we should create the metamethod
-# subclass with its traits here and pass the trait parameters directly to its
-# constructor, throwing away the current "compile-time metamethod" and
-# returning the one that'll be used at runtime. that'd also allow us to get rid
-# of some hacks we currently have, because the metamethod instance persists
-# from compile time to runtme (see _set_name, _set_package_name, etc).
-sub _adopt_trait_args {
- my ($self, %args) = @_;
- while (my ($name, $val) = each %args) {
- my $attr = $self->meta->get_attribute($name);
- confess qq{trying to set non-existant metamethod attribute $name}
- unless $attr;
- $attr->set_initial_value($self, $val);
- }
+sub clone {
+ my ($self, %params) = @_;
+ my $trait_args = delete $params{trait_args};
+
+ my $clone;
+ $clone = $self->meta->clone_object($self,
+ %params, @{ $trait_args || [] },
+ body => $self->_wrapped_body(\$clone,
+ ($self->has_return_signature
+ ? (return_signature => $self->return_signature)
+ : ()),
+ ),
+ );
+
+ return $clone;
}
sub _build_parsed_signature {
View
@@ -23,8 +23,7 @@ can_ok('Foo', map { ("anon_$_", "str_$_") } qw/foo bar baz/);
my $foo = Foo->new;
-TODO: for my $meth (qw/foo bar baz/) {
- local $TODO = 'weird closing behaviour';
+for my $meth (qw/foo bar baz/) {
is($foo->${\"anon_$meth"}('bar'), $meth . 'bar');
is($foo->${\"str_$meth"}('bar'), $meth . 'bar');
}

0 comments on commit b479073

Please sign in to comment.