Commit | Line | Data |
59b51046 |
1 | |
2 | package Class::MOP::Method::Meta; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use Carp 'confess'; |
8 | use Scalar::Util 'blessed'; |
9 | |
10 | our $VERSION = '1.08'; |
11 | $VERSION = eval $VERSION; |
12 | our $AUTHORITY = 'cpan:STEVAN'; |
13 | |
14 | use constant DEBUG_NO_META => $ENV{DEBUG_NO_META}; |
15 | |
16 | use base 'Class::MOP::Method'; |
17 | |
18 | sub _generate_meta_method { |
19 | my $method_self = shift; |
20 | my $metaclass = shift; |
21 | sub { |
22 | # this will be compiled out if the env var wasn't set |
23 | if (DEBUG_NO_META) { |
24 | my ($self) = @_; |
25 | # it's okay if we installed a meta method in a subclass of a class |
26 | # with a legitimate meta method (we'll still die if we install a |
27 | # meta method in a subclass of a class we installed a meta method |
28 | # in, since this function is itself defined in Class::MOP) |
29 | #if (my $meta = try { $self->SUPER::meta }) { |
30 | #return $meta if $meta->isa('Class::MOP::Class'); |
31 | #} |
32 | # it's okay if the test itself calls ->meta, we only care about if |
33 | # the mop internals call ->meta |
34 | confess "'meta' method called by MOP internals" |
35 | if caller =~ /^(?:Class::MOP|metaclass)(?:::|$)/; |
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 | 1; |
60 | |
61 | __END__ |
62 | |
63 | =pod |
64 | |
65 | =head1 NAME |
66 | |
67 | Class::MOP::Method::Meta - Method Meta Object for C<meta> methods |
68 | |
69 | =head1 DESCRIPTION |
70 | |
71 | This is a L<Class::MOP::Method> subclass which represents C<meta> |
72 | methods installed into classes by Class::MOP. |
73 | |
74 | =head1 METHODS |
75 | |
76 | =over 4 |
77 | |
78 | =item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >> |
79 | |
80 | This is the constructor. It accepts a L<Class::MOP::Method> object and |
81 | a hash of options. The options accepted are identical to the ones |
82 | accepted by L<Class::MOP::Method>, except that C<body> cannot be passed |
83 | (it will be generated automatically). |
84 | |
85 | =back |
86 | |
87 | =head1 AUTHORS |
88 | |
89 | Jesse Luehrs E<lt>doy at tozt dot netE<gt> |
90 | |
91 | =head1 COPYRIGHT AND LICENSE |
92 | |
93 | Copyright 2006-2010 by Infinity Interactive, Inc. |
94 | |
95 | L<http://www.iinteractive.com> |
96 | |
97 | This library is free software; you can redistribute it and/or modify |
98 | it under the same terms as Perl itself. |
99 | |
100 | =cut |
101 | |