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.2203';
3
4	462			210036		2827	use strict;
	462					803
	462					11814
5	462			160141		1981	use warnings;
	462					790
	462					10340
6
7	462			79604		2049	use Carp 'confess';
	462					857
	462					21183
8	462			71157		2699	use Scalar::Util 'blessed', 'weaken';
	462					965
	462					27948
9
10	462	50		30257		3078	use constant DEBUG_NO_META => $ENV{DEBUG_NO_META} ? 1 : 0;
	462					974
	462					32789
11
12	462			28649		3273	use parent 'Class::MOP::Method';
	462					1256
	462					2563
13
14							sub _is_caller_mop_internal {
15	0			26947		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	13256			39005		21318	my $method_self = shift;
22	13256					17864	my $metaclass = shift;
23	13256					38160	weaken($metaclass);
24
25							sub {
26							# this will be compiled out if the env var wasn't set
27	89123			114111		548300	if (DEBUG_NO_META) {
				112879
				111689
				109262
				108171
				106022
				104721
				102529
				101960
				101095
				100182
				99271
				97821
				97178
				96646
				88430
				88430
				87904
				87904
				87904
				87904
				87827
				87827
				87827
				87641
				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	89123		66			419462	$metaclass->initialize(blessed($_[0]) \|\| $_[0])
43	13256					70758	};
44							}
45
46							sub wrap {
47	13257			13897	1	38671	my ($class, @args) = @_;
48
49	13257	100				34056	unshift @args, 'body' if @args % 2 == 1;
50	13257					43064	my %params = @args;
51							$class->_throw_exception( CannotOverrideBodyOfMetaMethods => params => \%params,
52							class => $class
53							)
54	13257	100				32189	if $params{body};
55
56	13256					34161	my $metaclass_class = $params{associated_metaclass}->meta;
57	13256					44174	$params{body} = $class->_generate_meta_method($metaclass_class);
58	13256					61443	return $class->SUPER::wrap(%params);
59							}
60
61							sub _make_compatible_with {
62	132			569		259	my $self = shift;
63	132					288	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	132	50				743	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.2203
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