Filename | /usr/local/share/perl/5.18.2/Devel/OverloadInfo.pm |
Statements | Executed 205 statements in 1.19ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
92 | 1 | 1 | 541µs | 2.87ms | is_overloaded | Devel::OverloadInfo::
1 | 1 | 1 | 396µs | 604µs | BEGIN@18 | Devel::OverloadInfo::
1 | 1 | 1 | 264µs | 885µs | BEGIN@19 | Devel::OverloadInfo::
1 | 1 | 1 | 9µs | 22µs | BEGIN@22 | Devel::OverloadInfo::
1 | 1 | 1 | 8µs | 18µs | BEGIN@14 | Devel::OverloadInfo::
1 | 1 | 1 | 6µs | 9µs | BEGIN@15 | Devel::OverloadInfo::
1 | 1 | 1 | 5µs | 23µs | BEGIN@17 | Devel::OverloadInfo::
1 | 1 | 1 | 4µs | 4µs | BEGIN@20 | Devel::OverloadInfo::
1 | 1 | 1 | 2µs | 2µs | BEGIN@16 | Devel::OverloadInfo::
0 | 0 | 0 | 0s | 0s | overload_info | Devel::OverloadInfo::
0 | 0 | 0 | 0s | 0s | stash_with_symbol | Devel::OverloadInfo::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Devel::OverloadInfo; | ||||
2 | 1 | 500ns | $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 | 19µs | 2 | 27µs | # spent 18µs (8+9) within Devel::OverloadInfo::BEGIN@14 which was called:
# once (8µs+9µs) by Class::MOP::Mixin::HasOverloads::BEGIN@9 at line 14 # spent 18µs making 1 call to Devel::OverloadInfo::BEGIN@14
# spent 9µs making 1 call to strict::import |
15 | 2 | 16µs | 2 | 12µs | # spent 9µs (6+3) within Devel::OverloadInfo::BEGIN@15 which was called:
# once (6µs+3µs) by Class::MOP::Mixin::HasOverloads::BEGIN@9 at line 15 # spent 9µs making 1 call to Devel::OverloadInfo::BEGIN@15
# spent 3µs making 1 call to warnings::import |
16 | 2 | 17µ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 | 20µs | 2 | 42µs | # spent 23µs (5+18) within Devel::OverloadInfo::BEGIN@17 which was called:
# once (5µs+18µs) by Class::MOP::Mixin::HasOverloads::BEGIN@9 at line 17 # spent 23µs making 1 call to Devel::OverloadInfo::BEGIN@17
# spent 18µs making 1 call to Exporter::import |
18 | 2 | 82µs | 2 | 634µs | # spent 604µs (396+208) within Devel::OverloadInfo::BEGIN@18 which was called:
# once (396µs+208µs) by Class::MOP::Mixin::HasOverloads::BEGIN@9 at line 18 # spent 604µs making 1 call to Devel::OverloadInfo::BEGIN@18
# spent 30µs making 1 call to Exporter::import |
19 | 3 | 91µs | 2 | 892µs | # spent 885µs (264+621) within Devel::OverloadInfo::BEGIN@19 which was called:
# once (264µs+621µs) by Class::MOP::Mixin::HasOverloads::BEGIN@9 at line 19 # spent 885µs making 1 call to Devel::OverloadInfo::BEGIN@19
# spent 7µs making 1 call to UNIVERSAL::VERSION |
20 | 2 | 23µ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 | 330µs | 3 | 34µs | # spent 22µs (9+12) within Devel::OverloadInfo::BEGIN@22 which was called:
# once (9µs+12µ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 | 900ns | 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 | # spent 2.87ms (541µs+2.33) within Devel::OverloadInfo::is_overloaded which was called 92 times, avg 31µs/call:
# 92 times (541µs+2.33ms) by Class::MOP::Mixin::HasOverloads::is_overloaded at line 19 of Class/MOP/Mixin/HasOverloads.pm, avg 31µs/call | ||||
52 | 92 | 208µs | 92 | 30µs | my $class = blessed($_[0]) || $_[0]; # spent 30µs making 92 calls to Scalar::Util::blessed, avg 330ns/call |
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 | 92 | 382µs | 92 | 2.30ms | return !!("$]" >= 5.016 # spent 2.30ms making 92 calls to overload::Overloaded, avg 25µs/call |
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 | 2µs | 1; | ||
151 | |||||
152 | __END__ |