Commit | Line | Data |
38bf2a25 |
1 | |
2 | package Class::MOP::Method::Meta; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use Carp 'confess'; |
c21e08da |
8 | use Scalar::Util 'blessed', 'weaken'; |
38bf2a25 |
9 | |
38bf2a25 |
10 | use constant DEBUG_NO_META => $ENV{DEBUG_NO_META} ? 1 : 0; |
11 | |
12 | use base 'Class::MOP::Method'; |
13 | |
14 | sub _is_caller_mop_internal { |
15 | my $self = shift; |
16 | my ($caller) = @_; |
17 | return $caller =~ /^(?:Class::MOP|metaclass)(?:::|$)/; |
18 | } |
19 | |
20 | sub _generate_meta_method { |
21 | my $method_self = shift; |
22 | my $metaclass = shift; |
c21e08da |
23 | weaken($metaclass); |
24 | |
38bf2a25 |
25 | sub { |
26 | # this will be compiled out if the env var wasn't set |
27 | if (DEBUG_NO_META) { |
28 | confess "'meta' method called by MOP internals" |
29 | # it's okay to call meta methods on metaclasses, since we |
30 | # explicitly ask for them |
31 | if !$_[0]->isa('Class::MOP::Object') |
32 | && !$_[0]->isa('Class::MOP::Mixin') |
33 | # it's okay if the test itself calls ->meta, we only care about |
34 | # if the mop internals call ->meta |
35 | && $method_self->_is_caller_mop_internal(scalar caller); |
36 | } |
37 | # we must re-initialize so that it |
38 | # works as expected in subclasses, |
39 | # since metaclass instances are |
40 | # singletons, this is not really a |
41 | # big deal anyway. |
42 | $metaclass->initialize(blessed($_[0]) || $_[0]) |
43 | }; |
44 | } |
45 | |
46 | sub wrap { |
47 | my ($class, @args) = @_; |
48 | |
49 | unshift @args, 'body' if @args % 2 == 1; |
50 | my %params = @args; |
51 | confess "Overriding the body of meta methods is not allowed" |
52 | if $params{body}; |
53 | |
54 | my $metaclass_class = $params{associated_metaclass}->meta; |
55 | $params{body} = $class->_generate_meta_method($metaclass_class); |
56 | return $class->SUPER::wrap(%params); |
57 | } |
58 | |
59 | sub _make_compatible_with { |
60 | my $self = shift; |
61 | my ($other) = @_; |
62 | |
63 | # XXX: this is pretty gross. the issue here is that CMOP::Method::Meta |
64 | # objects are subclasses of CMOP::Method, but when we get to moose, they'll |
65 | # need to be compatible with Moose::Meta::Method, which isn't possible. the |
66 | # right solution here is to make ::Meta into a role that gets applied to |
67 | # whatever the method_metaclass happens to be and get rid of |
68 | # _meta_method_metaclass entirely, but that's not going to happen until |
69 | # we ditch cmop and get roles into the bootstrapping, so. i'm not |
70 | # maintaining the previous behavior of turning them into instances of the |
71 | # new method_metaclass because that's equally broken, and at least this way |
72 | # any issues will at least be detectable and potentially fixable. -doy |
73 | return $self unless $other->_is_compatible_with($self->_real_ref_name); |
74 | |
75 | return $self->SUPER::_make_compatible_with(@_); |
76 | } |
77 | |
78 | 1; |
79 | |
80 | # ABSTRACT: Method Meta Object for C<meta> methods |
81 | |
82 | __END__ |
83 | |
84 | =pod |
85 | |
86 | =head1 DESCRIPTION |
87 | |
88 | This is a L<Class::MOP::Method> subclass which represents C<meta> |
89 | methods installed into classes by Class::MOP. |
90 | |
91 | =head1 METHODS |
92 | |
93 | =over 4 |
94 | |
95 | =item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >> |
96 | |
97 | This is the constructor. It accepts a L<Class::MOP::Method> object and |
98 | a hash of options. The options accepted are identical to the ones |
99 | accepted by L<Class::MOP::Method>, except that C<body> cannot be passed |
100 | (it will be generated automatically). |
101 | |
102 | =back |
103 | |
104 | =cut |
105 | |