Profile of overload.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For t/app_dpath.t
Run on Tue Jun 5 15:25:28 2012
Reported on Tue Jun 5 15:25:59 2012

Filename | /home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/overload.pm
Statements | Executed 93 statements in 2.74ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 942µs | 1.41ms | overload::::BEGIN@147overload::BEGIN@147
4 | 1 | 1 | 643µs | 643µs | overload::::OVERLOADoverload::OVERLOAD
4 | 4 | 4 | 200µs | 843µs | overload::::importoverload::import
0 | 0 | 0 | 0s | 0s | overload::::AddrRefoverload::AddrRef
0 | 0 | 0 | 0s | 0s | overload::::Methodoverload::Method
0 | 0 | 0 | 0s | 0s | overload::::Overloadedoverload::Overloaded
0 | 0 | 0 | 0s | 0s | overload::::OverloadedStringifyoverload::OverloadedStringify
0 | 0 | 0 | 0s | 0s | overload::::constantoverload::constant
0 | 0 | 0 | 0s | 0s | overload::::mycanoverload::mycan
0 | 0 | 0 | 0s | 0s | overload::::niloverload::nil
0 | 0 | 0 | 0s | 0s | overload::::ov_methodoverload::ov_method
0 | 0 | 0 | 0s | 0s | overload::::remove_constantoverload::remove_constant
0 | 0 | 0 | 0s | 0s | overload::::unimportoverload::unimport

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package overload;
2 |  |  |  |  |
3 | 1 | 3µs |  |  | our $VERSION = '1.13';
4 |  |  |  |  |
5 |  |  |  |  | sub nil {}
6 |  |  |  |  |
7 |  |  |  |  | # spent 643µs within overload::OVERLOAD which was called 4 times, avg 161µs/call: # 4 times (643µs+0s) by overload::import at line 34, avg 161µs/call sub OVERLOAD {
8 | 74 | 689µs |  |  | $package = shift;
9 |  |  |  |  | my %arg = @_;
10 |  |  |  |  | my ($sub, $fb);
11 |  |  |  |  | $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching.
12 |  |  |  |  | $fb = ${$package . "::()"}; # preserve old fallback value RT#68196
13 |  |  |  |  | *{$package . "::()"} = \&nil; # Make it findable via fetchmethod.
14 |  |  |  |  | for (keys %arg) {
15 |  |  |  |  | if ($_ eq 'fallback') {
16 |  |  |  |  | $fb = $arg{$_};
17 |  |  |  |  | } else {
18 |  |  |  |  | $sub = $arg{$_};
19 |  |  |  |  | if (not ref $sub and $sub !~ /::/) {
20 |  |  |  |  | $ {$package . "::(" . $_} = $sub;
21 |  |  |  |  | $sub = \&nil;
22 |  |  |  |  | }
23 |  |  |  |  | #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n";
24 |  |  |  |  | *{$package . "::(" . $_} = \&{ $sub };
25 |  |  |  |  | }
26 |  |  |  |  | }
27 |  |  |  |  | ${$package . "::()"} = $fb; # Make it findable too (fallback only).
28 |  |  |  |  | }
29 |  |  |  |  |
30 |  |  |  |  | # spent 843µs (200+643) within overload::import which was called 4 times, avg 211µs/call: # once (77µs+210µs) by Test::Deep::Cmp::BEGIN@7 at line 7 of Test/Deep/Cmp.pm # once (47µs+225µs) by JSON::XS::Boolean::BEGIN@3 at line 14 of (eval 9)[JSON.pm:353] # once (44µs+123µs) by JSON::XS::Boolean::BEGIN@1477 at line 1480 of JSON/XS.pm # once (32µs+84µs) by JSON::PP::Boolean::BEGIN@3 at line 14 of (eval 10)[JSON.pm:353] sub import {
31 | 12 | 193µs |  |  | $package = (caller())[0];
32 |  |  |  |  | # *{$package . "::OVERLOAD"} = \&OVERLOAD;
33 |  |  |  |  | shift;
34 |  |  | 4 | 643µs | $package->overload::OVERLOAD(@_); # spent 643µs making 4 calls to overload::OVERLOAD, avg 161µs/call
35 |  |  |  |  | }
36 |  |  |  |  |
37 |  |  |  |  | sub unimport {
38 |  |  |  |  | $package = (caller())[0];
39 |  |  |  |  | ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table
40 |  |  |  |  | shift;
41 |  |  |  |  | for (@_) {
42 |  |  |  |  | if ($_ eq 'fallback') {
43 |  |  |  |  | undef $ {$package . "::()"};
44 |  |  |  |  | } else {
45 |  |  |  |  | delete $ {$package . "::"}{"(" . $_};
46 |  |  |  |  | }
47 |  |  |  |  | }
48 |  |  |  |  | }
49 |  |  |  |  |
50 |  |  |  |  | sub Overloaded {
51 |  |  |  |  | my $package = shift;
52 |  |  |  |  | $package = ref $package if ref $package;
53 |  |  |  |  | $package->can('()');
54 |  |  |  |  | }
55 |  |  |  |  |
56 |  |  |  |  | sub ov_method {
57 |  |  |  |  | my $globref = shift;
58 |  |  |  |  | return undef unless $globref;
59 |  |  |  |  | my $sub = \&{*$globref};
60 |  |  |  |  | require Scalar::Util;
61 |  |  |  |  | return $sub
62 |  |  |  |  | if Scalar::Util::refaddr($sub) != Scalar::Util::refaddr(\&nil);
63 |  |  |  |  | return shift->can($ {*$globref});
64 |  |  |  |  | }
65 |  |  |  |  |
66 |  |  |  |  | sub OverloadedStringify {
67 |  |  |  |  | my $package = shift;
68 |  |  |  |  | $package = ref $package if ref $package;
69 |  |  |  |  | #$package->can('(""')
70 |  |  |  |  | ov_method mycan($package, '(""'), $package
71 |  |  |  |  | or ov_method mycan($package, '(0+'), $package
72 |  |  |  |  | or ov_method mycan($package, '(bool'), $package
73 |  |  |  |  | or ov_method mycan($package, '(nomethod'), $package;
74 |  |  |  |  | }
75 |  |  |  |  |
76 |  |  |  |  | sub Method {
77 |  |  |  |  | my $package = shift;
78 |  |  |  |  | if(ref $package) {
79 |  |  |  |  | local $@;
80 |  |  |  |  | local $!;
81 |  |  |  |  | require Scalar::Util;
82 |  |  |  |  | $package = Scalar::Util::blessed($package);
83 |  |  |  |  | return undef if !defined $package;
84 |  |  |  |  | }
85 |  |  |  |  | #my $meth = $package->can('(' . shift);
86 |  |  |  |  | ov_method mycan($package, '(' . shift), $package;
87 |  |  |  |  | #return $meth if $meth ne \&nil;
88 |  |  |  |  | #return $ {*{$meth}};
89 |  |  |  |  | }
90 |  |  |  |  |
91 |  |  |  |  | sub AddrRef {
92 |  |  |  |  | my $package = ref $_[0];
93 |  |  |  |  | return "$_[0]" unless $package;
94 |  |  |  |  |
95 |  |  |  |  | local $@;
96 |  |  |  |  | local $!;
97 |  |  |  |  | require Scalar::Util;
98 |  |  |  |  | my $class = Scalar::Util::blessed($_[0]);
99 |  |  |  |  | my $class_prefix = defined($class) ? "$class=" : "";
100 |  |  |  |  | my $type = Scalar::Util::reftype($_[0]);
101 |  |  |  |  | my $addr = Scalar::Util::refaddr($_[0]);
102 |  |  |  |  | return sprintf("%s%s(0x%x)", $class_prefix, $type, $addr);
103 |  |  |  |  | }
104 |  |  |  |  |
105 | 1 | 8µs |  |  | *StrVal = *AddrRef;
106 |  |  |  |  |
107 |  |  |  |  | sub mycan { # Real can would leave stubs.
108 |  |  |  |  | my ($package, $meth) = @_;
109 |  |  |  |  |
110 |  |  |  |  | local $@;
111 |  |  |  |  | local $!;
112 |  |  |  |  | require mro;
113 |  |  |  |  |
114 |  |  |  |  | my $mro = mro::get_linear_isa($package);
115 |  |  |  |  | foreach my $p (@$mro) {
116 |  |  |  |  | my $fqmeth = $p . q{::} . $meth;
117 |  |  |  |  | return \*{$fqmeth} if defined &{$fqmeth};
118 |  |  |  |  | }
119 |  |  |  |  |
120 |  |  |  |  | return undef;
121 |  |  |  |  | }
122 |  |  |  |  |
123 | 1 | 12µs |  |  | %constants = (
124 |  |  |  |  | 'integer' => 0x1000, # HINT_NEW_INTEGER
125 |  |  |  |  | 'float' => 0x2000, # HINT_NEW_FLOAT
126 |  |  |  |  | 'binary' => 0x4000, # HINT_NEW_BINARY
127 |  |  |  |  | 'q' => 0x8000, # HINT_NEW_STRING
128 |  |  |  |  | 'qr' => 0x10000, # HINT_NEW_RE
129 |  |  |  |  | );
130 |  |  |  |  |
131 | 1 | 25µs |  |  | %ops = ( with_assign => "+ - * / % ** << >> x .",
132 |  |  |  |  | assign => "+= -= *= /= %= **= <<= >>= x= .=",
133 |  |  |  |  | num_comparison => "< <= > >= == !=",
134 |  |  |  |  | '3way_comparison'=> "<=> cmp",
135 |  |  |  |  | str_comparison => "lt le gt ge eq ne",
136 |  |  |  |  | binary => '& &= | |= ^ ^=',
137 |  |  |  |  | unary => "neg ! ~",
138 |  |  |  |  | mutators => '++ --',
139 |  |  |  |  | func => "atan2 cos sin exp abs log sqrt int",
140 |  |  |  |  | conversion => 'bool "" 0+ qr',
141 |  |  |  |  | iterators => '<>',
142 |  |  |  |  | filetest => "-X",
143 |  |  |  |  | dereferencing => '${} @{} %{} &{} *{}',
144 |  |  |  |  | matching => '~~',
145 |  |  |  |  | special => 'nomethod fallback =');
146 |  |  |  |  |
147 | 2 | 1.78ms | 2 | 1.87ms | # spent 1.41ms (942µs+464µs) within overload::BEGIN@147 which was called: # once (942µs+464µs) by main::BEGIN@6 at line 147 use warnings::register; # spent 1.41ms making 1 call to overload::BEGIN@147 # spent 464µs making 1 call to warnings::register::import
148 |  |  |  |  | sub constant {
149 |  |  |  |  | # Arguments: what, sub
150 |  |  |  |  | while (@_) {
151 |  |  |  |  | if (@_ == 1) {
152 |  |  |  |  | warnings::warnif ("Odd number of arguments for overload::constant");
153 |  |  |  |  | last;
154 |  |  |  |  | }
155 |  |  |  |  | elsif (!exists $constants {$_ [0]}) {
156 |  |  |  |  | warnings::warnif ("`$_[0]' is not an overloadable type");
157 |  |  |  |  | }
158 |  |  |  |  | elsif (!ref $_ [1] || "$_[1]" !~ /(^|=)CODE\(0x[0-9a-f]+\)$/) {
159 |  |  |  |  | # Can't use C<ref $_[1] eq "CODE"> above as code references can be
160 |  |  |  |  | # blessed, and C<ref> would return the package the ref is blessed into.
161 |  |  |  |  | if (warnings::enabled) {
162 |  |  |  |  | $_ [1] = "undef" unless defined $_ [1];
163 |  |  |  |  | warnings::warn ("`$_[1]' is not a code reference");
164 |  |  |  |  | }
165 |  |  |  |  | }
166 |  |  |  |  | else {
167 |  |  |  |  | $^H{$_[0]} = $_[1];
168 |  |  |  |  | $^H |= $constants{$_[0]};
169 |  |  |  |  | }
170 |  |  |  |  | shift, shift;
171 |  |  |  |  | }
172 |  |  |  |  | }
173 |  |  |  |  |
174 |  |  |  |  | sub remove_constant {
175 |  |  |  |  | # Arguments: what, sub
176 |  |  |  |  | while (@_) {
177 |  |  |  |  | delete $^H{$_[0]};
178 |  |  |  |  | $^H &= ~ $constants{$_[0]};
179 |  |  |  |  | shift, shift;
180 |  |  |  |  | }
181 |  |  |  |  | }
182 |  |  |  |  |
183 | 1 | 30µs |  |  | 1;
184 |  |  |  |  |
185 |  |  |  |  | __END__