File Coverage

blib/lib/Class/MOP/Object.pm
Criterion Covered Total %
statement 43 47 91.4
branch 10 10 100.0
condition 3 5 60.0
subroutine 14 15 93.3
pod 2 2 100.0
total 72 79 91.1


line stmt bran cond sub pod time code
1             package Class::MOP::Object;
2             our $VERSION = '2.2206';
3              
4 451     451   208952 use strict;
  451         1095  
  451         12939  
5 451     451   2286 use warnings;
  451         1005  
  451         13109  
6              
7 451     451   2347 use parent 'Class::MOP::Mixin';
  451         1007  
  451         3848  
8 451     451   27967 use Scalar::Util 'blessed';
  451         1260  
  451         22391  
9 451     451   3418 use Module::Runtime;
  451         1053  
  451         3019  
10              
11             # introspection
12              
13             sub throw_error {
14 3     3 1 39 shift->_throw_exception( Legacy => message => join('', @_) );
15             }
16              
17             sub _inline_throw_error {
18 1     1   16 my ( $self, $message ) = @_;
19 1         9 return 'die Module::Runtime::use_module("Moose::Exception::Legacy")->new(message => ' . $message. ')';
20             }
21              
22             sub _new {
23 390     390   2345 Class::MOP::class_of(shift)->new_object(@_);
24             }
25              
26             # RANT:
27             # Cmon, how many times have you written
28             # the following code while debugging:
29             #
30             # use Data::Dumper;
31             # warn Dumper $obj;
32             #
33             # It can get seriously annoying, so why
34             # not just do this ...
35             sub dump {
36 0     0 1 0 my $self = shift;
37 0         0 require Data::Dumper;
38 0   0     0 local $Data::Dumper::Maxdepth = shift || 1;
39 0         0 Data::Dumper::Dumper $self;
40             }
41              
42             sub _real_ref_name {
43 199     199   409 my $self = shift;
44 199         981 return blessed($self);
45             }
46              
47             sub _is_compatible_with {
48 160420     160420   213315 my $self = shift;
49 160420         232080 my ($other_name) = @_;
50              
51 160420         887923 return $self->isa($other_name);
52             }
53              
54             sub _can_be_made_compatible_with {
55 137810     137810   192424 my $self = shift;
56 137810   100     270737 return !$self->_is_compatible_with(@_)
57             && defined($self->_get_compatible_metaclass(@_));
58             }
59              
60             sub _make_compatible_with {
61 116     116   279 my $self = shift;
62 116         264 my ($other_name) = @_;
63              
64 116         689 my $new_metaclass = $self->_get_compatible_metaclass($other_name);
65              
66 116 100       395 unless ( defined $new_metaclass ) {
67 3         58 $self->_throw_exception( CannotMakeMetaclassCompatible => superclass_name => $other_name,
68             class => $self,
69             );
70             }
71              
72             # can't use rebless_instance here, because it might not be an actual
73             # subclass in the case of, e.g. moose role reconciliation
74 113 100       672 $new_metaclass->meta->_force_rebless_instance($self)
75             if blessed($self) ne $new_metaclass;
76              
77 113         421 return $self;
78             }
79              
80             sub _get_compatible_metaclass {
81 509     509   876 my $self = shift;
82 509         869 my ($other_name) = @_;
83              
84 509         1455 return $self->_get_compatible_metaclass_by_subclassing($other_name);
85             }
86              
87             sub _get_compatible_metaclass_by_subclassing {
88 509     509   768 my $self = shift;
89 509         812 my ($other_name) = @_;
90 509 100       1817 my $meta_name = blessed($self) ? $self->_real_ref_name : $self;
91              
92 509 100       3025 if ($meta_name->isa($other_name)) {
    100          
93 35         158 return $meta_name;
94             }
95             elsif ($other_name->isa($meta_name)) {
96 392         2088 return $other_name;
97             }
98              
99 82         495 return;
100             }
101              
102             1;
103              
104             # ABSTRACT: Base class for metaclasses
105              
106             __END__
107              
108             =pod
109              
110             =encoding UTF-8
111              
112             =head1 NAME
113              
114             Class::MOP::Object - Base class for metaclasses
115              
116             =head1 VERSION
117              
118             version 2.2206
119              
120             =head1 DESCRIPTION
121              
122             This class is a very minimal base class for metaclasses.
123              
124             =head1 METHODS
125              
126             This class provides a few methods which are useful in all metaclasses.
127              
128             =head2 Class::MOP::???->meta
129              
130             This returns a L<Class::MOP::Class> object.
131              
132             =head2 $metaobject->dump($max_depth)
133              
134             This method uses L<Data::Dumper> to dump the object. You can pass an
135             optional maximum depth, which will set C<$Data::Dumper::Maxdepth>. The
136             default maximum depth is 1.
137              
138             =head2 $metaclass->throw_error($message)
139              
140             This method calls L<Class::MOP::Mixin/_throw_exception> internally, with an object
141             of class L<Moose::Exception::Legacy>.
142              
143             =head1 AUTHORS
144              
145             =over 4
146              
147             =item *
148              
149             Stevan Little <stevan@cpan.org>
150              
151             =item *
152              
153             Dave Rolsky <autarch@urth.org>
154              
155             =item *
156              
157             Jesse Luehrs <doy@cpan.org>
158              
159             =item *
160              
161             Shawn M Moore <sartak@cpan.org>
162              
163             =item *
164              
165             יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
166              
167             =item *
168              
169             Karen Etheridge <ether@cpan.org>
170              
171             =item *
172              
173             Florian Ragwitz <rafl@debian.org>
174              
175             =item *
176              
177             Hans Dieter Pearcey <hdp@cpan.org>
178              
179             =item *
180              
181             Chris Prather <chris@prather.org>
182              
183             =item *
184              
185             Matt S Trout <mstrout@cpan.org>
186              
187             =back
188              
189             =head1 COPYRIGHT AND LICENSE
190              
191             This software is copyright (c) 2006 by Infinity Interactive, Inc.
192              
193             This is free software; you can redistribute it and/or modify it under
194             the same terms as the Perl 5 programming language system itself.
195              
196             =cut