File Coverage

blib/lib/Class/MOP/Method/Meta.pm
Criterion Covered Total %
statement 34 38 89.4
branch 6 8 75.0
condition 2 3 66.6
subroutine 77 77 100.0
pod 1 1 100.0
total 120 127 94.4


line stmt bran cond sub pod time code
1             package Class::MOP::Method::Meta;
2             our $VERSION = '2.2206';
3              
4 450     206438   3273 use strict;
  450         937  
  450         13040  
5 450     157177   2320 use warnings;
  450         1027  
  450         12165  
6              
7 450     78874   2530 use Carp 'confess';
  450         1090  
  450         24055  
8 450     70427   3113 use Scalar::Util 'blessed', 'weaken';
  450         1154  
  450         31627  
9              
10 450 50   29993   3427 use constant DEBUG_NO_META => $ENV{DEBUG_NO_META} ? 1 : 0;
  450         1228  
  450         35388  
11              
12 450     28385   3731 use parent 'Class::MOP::Method';
  450         1593  
  450         3029  
13              
14             sub _is_caller_mop_internal {
15 0     26695   0 my $self = shift;
16 0         0 my ($caller) = @_;
17 0         0 return $caller =~ /^(?:Class::MOP|metaclass)(?:::|$)/;
18             }
19              
20             sub _generate_meta_method {
21 12939     38436   24465 my $method_self = shift;
22 12939         19760 my $metaclass = shift;
23 12939         44379 weaken($metaclass);
24              
25             sub {
26             # this will be compiled out if the env var wasn't set
27 86842     111578   551840 if (DEBUG_NO_META) {
        110346      
        109156      
        106729      
        105693      
        103544      
        102243      
        100051      
        99482      
        98869      
        97956      
        97045      
        95595      
        94952      
        94420      
        86204      
        86204      
        85678      
        85678      
        85678      
        85678      
        85601      
        85601      
        85601      
        85229      
        694      
        694      
        640      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
        437      
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 86842   66     462416 $metaclass->initialize(blessed($_[0]) || $_[0])
43 12939         79417 };
44             }
45              
46             sub wrap {
47 12940     13580 1 43564 my ($class, @args) = @_;
48              
49 12940 100       37617 unshift @args, 'body' if @args % 2 == 1;
50 12940         48741 my %params = @args;
51             $class->_throw_exception( CannotOverrideBodyOfMetaMethods => params => \%params,
52             class => $class
53             )
54 12940 100       36347 if $params{body};
55              
56 12939         36809 my $metaclass_class = $params{associated_metaclass}->meta;
57 12939         53932 $params{body} = $class->_generate_meta_method($metaclass_class);
58 12939         67345 return $class->SUPER::wrap(%params);
59             }
60              
61             sub _make_compatible_with {
62 129     566   274 my $self = shift;
63 129         315 my ($other) = @_;
64              
65             # XXX: this is pretty gross. the issue here is that CMOP::Method::Meta
66             # objects are subclasses of CMOP::Method, but when we get to moose, they'll
67             # need to be compatible with Moose::Meta::Method, which isn't possible. the
68             # right solution here is to make ::Meta into a role that gets applied to
69             # whatever the method_metaclass happens to be and get rid of
70             # _meta_method_metaclass entirely, but that's not going to happen until
71             # we ditch cmop and get roles into the bootstrapping, so. i'm not
72             # maintaining the previous behavior of turning them into instances of the
73             # new method_metaclass because that's equally broken, and at least this way
74             # any issues will at least be detectable and potentially fixable. -doy
75 129 50       916 return $self unless $other->_is_compatible_with($self->_real_ref_name);
76              
77 0           return $self->SUPER::_make_compatible_with(@_);
78             }
79              
80             1;
81              
82             # ABSTRACT: Method Meta Object for C<meta> methods
83              
84             __END__
85              
86             =pod
87              
88             =encoding UTF-8
89              
90             =head1 NAME
91              
92             Class::MOP::Method::Meta - Method Meta Object for C<meta> methods
93              
94             =head1 VERSION
95              
96             version 2.2206
97              
98             =head1 DESCRIPTION
99              
100             This is a L<Class::MOP::Method> subclass which represents C<meta>
101             methods installed into classes by Class::MOP.
102              
103             =head1 METHODS
104              
105             =over 4
106              
107             =item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >>
108              
109             This is the constructor. It accepts a L<Class::MOP::Method> object and
110             a hash of options. The options accepted are identical to the ones
111             accepted by L<Class::MOP::Method>, except that C<body> cannot be passed
112             (it will be generated automatically).
113              
114             =back
115              
116             =head1 AUTHORS
117              
118             =over 4
119              
120             =item *
121              
122             Stevan Little <stevan@cpan.org>
123              
124             =item *
125              
126             Dave Rolsky <autarch@urth.org>
127              
128             =item *
129              
130             Jesse Luehrs <doy@cpan.org>
131              
132             =item *
133              
134             Shawn M Moore <sartak@cpan.org>
135              
136             =item *
137              
138             יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
139              
140             =item *
141              
142             Karen Etheridge <ether@cpan.org>
143              
144             =item *
145              
146             Florian Ragwitz <rafl@debian.org>
147              
148             =item *
149              
150             Hans Dieter Pearcey <hdp@cpan.org>
151              
152             =item *
153              
154             Chris Prather <chris@prather.org>
155              
156             =item *
157              
158             Matt S Trout <mstrout@cpan.org>
159              
160             =back
161              
162             =head1 COPYRIGHT AND LICENSE
163              
164             This software is copyright (c) 2006 by Infinity Interactive, Inc.
165              
166             This is free software; you can redistribute it and/or modify it under
167             the same terms as the Perl 5 programming language system itself.
168              
169             =cut