File | /usr/local/lib/perl/5.10.0/Class/MOP/Object.pm |
Statements Executed | 2017 |
Total Time | 0.00577529999999998 seconds |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
422 | 3 | 2 | 2.51ms | 4.07ms | _is_compatible_with | Class::MOP::Object::
334 | 2 | 1 | 1.73ms | 4.95ms | _can_be_made_compatible_with | Class::MOP::Object::
1 | 1 | 1 | 9µs | 438µs | _new | Class::MOP::Object::
0 | 0 | 0 | 0s | 0s | BEGIN | Class::MOP::Object::
0 | 0 | 0 | 0s | 0s | _get_compatible_metaclass | Class::MOP::Object::
0 | 0 | 0 | 0s | 0s | _get_compatible_metaclass_by_subclassing | Class::MOP::Object::
0 | 0 | 0 | 0s | 0s | _make_compatible_with | Class::MOP::Object::
0 | 0 | 0 | 0s | 0s | _real_ref_name | Class::MOP::Object::
0 | 0 | 0 | 0s | 0s | dump | Class::MOP::Object::
Line | Stmts. | Exclusive Time | Avg. | Code |
---|---|---|---|---|
1 | ||||
2 | package Class::MOP::Object; | |||
3 | ||||
4 | 3 | 28µs | 9µs | use strict; # spent 7µs making 1 call to strict::import |
5 | 3 | 24µs | 8µs | use warnings; # spent 25µs making 1 call to warnings::import |
6 | ||||
7 | 3 | 23µs | 8µs | use Carp qw(confess); # spent 44µs making 1 call to Exporter::import |
8 | 3 | 498µs | 166µs | use Scalar::Util 'blessed'; # spent 36µs making 1 call to Exporter::import |
9 | ||||
10 | 1 | 1µs | 1µs | our $VERSION = '1.09'; |
11 | 1 | 21µs | 21µs | $VERSION = eval $VERSION; |
12 | 1 | 800ns | 800ns | our $AUTHORITY = 'cpan:STEVAN'; |
13 | ||||
14 | # introspection | |||
15 | ||||
16 | sub meta { | |||
17 | 66 | 252µs | 4µs | require Class::MOP::Class; |
18 | Class::MOP::Class->initialize(blessed($_[0]) || $_[0]); # spent 6.32ms making 33 calls to Class::MOP::Class::initialize, avg 191µs/call
# spent 75µs making 33 calls to Scalar::Util::blessed, avg 2µs/call | |||
19 | } | |||
20 | ||||
21 | # spent 438µs (9+429) within Class::MOP::Object::_new which was called
# once (9µs+429µs) by Moose::Meta::TypeConstraint::Registry::new at line 29 of /usr/local/lib/perl/5.10.0/Moose/Meta/TypeConstraint/Registry.pm | |||
22 | 1 | 13µs | 13µs | Class::MOP::class_of(shift)->new_object(@_); # spent 414µs making 1 call to Class::MOP::Class::new_object
# spent 16µs making 1 call to Class::MOP::class_of |
23 | } | |||
24 | ||||
25 | # RANT: | |||
26 | # Cmon, how many times have you written | |||
27 | # the following code while debugging: | |||
28 | # | |||
29 | # use Data::Dumper; | |||
30 | # warn Dumper $obj; | |||
31 | # | |||
32 | # It can get seriously annoying, so why | |||
33 | # not just do this ... | |||
34 | sub dump { | |||
35 | my $self = shift; | |||
36 | require Data::Dumper; | |||
37 | local $Data::Dumper::Maxdepth = shift || 1; | |||
38 | Data::Dumper::Dumper $self; | |||
39 | } | |||
40 | ||||
41 | sub _real_ref_name { | |||
42 | my $self = shift; | |||
43 | return blessed($self); | |||
44 | } | |||
45 | ||||
46 | # spent 4.07ms (2.51+1.55) within Class::MOP::Object::_is_compatible_with which was called 422 times, avg 10µs/call:
# 334 times (1.97ms+1.24ms) by Class::MOP::Object::_can_be_made_compatible_with at line 55, avg 10µs/call
# 77 times (456µs+274µs) by Class::MOP::Class::_single_metaclass_is_compatible at line 301 of /usr/local/lib/perl/5.10.0/Class/MOP/Class.pm, avg 9µs/call
# 11 times (85µs+36µs) by Class::MOP::Class::_class_metaclass_is_compatible at line 263 of /usr/local/lib/perl/5.10.0/Class/MOP/Class.pm, avg 11µs/call | |||
47 | 1266 | 3.26ms | 3µs | my $self = shift; |
48 | my ($other_name) = @_; | |||
49 | ||||
50 | return $self->isa($other_name); # spent 1.55ms making 422 calls to UNIVERSAL::isa, avg 4µs/call | |||
51 | } | |||
52 | ||||
53 | # spent 4.95ms (1.73+3.22) within Class::MOP::Object::_can_be_made_compatible_with which was called 334 times, avg 15µs/call:
# 282 times (1.43ms+2.72ms) by Class::MOP::Class::_single_metaclass_can_be_made_compatible at line 371 of /usr/local/lib/perl/5.10.0/Class/MOP/Class.pm, avg 15µs/call
# 52 times (301µs+499µs) by Class::MOP::Class::_class_metaclass_can_be_made_compatible at line 351 of /usr/local/lib/perl/5.10.0/Class/MOP/Class.pm, avg 15µs/call | |||
54 | 668 | 1.64ms | 2µs | my $self = shift; |
55 | return !$self->_is_compatible_with(@_) # spent 3.22ms making 334 calls to Class::MOP::Object::_is_compatible_with, avg 10µs/call | |||
56 | && defined($self->_get_compatible_metaclass(@_)); | |||
57 | } | |||
58 | ||||
59 | sub _make_compatible_with { | |||
60 | my $self = shift; | |||
61 | my ($other_name) = @_; | |||
62 | ||||
63 | my $new_metaclass = $self->_get_compatible_metaclass($other_name); | |||
64 | ||||
65 | confess "Can't make $self compatible with metaclass $other_name" | |||
66 | unless defined $new_metaclass; | |||
67 | ||||
68 | # can't use rebless_instance here, because it might not be an actual | |||
69 | # subclass in the case of, e.g. moose role reconciliation | |||
70 | $new_metaclass->meta->_force_rebless_instance($self) | |||
71 | if blessed($self) ne $new_metaclass; | |||
72 | ||||
73 | return $self; | |||
74 | } | |||
75 | ||||
76 | sub _get_compatible_metaclass { | |||
77 | my $self = shift; | |||
78 | my ($other_name) = @_; | |||
79 | ||||
80 | return $self->_get_compatible_metaclass_by_subclassing($other_name); | |||
81 | } | |||
82 | ||||
83 | sub _get_compatible_metaclass_by_subclassing { | |||
84 | my $self = shift; | |||
85 | my ($other_name) = @_; | |||
86 | my $meta_name = blessed($self) ? $self->_real_ref_name : $self; | |||
87 | ||||
88 | if ($meta_name->isa($other_name)) { | |||
89 | return $meta_name; | |||
90 | } | |||
91 | elsif ($other_name->isa($meta_name)) { | |||
92 | return $other_name; | |||
93 | } | |||
94 | ||||
95 | return; | |||
96 | } | |||
97 | ||||
98 | 1 | 9µs | 9µs | 1; |
99 | ||||
100 | __END__ | |||
101 | ||||
102 | =pod | |||
103 | ||||
104 | =head1 NAME | |||
105 | ||||
106 | Class::MOP::Object - Base class for metaclasses | |||
107 | ||||
108 | =head1 DESCRIPTION | |||
109 | ||||
110 | This class is a very minimal base class for metaclasses. | |||
111 | ||||
112 | =head1 METHODS | |||
113 | ||||
114 | This class provides a few methods which are useful in all metaclasses. | |||
115 | ||||
116 | =over 4 | |||
117 | ||||
118 | =item B<< Class::MOP::???->meta >> | |||
119 | ||||
120 | This returns a L<Class::MOP::Class> object. | |||
121 | ||||
122 | =item B<< $metaobject->dump($max_depth) >> | |||
123 | ||||
124 | This method uses L<Data::Dumper> to dump the object. You can pass an | |||
125 | optional maximum depth, which will set C<$Data::Dumper::Maxdepth>. The | |||
126 | default maximum depth is 1. | |||
127 | ||||
128 | =back | |||
129 | ||||
130 | =head1 AUTHORS | |||
131 | ||||
132 | Stevan Little E<lt>stevan@iinteractive.comE<gt> | |||
133 | ||||
134 | =head1 COPYRIGHT AND LICENSE | |||
135 | ||||
136 | Copyright 2006-2010 by Infinity Interactive, Inc. | |||
137 | ||||
138 | L<http://www.iinteractive.com> | |||
139 | ||||
140 | This library is free software; you can redistribute it and/or modify | |||
141 | it under the same terms as Perl itself. | |||
142 | ||||
143 | =cut |