line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Devel::KYTProf; |
2
|
6
|
|
|
6
|
|
397185
|
use strict; |
|
6
|
|
|
|
|
144
|
|
|
6
|
|
|
|
|
187
|
|
3
|
6
|
|
|
6
|
|
34
|
use warnings; |
|
6
|
|
|
|
|
11
|
|
|
6
|
|
|
|
|
401
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
our $VERSION = '0.9993'; |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
my $Applied = {}; |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
use Class::Data::Lite ( |
10
|
6
|
|
|
|
|
85
|
rw => { |
11
|
|
|
|
|
|
|
namespace_regex => undef, |
12
|
|
|
|
|
|
|
ignore_class_regex => undef, |
13
|
|
|
|
|
|
|
context_classes_regex => undef, |
14
|
|
|
|
|
|
|
logger => undef, |
15
|
|
|
|
|
|
|
threshold => undef, |
16
|
|
|
|
|
|
|
remove_linefeed => undef, |
17
|
|
|
|
|
|
|
remove_escape_sequences => undef, |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
color_time => 'red', |
20
|
|
|
|
|
|
|
color_module => 'cyan', |
21
|
|
|
|
|
|
|
color_info => 'blue', |
22
|
|
|
|
|
|
|
color_call => 'green', |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
_orig_code => {}, |
25
|
|
|
|
|
|
|
_prof_code => {}, |
26
|
|
|
|
|
|
|
}, |
27
|
6
|
|
|
6
|
|
2707
|
); |
|
6
|
|
|
|
|
3456
|
|
28
|
|
|
|
|
|
|
|
29
|
6
|
|
|
6
|
|
3938
|
use Module::Load (); |
|
6
|
|
|
|
|
6657
|
|
|
6
|
|
|
|
|
133
|
|
30
|
6
|
|
|
6
|
|
2857
|
use Time::HiRes; |
|
6
|
|
|
|
|
7923
|
|
|
6
|
|
|
|
|
25
|
|
31
|
6
|
|
|
6
|
|
4302
|
use Term::ANSIColor; |
|
6
|
|
|
|
|
49624
|
|
|
6
|
|
|
|
|
6897
|
|
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
sub import { |
34
|
7
|
|
|
7
|
|
74
|
__PACKAGE__->apply_prof('DBI'); |
35
|
7
|
|
|
|
|
35
|
__PACKAGE__->apply_prof('LWP::UserAgent'); |
36
|
7
|
|
|
|
|
30
|
__PACKAGE__->apply_prof('Cache::Memcached::Fast'); |
37
|
7
|
|
|
|
|
31
|
__PACKAGE__->apply_prof('MogileFS::Client'); |
38
|
7
|
|
|
|
|
34
|
__PACKAGE__->apply_prof('Furl::HTTP'); |
39
|
7
|
|
|
|
|
3565
|
1; |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
sub apply_prof { |
43
|
35
|
|
|
35
|
0
|
90
|
my ($class, $pkg, $prof_pkg, @args) = @_; |
44
|
35
|
|
|
|
|
55
|
eval { Module::Load::load($pkg) }; |
|
35
|
|
|
|
|
84
|
|
45
|
35
|
100
|
|
|
|
121983
|
return if $@; |
46
|
|
|
|
|
|
|
|
47
|
7
|
|
33
|
|
|
77
|
$prof_pkg ||= "Devel::KYTProf::Profiler::$pkg"; |
48
|
7
|
|
|
|
|
13
|
eval {Module::Load::load($prof_pkg)}; |
|
7
|
|
|
|
|
29
|
|
49
|
7
|
50
|
|
|
|
137
|
if ($@) { |
50
|
0
|
|
|
|
|
0
|
die qq{failed to load profiler package "$prof_pkg" for "$pkg": $@\n}; |
51
|
|
|
|
|
|
|
} |
52
|
7
|
50
|
|
|
|
108
|
unless ($prof_pkg->can('apply')) { |
53
|
0
|
|
|
|
|
0
|
die qq{"$prof_pkg" has no `apply` method. A profiler package should implement it.\n}; |
54
|
|
|
|
|
|
|
} |
55
|
7
|
100
|
|
|
|
42
|
return if ++$Applied->{$prof_pkg} > 1; # skip if already applied |
56
|
6
|
|
|
|
|
31
|
$prof_pkg->apply(@args); |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
sub add_profs { |
60
|
7
|
|
|
7
|
0
|
137
|
my ($class, $module, $methods, $callback, $sampler) = @_; |
61
|
7
|
|
|
|
|
30
|
eval {Module::Load::load($module)}; |
|
7
|
|
|
|
|
36
|
|
62
|
7
|
50
|
|
|
|
1899
|
if ($methods eq ':all') { |
63
|
0
|
|
|
|
|
0
|
eval { Module::Load::load('Class/Inspector.pm') }; |
|
0
|
|
|
|
|
0
|
|
64
|
0
|
0
|
|
|
|
0
|
return if $@; |
65
|
0
|
|
|
|
|
0
|
$methods = []; |
66
|
0
|
|
|
|
|
0
|
@$methods = @{Class::Inspector->methods($module, 'public')}; |
|
0
|
|
|
|
|
0
|
|
67
|
|
|
|
|
|
|
} |
68
|
7
|
|
|
|
|
22
|
for my $method (@$methods) { |
69
|
26
|
|
|
|
|
76
|
$class->add_prof($module, $method, $callback, $sampler); |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
sub add_prof { |
74
|
40
|
|
|
40
|
0
|
295
|
my ($class, $module, $method, $callback, $sampler) = @_; |
75
|
40
|
|
|
|
|
72
|
eval {Module::Load::load($module)}; |
|
40
|
|
|
|
|
97
|
|
76
|
40
|
|
|
|
|
9513
|
my $orig = $class->_orig_code->{$module}{$method}; |
77
|
40
|
50
|
|
|
|
301
|
unless ($orig) { |
78
|
40
|
50
|
|
|
|
389
|
$orig = $module->can($method) or return; |
79
|
40
|
|
|
|
|
160
|
$class->_orig_code->{$module}->{$method} = $orig; |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
my $code = sub { |
83
|
12
|
100
|
|
12
|
|
5765
|
if ($sampler) { |
84
|
3
|
|
|
|
|
10
|
my $is_sample = $sampler->($orig, @_); |
85
|
3
|
50
|
|
|
|
8
|
unless ($is_sample) { |
86
|
0
|
|
|
|
|
0
|
return $orig->(@_); |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
12
|
|
|
|
|
26
|
my ($package, $file, $line, $level); |
91
|
12
|
|
|
|
|
53
|
my $namespace_regex = $class->namespace_regex; |
92
|
12
|
|
|
|
|
73
|
my $ignore_class_regex = $class->ignore_class_regex; |
93
|
12
|
|
|
|
|
66
|
my $context_classes_regex = $class->context_classes_regex; |
94
|
12
|
|
|
|
|
63
|
my $threshold = $class->threshold; |
95
|
12
|
50
|
33
|
|
|
98
|
if ($namespace_regex || $context_classes_regex) { |
96
|
0
|
|
|
|
|
0
|
for my $i (1..30) { |
97
|
0
|
0
|
|
|
|
0
|
my ($p, $f, $l) = caller($i) or next; |
98
|
0
|
0
|
0
|
|
|
0
|
if ( |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
99
|
|
|
|
|
|
|
$namespace_regex |
100
|
|
|
|
|
|
|
&& |
101
|
|
|
|
|
|
|
!$package |
102
|
|
|
|
|
|
|
&& |
103
|
|
|
|
|
|
|
$p =~ /^($namespace_regex)/ |
104
|
|
|
|
|
|
|
&& |
105
|
|
|
|
|
|
|
(! $ignore_class_regex || $p !~ /$ignore_class_regex/) |
106
|
|
|
|
|
|
|
) { |
107
|
0
|
|
|
|
|
0
|
($package, $file, $line) = ($p, $f, $l); |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
0
|
0
|
0
|
|
|
0
|
if ($context_classes_regex && !$level && $p =~ /^($context_classes_regex)$/) { |
|
|
|
0
|
|
|
|
|
111
|
0
|
|
|
|
|
0
|
$level = $i; |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
} else { |
115
|
12
|
|
|
|
|
45
|
for my $i (1..30) { |
116
|
360
|
50
|
|
|
|
691
|
my ($p, $f, $l) = caller($i) or next; |
117
|
0
|
0
|
|
|
|
0
|
if ($p !~ /^($module)/) { |
118
|
0
|
|
|
|
|
0
|
($package, $file, $line) = ($p, $f, $l); |
119
|
0
|
|
|
|
|
0
|
last; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
} |
123
|
12
|
50
|
|
|
|
29
|
unless ($package) { |
124
|
12
|
|
|
|
|
39
|
($package, $file, $line) = caller; |
125
|
|
|
|
|
|
|
} |
126
|
12
|
|
|
|
|
72
|
my $start = [ Time::HiRes::gettimeofday ]; |
127
|
12
|
|
|
|
|
25
|
my ($res, @res); |
128
|
12
|
50
|
|
|
|
26
|
if (wantarray) { |
129
|
0
|
|
|
|
|
0
|
@res = $orig->(@_); |
130
|
|
|
|
|
|
|
} else { |
131
|
12
|
|
|
|
|
37
|
$res = $orig->(@_); |
132
|
|
|
|
|
|
|
} |
133
|
12
|
|
|
|
|
1938
|
my $ns = Time::HiRes::tv_interval($start) * 1000; |
134
|
12
|
50
|
33
|
|
|
211
|
if (!$threshold || $ns >= $threshold) { |
135
|
12
|
|
|
|
|
22
|
my $message = ""; |
136
|
12
|
|
|
|
|
159
|
$message .= colored(sprintf('% 9.3f ms ', $ns), $class->color_time); |
137
|
12
|
|
50
|
|
|
340
|
$message .= colored(sprintf(' [%s] ', ref $_[0] || $_[0] || ''), $class->color_module); |
138
|
12
|
|
|
|
|
253
|
my $cb_info; |
139
|
|
|
|
|
|
|
my $cb_data; |
140
|
12
|
100
|
|
|
|
30
|
if ($callback) { |
141
|
7
|
|
|
|
|
24
|
my $v = $callback->($orig, @_); |
142
|
7
|
100
|
|
|
|
47
|
if (ref $v eq "ARRAY") { |
143
|
6
|
|
|
|
|
14
|
$cb_info = sprintf $v->[0], map { $v->[2]->{$_} } @{$v->[1]}; |
|
12
|
|
|
|
|
40
|
|
|
6
|
|
|
|
|
16
|
|
144
|
6
|
|
|
|
|
19
|
$cb_data = $v->[2]; |
145
|
|
|
|
|
|
|
} else { |
146
|
1
|
|
|
|
|
2
|
$cb_info = $v; |
147
|
1
|
|
|
|
|
2
|
$cb_data = {}; |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
} else { |
150
|
5
|
|
|
|
|
7
|
$cb_info = $method; |
151
|
5
|
|
|
|
|
9
|
$cb_data = {}; |
152
|
|
|
|
|
|
|
} |
153
|
12
|
100
|
|
|
|
37
|
$cb_info =~ s/[[:cntrl:]]//smg if $class->remove_escape_sequences; |
154
|
12
|
|
|
|
|
94
|
$message .= colored(sprintf(' %s ', $cb_info), $class->color_info); |
155
|
12
|
|
|
|
|
197
|
$message .= ' | '; |
156
|
12
|
|
50
|
|
|
66
|
$message .= colored(sprintf('%s:%d', $package || '', $line || 0), $class->color_call); |
|
|
|
50
|
|
|
|
|
157
|
12
|
50
|
|
|
|
191
|
$message =~ s/\n/ /g if $class->remove_linefeed; |
158
|
12
|
|
|
|
|
63
|
$message .= "\n"; |
159
|
12
|
50
|
|
|
|
30
|
$class->logger ? $class->logger->log( |
160
|
|
|
|
|
|
|
level => 'debug', |
161
|
|
|
|
|
|
|
message => $message, |
162
|
|
|
|
|
|
|
module => $module, |
163
|
|
|
|
|
|
|
method => $method, |
164
|
|
|
|
|
|
|
time => $ns, |
165
|
|
|
|
|
|
|
package => $package, |
166
|
|
|
|
|
|
|
file => $file, |
167
|
|
|
|
|
|
|
line => $line, |
168
|
|
|
|
|
|
|
data => $cb_data, |
169
|
|
|
|
|
|
|
) : print STDERR $message; |
170
|
|
|
|
|
|
|
} |
171
|
12
|
50
|
|
|
|
133
|
return wantarray ? @res : $res; |
172
|
40
|
|
|
|
|
529
|
}; |
173
|
40
|
|
|
|
|
149
|
$class->_prof_code->{$module}->{$method} = $code; |
174
|
|
|
|
|
|
|
|
175
|
40
|
|
|
|
|
257
|
$class->_inject_code($module, $method, $code); |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
sub _inject_code { |
179
|
46
|
|
|
46
|
|
167
|
my ($class, $module, $method, $code) = @_; |
180
|
6
|
|
|
6
|
|
56
|
no strict 'refs'; |
|
6
|
|
|
|
|
15
|
|
|
6
|
|
|
|
|
290
|
|
181
|
6
|
|
|
6
|
|
40
|
no warnings qw/redefine prototype/; |
|
6
|
|
|
|
|
12
|
|
|
6
|
|
|
|
|
1663
|
|
182
|
46
|
|
|
|
|
121
|
*{"$module\::$method"} = $code; |
|
46
|
|
|
|
|
282
|
|
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
sub mute { |
186
|
2
|
|
|
2
|
0
|
1563
|
my ($class, $module, @methods) = @_; |
187
|
|
|
|
|
|
|
|
188
|
2
|
100
|
|
|
|
7
|
if (scalar(@methods)) { |
189
|
1
|
|
|
|
|
3
|
for my $method (@methods) { |
190
|
1
|
|
|
|
|
14
|
$class->_inject_code($module, $method, $class->_orig_code->{$module}->{$method}); |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
} else { |
193
|
1
|
|
|
|
|
2
|
for my $method (keys %{$class->_orig_code->{$module}}) { |
|
1
|
|
|
|
|
4
|
|
194
|
2
|
|
|
|
|
13
|
$class->_inject_code($module, $method, $class->_orig_code->{$module}->{$method}); |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
sub unmute { |
200
|
2
|
|
|
2
|
0
|
1110
|
my ($class, $module, @methods) = @_; |
201
|
|
|
|
|
|
|
|
202
|
2
|
100
|
|
|
|
8
|
if (scalar(@methods)) { |
203
|
1
|
|
|
|
|
3
|
for my $method (@methods) { |
204
|
1
|
|
|
|
|
5
|
$class->_inject_code($module, $method, $class->_prof_code->{$module}->{$method}); |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
} else { |
207
|
1
|
|
|
|
|
2
|
for my $method (keys %{$class->_prof_code->{$module}}) { |
|
1
|
|
|
|
|
4
|
|
208
|
2
|
|
|
|
|
16
|
$class->_inject_code($module, $method, $class->_prof_code->{$module}->{$method}); |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
{ |
214
|
6
|
|
|
6
|
|
59
|
no warnings 'redefine'; |
|
6
|
|
|
|
|
12
|
|
|
6
|
|
|
|
|
467
|
|
215
|
|
|
|
0
|
|
|
*DB::DB = sub {}; |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
1; |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
__END__ |