| File | /usr/local/lib/perl/5.10.0/Class/MOP/Object.pm |
| Statements Executed | 2017 |
| Total Time | 0.0057753 seconds |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 422 | 3 | 2 | 2.51ms | 4.07ms | Class::MOP::Object::_is_compatible_with |
| 334 | 2 | 1 | 1.73ms | 4.95ms | Class::MOP::Object::_can_be_made_compatible_with |
| 1 | 1 | 1 | 9µs | 438µs | Class::MOP::Object::_new |
| 0 | 0 | 0 | 0s | 0s | Class::MOP::Object::BEGIN |
| 0 | 0 | 0 | 0s | 0s | Class::MOP::Object::_get_compatible_metaclass |
| 0 | 0 | 0 | 0s | 0s | Class::MOP::Object::_get_compatible_metaclass_by_subclassing |
| 0 | 0 | 0 | 0s | 0s | Class::MOP::Object::_make_compatible_with |
| 0 | 0 | 0 | 0s | 0s | Class::MOP::Object::_real_ref_name |
| 0 | 0 | 0 | 0s | 0s | Class::MOP::Object::dump |
| 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 | 33 | 20µs | 612ns | require Class::MOP::Class; |
| 18 | 33 | 231µs | 7µs | 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 | 422 | 209µs | 496ns | my $self = shift; |
| 48 | 422 | 393µs | 931ns | my ($other_name) = @_; |
| 49 | ||||
| 50 | 422 | 2.66ms | 6µs | 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 | 334 | 176µs | 526ns | my $self = shift; |
| 55 | 334 | 1.47ms | 4µs | 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 |