File Coverage

blib/lib/Devel/KYTProf.pm
Criterion Covered Total %
statement 119 138 86.2
branch 30 54 55.5
condition 6 33 18.1
subroutine 17 18 94.4
pod 0 5 0.0
total 172 248 69.3


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__