← Index
Performance Profile   « block view • line view • sub view »
For t/test-parsing
  Run on Sun Nov 14 09:49:57 2010
Reported on Sun Nov 14 09:50:08 2010

File /usr/share/perl/5.10/overload.pm
Statements Executed 182
Total Time 0.0008163 seconds
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1011423µs423µsoverload::::OVERLOADoverload::OVERLOAD
101010146µs568µsoverload::::importoverload::import
0000s0soverload::::AddrRefoverload::AddrRef
0000s0soverload::::BEGINoverload::BEGIN
0000s0soverload::::Methodoverload::Method
0000s0soverload::::Overloadedoverload::Overloaded
0000s0soverload::::OverloadedStringifyoverload::OverloadedStringify
0000s0soverload::::constantoverload::constant
0000s0soverload::::mycanoverload::mycan
0000s0soverload::::niloverload::nil
0000s0soverload::::ov_methodoverload::ov_method
0000s0soverload::::remove_constantoverload::remove_constant
0000s0soverload::::unimportoverload::unimport
LineStmts.Exclusive
Time
Avg.Code
1package overload;
2
31800ns800nsour $VERSION = '1.06';
4
5sub nil {}
6
7
# spent 423µs within overload::OVERLOAD which was called 10 times, avg 42µs/call: # 10 times (423µs+0s) by overload::import at line 33, avg 42µs/call
sub OVERLOAD {
870248µs4µs $package = shift;
9 my %arg = @_;
10 my ($sub, $fb);
11 $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching.
12 *{$package . "::()"} = \&nil; # Make it findable via fetchmethod.
13 for (keys %arg) {
1472144µs2µs if ($_ eq 'fallback') {
15 $fb = $arg{$_};
16 } else {
17 $sub = $arg{$_};
1825µs2µs if (not ref $sub and $sub !~ /::/) {
19 $ {$package . "::(" . $_} = $sub;
20 $sub = \&nil;
21 }
22 #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n";
23 *{$package . "::(" . $_} = \&{ $sub };
24 }
25 }
26 ${$package . "::()"} = $fb; # Make it findable too (fallback only).
27}
28
29
# spent 568µs (146+423) within overload::import which was called 10 times, avg 57µs/call: # once (15µs+56µs) at line 11 of /usr/local/lib/perl/5.10.0/Moose/Meta/TypeConstraint.pm # once (16µs+51µs) by XML::LibXML::Number::BEGIN at line 12 of /usr/lib/perl5/XML/LibXML/Number.pm # once (15µs+52µs) by XML::LibXML::Literal::BEGIN at line 12 of /usr/lib/perl5/XML/LibXML/Literal.pm # once (14µs+45µs) at line 5 of /usr/share/perl5/XML/SAX/Exception.pm # once (19µs+37µs) at line 9 of /usr/local/lib/perl/5.10.0/Moose/Meta/Role/Method/Required.pm # once (14µs+39µs) by MARC::Moose::Field::Std::BEGIN at line 10 of /home/tamil/util/marc-moose/lib/MARC/Moose/Field/Std.pm # once (14µs+39µs) by XML::LibXML::NodeList::BEGIN at line 13 of /usr/lib/perl5/XML/LibXML/NodeList.pm # once (14µs+36µs) by YAML::Tag::BEGIN or YAML::Tag::__ANON__[/usr/share/perl5/YAML/Tag.pm:4] at line 4 of /usr/share/perl5/YAML/Tag.pm # once (12µs+35µs) by Class::MOP::Method::BEGIN or Class::MOP::Method::__ANON__[/usr/local/lib/perl/5.10.0/Class/MOP/Method.pm:19] at line 19 of /usr/local/lib/perl/5.10.0/Class/MOP/Method.pm # once (14µs+32µs) by XML::LibXML::Boolean::BEGIN at line 14 of /usr/lib/perl5/XML/LibXML/Boolean.pm
sub import {
3030106µs4µs $package = (caller())[0];
31 # *{$package . "::OVERLOAD"} = \&OVERLOAD;
32 shift;
33 $package->overload::OVERLOAD(@_);
# spent 423µs making 10 calls to overload::OVERLOAD, avg 42µs/call
34}
35
36sub unimport {
37 $package = (caller())[0];
38 ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table
39 shift;
40 for (@_) {
41 if ($_ eq 'fallback') {
42 undef $ {$package . "::()"};
43 } else {
44 delete $ {$package . "::"}{"(" . $_};
45 }
46 }
47}
48
49sub Overloaded {
50 my $package = shift;
51 $package = ref $package if ref $package;
52 $package->can('()');
53}
54
55sub ov_method {
56 my $globref = shift;
57 return undef unless $globref;
58 my $sub = \&{*$globref};
59 return $sub if $sub ne \&nil;
60 return shift->can($ {*$globref});
61}
62
63sub OverloadedStringify {
64 my $package = shift;
65 $package = ref $package if ref $package;
66 #$package->can('(""')
67 ov_method mycan($package, '(""'), $package
68 or ov_method mycan($package, '(0+'), $package
69 or ov_method mycan($package, '(bool'), $package
70 or ov_method mycan($package, '(nomethod'), $package;
71}
72
73sub Method {
74 my $package = shift;
75 if(ref $package) {
76 local $@;
77 local $!;
78 require Scalar::Util;
79 $package = Scalar::Util::blessed($package);
80 return undef if !defined $package;
81 }
82 #my $meth = $package->can('(' . shift);
83 ov_method mycan($package, '(' . shift), $package;
84 #return $meth if $meth ne \&nil;
85 #return $ {*{$meth}};
86}
87
88sub AddrRef {
89 my $package = ref $_[0];
90 return "$_[0]" unless $package;
91
92 local $@;
93 local $!;
94 require Scalar::Util;
95 my $class = Scalar::Util::blessed($_[0]);
96 my $class_prefix = defined($class) ? "$class=" : "";
97 my $type = Scalar::Util::reftype($_[0]);
98 my $addr = Scalar::Util::refaddr($_[0]);
99 return sprintf("$class_prefix$type(0x%x)", $addr);
100}
101
10212µs2µs*StrVal = *AddrRef;
103
104sub mycan { # Real can would leave stubs.
105 my ($package, $meth) = @_;
106
107 my $mro = mro::get_linear_isa($package);
108 foreach my $p (@$mro) {
109 my $fqmeth = $p . q{::} . $meth;
110 return \*{$fqmeth} if defined &{$fqmeth};
111 }
112
113 return undef;
114}
115
11613µs3µs%constants = (
117 'integer' => 0x1000, # HINT_NEW_INTEGER
118 'float' => 0x2000, # HINT_NEW_FLOAT
119 'binary' => 0x4000, # HINT_NEW_BINARY
120 'q' => 0x8000, # HINT_NEW_STRING
121 'qr' => 0x10000, # HINT_NEW_RE
122 );
123
12419µs9µs%ops = ( with_assign => "+ - * / % ** << >> x .",
125 assign => "+= -= *= /= %= **= <<= >>= x= .=",
126 num_comparison => "< <= > >= == !=",
127 '3way_comparison'=> "<=> cmp",
128 str_comparison => "lt le gt ge eq ne",
129 binary => '& &= | |= ^ ^=',
130 unary => "neg ! ~",
131 mutators => '++ --',
132 func => "atan2 cos sin exp abs log sqrt int",
133 conversion => 'bool "" 0+',
134 iterators => '<>',
135 dereferencing => '${} @{} %{} &{} *{}',
136 special => 'nomethod fallback =');
137
1383290µs97µsuse warnings::register;
# spent 101µs making 1 call to warnings::register::import
139sub constant {
140 # Arguments: what, sub
141 while (@_) {
142 if (@_ == 1) {
143 warnings::warnif ("Odd number of arguments for overload::constant");
144 last;
145 }
146 elsif (!exists $constants {$_ [0]}) {
147 warnings::warnif ("`$_[0]' is not an overloadable type");
148 }
149 elsif (!ref $_ [1] || "$_[1]" !~ /CODE\(0x[\da-f]+\)$/) {
150 # Can't use C<ref $_[1] eq "CODE"> above as code references can be
151 # blessed, and C<ref> would return the package the ref is blessed into.
152 if (warnings::enabled) {
153 $_ [1] = "undef" unless defined $_ [1];
154 warnings::warn ("`$_[1]' is not a code reference");
155 }
156 }
157 else {
158 $^H{$_[0]} = $_[1];
159 $^H |= $constants{$_[0]};
160 }
161 shift, shift;
162 }
163}
164
165sub remove_constant {
166 # Arguments: what, sub
167 while (@_) {
168 delete $^H{$_[0]};
169 $^H &= ~ $constants{$_[0]};
170 shift, shift;
171 }
172}
173
174111µs11µs1;
175
176__END__
177