Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

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

…hod keyword.
  • Loading branch information...
commit b4790733dcaebe0fabe86735c441c8c9603e4cb6 1 parent fe1ad1b
Florian Ragwitz authored August 27, 2009
14  lib/MooseX/Method/Signatures.pm
@@ -217,7 +217,7 @@ sub _parser {
217 217
         $args{prototype_injections} = $self->prototype_injections->{injections};
218 218
     }
219 219
 
220  
-    my $method = MooseX::Method::Signatures::Meta::Method->wrap(%args);
  220
+    my $proto_method = MooseX::Method::Signatures::Meta::Method->wrap(%args);
221 221
 
222 222
     my $after_block = ')';
223 223
 
@@ -232,7 +232,7 @@ sub _parser {
232 232
         $after_block = $name_arg . $after_block . q{;};
233 233
     }
234 234
 
235  
-    my $inject = $method->injectable_code;
  235
+    my $inject = $proto_method->injectable_code;
236 236
     $inject = $self->scope_injector_call($after_block) . $inject;
237 237
 
238 238
     $ctx->inject_if_block($inject, "(sub ${attrs} ");
@@ -240,10 +240,12 @@ sub _parser {
240 240
     my $create_meta_method = sub {
241 241
         my ($code, $pkg, $meth_name, @args) = @_;
242 242
         subname $pkg . "::" .$meth_name, $code;
243  
-        $method->_set_actual_body($code);
244  
-        $method->_set_package_name($pkg);
245  
-        $method->_set_name($meth_name);
246  
-        $method->_adopt_trait_args(@args);
  243
+        my $method = $proto_method->clone(
  244
+            actual_body  => $code,
  245
+            package_name => $pkg,
  246
+            name         => $meth_name,
  247
+            trait_args   => \@args,
  248
+        );
247 249
         return $method;
248 250
     };
249 251
 
80  lib/MooseX/Method/Signatures/Meta/Method.pm
@@ -95,7 +95,6 @@ has _return_type_constraint => (
95 95
 has actual_body => (
96 96
     is        => 'ro',
97 97
     isa       => CodeRef,
98  
-    writer    => '_set_actual_body',
99 98
     predicate => '_has_actual_body',
100 99
 );
101 100
 
@@ -126,14 +125,28 @@ around name => sub {
126 125
     return $ret;
127 126
 };
128 127
 
129  
-sub _set_name {
130  
-    my ($self, $name) = @_;
131  
-    $self->{name} = $name;
132  
-}
  128
+sub _wrapped_body {
  129
+    my ($class, $self, %args) = @_;
  130
+
  131
+    if (exists $args{return_signature}) {
  132
+        return sub {
  133
+            my @args = ${ $self }->validate(\@_);
  134
+            return preserve_context { ${ $self }->actual_body->(@args) }
  135
+                after => sub {
  136
+                    if (defined (my $msg = ${ $self }->_return_type_constraint->validate(\@_))) {
  137
+                        confess $msg;
  138
+                    }
  139
+                };
  140
+        };
  141
+    }
  142
+
  143
+    my $actual_body;
  144
+    return sub {
  145
+        @_ = ${ $self }->validate(\@_);
  146
+        $actual_body ||= ${ $self }->actual_body;
  147
+        goto &{ $actual_body };
  148
+    };
133 149
 
134  
-sub _set_package_name {
135  
-    my ($self, $package_name) = @_;
136  
-    $self->{package_name} = $package_name;
137 150
 }
138 151
 
139 152
 sub wrap {
@@ -142,26 +155,9 @@ sub wrap {
142 155
     $args{actual_body} = delete $args{body}
143 156
         if exists $args{body};
144 157
 
145  
-    my ($to_wrap, $self);
  158
+    my $self;
  159
+    my $to_wrap = $class->_wrapped_body(\$self, %args);
146 160
 
147  
-    if (exists $args{return_signature}) {
148  
-        $to_wrap = sub {
149  
-            my @args = $self->validate(\@_);
150  
-            return preserve_context { $self->actual_body->(@args) }
151  
-                after => sub {
152  
-                    if (defined (my $msg = $self->_return_type_constraint->validate(\@_))) {
153  
-                        confess $msg;
154  
-                    }
155  
-                };
156  
-        };
157  
-    } else {
158  
-        my $actual_body;
159  
-        $to_wrap = sub {
160  
-            @_ = $self->validate(\@_);
161  
-            $actual_body ||= $self->actual_body;
162  
-            goto &{ $actual_body };
163  
-        };
164  
-    }
165 161
 
166 162
     if ($args{traits}) {
167 163
         my @traits = map {
@@ -191,21 +187,21 @@ sub wrap {
191 187
     return $self;
192 188
 }
193 189
 
194  
-# ok, this is a little lame, as you can't really rely on the normal attribute
195  
-# initialisation within your traits. I suppose we should create the metamethod
196  
-# subclass with its traits here and pass the trait parameters directly to its
197  
-# constructor, throwing away the current "compile-time metamethod" and
198  
-# returning the one that'll be used at runtime. that'd also allow us to get rid
199  
-# of some hacks we currently have, because the metamethod instance persists
200  
-# from compile time to runtme (see _set_name, _set_package_name, etc).
201  
-sub _adopt_trait_args {
202  
-    my ($self, %args) = @_;
203  
-    while (my ($name, $val) = each %args) {
204  
-        my $attr = $self->meta->get_attribute($name);
205  
-        confess qq{trying to set non-existant metamethod attribute $name}
206  
-            unless $attr;
207  
-        $attr->set_initial_value($self, $val);
208  
-    }
  190
+sub clone {
  191
+    my ($self, %params) = @_;
  192
+    my $trait_args = delete $params{trait_args};
  193
+
  194
+    my $clone;
  195
+    $clone = $self->meta->clone_object($self,
  196
+        %params, @{ $trait_args || [] },
  197
+        body => $self->_wrapped_body(\$clone,
  198
+            ($self->has_return_signature
  199
+              ? (return_signature => $self->return_signature)
  200
+              : ()),
  201
+        ),
  202
+    );
  203
+
  204
+    return $clone;
209 205
 }
210 206
 
211 207
 sub _build_parsed_signature {
3  t/closure.t
@@ -23,8 +23,7 @@ can_ok('Foo', map { ("anon_$_", "str_$_") } qw/foo bar baz/);
23 23
 
24 24
 my $foo = Foo->new;
25 25
 
26  
-TODO: for my $meth (qw/foo bar baz/) {
27  
-    local $TODO = 'weird closing behaviour';
  26
+for my $meth (qw/foo bar baz/) {
28 27
     is($foo->${\"anon_$meth"}('bar'), $meth . 'bar');
29 28
     is($foo->${\"str_$meth"}('bar'), $meth . 'bar');
30 29
 }

0 notes on commit b479073

Please sign in to comment.
Something went wrong with that request. Please try again.