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.2205';
3
4	450			206438		3140	use strict;
	450					981
	450					13056
5	450			157177		2282	use warnings;
	450					994
	450					11793
6
7	450			78874		2531	use Carp 'confess';
	450					1053
	450					24057
8	450			70427		3111	use Scalar::Util 'blessed', 'weaken';
	450					1286
	450					32125
9
10	450	50		29993		3472	use constant DEBUG_NO_META => $ENV{DEBUG_NO_META} ? 1 : 0;
	450					1189
	450					35416
11
12	450			28385		3714	use parent 'Class::MOP::Method';
	450					1464
	450					3086
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		24523	my $method_self = shift;
22	12939					19983	my $metaclass = shift;
23	12939					44554	weaken($metaclass);
24
25							sub {
26							# this will be compiled out if the env var wasn't set
27	86842			111578		547888	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			463191	$metaclass->initialize(blessed($_[0]) \|\| $_[0])
43	12939					78699	};
44							}
45
46							sub wrap {
47	12940			13580	1	44045	my ($class, @args) = @_;
48
49	12940	100				38022	unshift @args, 'body' if @args % 2 == 1;
50	12940					48497	my %params = @args;
51							$class->_throw_exception( CannotOverrideBodyOfMetaMethods => params => \%params,
52							class => $class
53							)
54	12940	100				36734	if $params{body};
55
56	12939					36913	my $metaclass_class = $params{associated_metaclass}->meta;
57	12939					54130	$params{body} = $class->_generate_meta_method($metaclass_class);
58	12939					68052	return $class->SUPER::wrap(%params);
59							}
60
61							sub _make_compatible_with {
62	131			568		267	my $self = shift;
63	131					311	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	131	50				970	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.2205
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