| Filename | /home/ss5/perl5/perlbrew/perls/perl-5.22.0/lib/site_perl/5.22.0/Devel/OverloadInfo.pm |
| Statements | Executed 21 statements in 486µs |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 380µs | 558µs | Devel::OverloadInfo::BEGIN@18 |
| 1 | 1 | 1 | 16µs | 25µs | Devel::OverloadInfo::BEGIN@19 |
| 1 | 1 | 1 | 10µs | 22µs | Devel::OverloadInfo::BEGIN@22 |
| 1 | 1 | 1 | 8µs | 10µs | Devel::OverloadInfo::BEGIN@14 |
| 1 | 1 | 1 | 4µs | 4µs | Devel::OverloadInfo::BEGIN@20 |
| 1 | 1 | 1 | 4µs | 24µs | Devel::OverloadInfo::BEGIN@17 |
| 1 | 1 | 1 | 4µs | 7µs | Devel::OverloadInfo::BEGIN@15 |
| 1 | 1 | 1 | 2µs | 2µs | Devel::OverloadInfo::BEGIN@16 |
| 0 | 0 | 0 | 0s | 0s | Devel::OverloadInfo::is_overloaded |
| 0 | 0 | 0 | 0s | 0s | Devel::OverloadInfo::overload_info |
| 0 | 0 | 0 | 0s | 0s | Devel::OverloadInfo::stash_with_symbol |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package Devel::OverloadInfo; | ||||
| 2 | 1 | 300ns | $Devel::OverloadInfo::VERSION = '0.004'; | ||
| 3 | # ABSTRACT: introspect overloaded operators | ||||
| 4 | |||||
| 5 | #pod =head1 DESCRIPTION | ||||
| 6 | #pod | ||||
| 7 | #pod Devel::OverloadInfo returns information about L<overloaded|overload> | ||||
| 8 | #pod operators for a given class (or object), including where in the | ||||
| 9 | #pod inheritance hierarchy the overloads are declared and where the code | ||||
| 10 | #pod implementing it is. | ||||
| 11 | #pod | ||||
| 12 | #pod =cut | ||||
| 13 | |||||
| 14 | 2 | 14µs | 2 | 12µs | # spent 10µs (8+2) within Devel::OverloadInfo::BEGIN@14 which was called:
# once (8µs+2µs) by Class::MOP::Mixin::HasOverloads::BEGIN@9 at line 14 # spent 10µs making 1 call to Devel::OverloadInfo::BEGIN@14
# spent 2µs making 1 call to strict::import |
| 15 | 2 | 12µs | 2 | 10µs | # spent 7µs (4+3) within Devel::OverloadInfo::BEGIN@15 which was called:
# once (4µs+3µs) by Class::MOP::Mixin::HasOverloads::BEGIN@9 at line 15 # spent 7µs making 1 call to Devel::OverloadInfo::BEGIN@15
# spent 3µs making 1 call to warnings::import |
| 16 | 2 | 12µs | 1 | 2µs | # spent 2µs within Devel::OverloadInfo::BEGIN@16 which was called:
# once (2µs+0s) by Class::MOP::Mixin::HasOverloads::BEGIN@9 at line 16 # spent 2µs making 1 call to Devel::OverloadInfo::BEGIN@16 |
| 17 | 2 | 16µs | 2 | 44µs | # spent 24µs (4+20) within Devel::OverloadInfo::BEGIN@17 which was called:
# once (4µs+20µs) by Class::MOP::Mixin::HasOverloads::BEGIN@9 at line 17 # spent 24µs making 1 call to Devel::OverloadInfo::BEGIN@17
# spent 20µs making 1 call to Exporter::import |
| 18 | 2 | 64µs | 2 | 585µs | # spent 558µs (380+178) within Devel::OverloadInfo::BEGIN@18 which was called:
# once (380µs+178µs) by Class::MOP::Mixin::HasOverloads::BEGIN@9 at line 18 # spent 558µs making 1 call to Devel::OverloadInfo::BEGIN@18
# spent 27µs making 1 call to Exporter::import |
| 19 | 3 | 39µs | 2 | 33µs | # spent 25µs (16+8) within Devel::OverloadInfo::BEGIN@19 which was called:
# once (16µs+8µs) by Class::MOP::Mixin::HasOverloads::BEGIN@9 at line 19 # spent 25µs making 1 call to Devel::OverloadInfo::BEGIN@19
# spent 8µs making 1 call to UNIVERSAL::VERSION |
| 20 | 2 | 29µs | 1 | 4µs | # spent 4µs within Devel::OverloadInfo::BEGIN@20 which was called:
# once (4µs+0s) by Class::MOP::Mixin::HasOverloads::BEGIN@9 at line 20 # spent 4µs making 1 call to Devel::OverloadInfo::BEGIN@20 |
| 21 | |||||
| 22 | 3 | 296µs | 3 | 33µs | # spent 22µs (10+11) within Devel::OverloadInfo::BEGIN@22 which was called:
# once (10µs+11µs) by Class::MOP::Mixin::HasOverloads::BEGIN@9 at line 22 # spent 22µs making 1 call to Devel::OverloadInfo::BEGIN@22
# spent 6µs making 1 call to UNIVERSAL::VERSION
# spent 6µs making 1 call to Exporter::import |
| 23 | 1 | 600ns | our @EXPORT_OK = qw(overload_info is_overloaded); | ||
| 24 | |||||
| 25 | sub stash_with_symbol { | ||||
| 26 | my ($class, $symbol) = @_; | ||||
| 27 | |||||
| 28 | for my $package (@{mro::get_linear_isa($class)}) { | ||||
| 29 | my $stash = Package::Stash->new($package); | ||||
| 30 | my $value_ref = $stash->get_symbol($symbol); | ||||
| 31 | return ($stash, $value_ref) if $value_ref; | ||||
| 32 | } | ||||
| 33 | return; | ||||
| 34 | } | ||||
| 35 | |||||
| 36 | #pod =func is_overloaded | ||||
| 37 | #pod | ||||
| 38 | #pod if (is_overloaded($class_or_object)) { ... } | ||||
| 39 | #pod | ||||
| 40 | #pod Returns a boolean indicating whether the given class or object has any | ||||
| 41 | #pod overloading declared. Note that a bare C<use overload;> with no | ||||
| 42 | #pod actual operators counts as being overloaded. | ||||
| 43 | #pod | ||||
| 44 | #pod Equivalent to | ||||
| 45 | #pod L<overload::Overloaded()|overload/overload::Overloaded(arg)>, but | ||||
| 46 | #pod doesn't trigger various bugs associated with it in versions of perl | ||||
| 47 | #pod before 5.16. | ||||
| 48 | #pod | ||||
| 49 | #pod =cut | ||||
| 50 | |||||
| 51 | sub is_overloaded { | ||||
| 52 | my $class = blessed($_[0]) || $_[0]; | ||||
| 53 | |||||
| 54 | # Perl before 5.16 seems to corrupt inherited overload info if | ||||
| 55 | # there's a lone dereference overload and overload::Overloaded() | ||||
| 56 | # is called before any object has been blessed into the class. | ||||
| 57 | return !!("$]" >= 5.016 | ||||
| 58 | ? overload::Overloaded($class) | ||||
| 59 | : stash_with_symbol($class, '&()') | ||||
| 60 | ); | ||||
| 61 | } | ||||
| 62 | |||||
| 63 | #pod =func overload_info | ||||
| 64 | #pod | ||||
| 65 | #pod my $info = overload_info($class_or_object); | ||||
| 66 | #pod | ||||
| 67 | #pod Returns a hash reference with information about all the overloaded | ||||
| 68 | #pod operators of the argument, which can be either a class name or a blessed | ||||
| 69 | #pod object. The keys are the overloaded operators, as specified in | ||||
| 70 | #pod C<%overload::ops> (see L<overload/Overloadable Operations>). | ||||
| 71 | #pod | ||||
| 72 | #pod =over | ||||
| 73 | #pod | ||||
| 74 | #pod =item class | ||||
| 75 | #pod | ||||
| 76 | #pod The name of the class in which the operator overloading was declared. | ||||
| 77 | #pod | ||||
| 78 | #pod =item code | ||||
| 79 | #pod | ||||
| 80 | #pod A reference to the function implementing the overloaded operator. | ||||
| 81 | #pod | ||||
| 82 | #pod =item code_name | ||||
| 83 | #pod | ||||
| 84 | #pod The name of the function implementing the overloaded operator, as | ||||
| 85 | #pod returned by C<sub_fullname> in L<Sub::Identify>. | ||||
| 86 | #pod | ||||
| 87 | #pod =item method_name (optional) | ||||
| 88 | #pod | ||||
| 89 | #pod The name of the method implementing the overloaded operator, if the | ||||
| 90 | #pod overloading was specified as a named method, e.g. C<< use overload $op | ||||
| 91 | #pod => 'method'; >>. | ||||
| 92 | #pod | ||||
| 93 | #pod =item code_class (optional) | ||||
| 94 | #pod | ||||
| 95 | #pod The name of the class in which the method specified by C<method_name> | ||||
| 96 | #pod was found. | ||||
| 97 | #pod | ||||
| 98 | #pod =item value (optional) | ||||
| 99 | #pod | ||||
| 100 | #pod For the special C<fallback> key, the value it was given in C<class>. | ||||
| 101 | #pod | ||||
| 102 | #pod =back | ||||
| 103 | #pod | ||||
| 104 | #pod =cut | ||||
| 105 | |||||
| 106 | sub overload_info { | ||||
| 107 | my $class = blessed($_[0]) || $_[0]; | ||||
| 108 | |||||
| 109 | return {} unless is_overloaded($class); | ||||
| 110 | |||||
| 111 | my (%overloaded); | ||||
| 112 | for my $op (map split(/\s+/), values %overload::ops) { | ||||
| 113 | my $op_method = $op eq 'fallback' ? "()" : "($op"; | ||||
| 114 | my ($stash, $func) = stash_with_symbol($class, "&$op_method") | ||||
| 115 | or next; | ||||
| 116 | my $info = $overloaded{$op} = { | ||||
| 117 | class => $stash->name, | ||||
| 118 | }; | ||||
| 119 | if ($func == \&overload::nil) { | ||||
| 120 | # Named method or fallback, stored in the scalar slot | ||||
| 121 | if (my $value_ref = $stash->get_symbol("\$$op_method")) { | ||||
| 122 | my $value = $$value_ref; | ||||
| 123 | if ($op eq 'fallback') { | ||||
| 124 | $info->{value} = $value; | ||||
| 125 | } else { | ||||
| 126 | $info->{method_name} = $value; | ||||
| 127 | if (my ($impl_stash, $impl_func) = stash_with_symbol($class, "&$value")) { | ||||
| 128 | $info->{code_class} = $impl_stash->name; | ||||
| 129 | $info->{code} = $impl_func; | ||||
| 130 | } | ||||
| 131 | } | ||||
| 132 | } | ||||
| 133 | } else { | ||||
| 134 | $info->{code} = $func; | ||||
| 135 | } | ||||
| 136 | $info->{code_name} = sub_fullname($info->{code}) | ||||
| 137 | if exists $info->{code}; | ||||
| 138 | } | ||||
| 139 | return \%overloaded; | ||||
| 140 | } | ||||
| 141 | |||||
| 142 | #pod =head1 CAVEATS | ||||
| 143 | #pod | ||||
| 144 | #pod Whether the C<fallback> key exists when it has its default value of | ||||
| 145 | #pod C<undef> varies between perl versions: Before 5.18 it's there, in | ||||
| 146 | #pod later versions it's not. | ||||
| 147 | #pod | ||||
| 148 | #pod =cut | ||||
| 149 | |||||
| 150 | 1 | 3µs | 1; | ||
| 151 | |||||
| 152 | __END__ |