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