|
407
|
1 package IMPL::Profiler;
|
|
|
2
|
|
|
3 use strict;
|
|
|
4 use warnings;
|
|
|
5 use Time::HiRes;
|
|
|
6 require Scalar::Util;
|
|
|
7
|
|
|
8 our $Enabled;
|
|
|
9 our %TrappedModules;
|
|
|
10 our %InvokeInfo;
|
|
|
11 our $InvokeTime = 0;
|
|
|
12 our @TrapQueue;
|
|
|
13 our $Filter ||= qr//;
|
|
|
14 my $level;
|
|
|
15
|
|
|
16 BEGIN {
|
|
|
17 $level = 0;
|
|
|
18 if ($Enabled) {
|
|
|
19 warn "profiler enabled";
|
|
|
20
|
|
|
21 unshift @INC, sub {
|
|
|
22 my ($self,$filename) = @_;
|
|
|
23
|
|
|
24 (my $module = $filename) =~ s/\//::/g;
|
|
|
25 $module =~ s/\.\w+$//;
|
|
|
26
|
|
|
27 return unless $module =~ $Filter;
|
|
|
28
|
|
|
29 foreach my $dir (@INC) {
|
|
|
30 my $fullName = "$dir/$filename";
|
|
|
31 if (-f $fullName) {
|
|
|
32 open my $hmod, $fullName or die "$fullName: $!" if $!;
|
|
|
33
|
|
|
34
|
|
|
35
|
|
|
36 my @source;
|
|
|
37 local $/ = "\n";
|
|
|
38 while (my $line = <$hmod>) {
|
|
|
39 last if $line =~ /^\s*__END__/;
|
|
|
40 push @source, $line;
|
|
|
41 }
|
|
|
42
|
|
|
43 undef $hmod;
|
|
|
44
|
|
|
45 push @source,
|
|
|
46 "IMPL::Profiler::trap_all(__PACKAGE__);\n",
|
|
|
47 "1;\n";
|
|
|
48
|
|
|
49
|
|
|
50 return (sub {
|
|
|
51 if (@source) {
|
|
|
52 $_ = shift @source;
|
|
|
53 return 1;
|
|
|
54 } else {
|
|
|
55 return 0;
|
|
|
56 }
|
|
|
57 }, undef );
|
|
|
58 }
|
|
|
59 }
|
|
|
60 };
|
|
|
61
|
|
|
62 no warnings 'once';
|
|
|
63 *CORE::GLOBAL::caller = sub {
|
|
|
64 my $target = (shift || 0)+1;
|
|
|
65 my $realFrame = 1;
|
|
|
66
|
|
|
67 for (my $i = 1; $i<$target; $i++) {
|
|
|
68 $realFrame ++;
|
|
|
69 my $caller = CORE::caller($realFrame-1) or return;
|
|
|
70 $realFrame ++ if $caller eq 'IMPL::Profiler::Proxy'; #current frame is proxy
|
|
|
71 }
|
|
|
72
|
|
|
73 my @frame = CORE::caller($realFrame) or return;
|
|
|
74 if ( $frame[0] eq 'IMPL::Profiler::Proxy' ) {
|
|
|
75 my @next = CORE::caller($realFrame+1) or return;
|
|
|
76 @frame[0..2] = @next[0..2];
|
|
|
77 }
|
|
|
78
|
|
|
79 #warn " "x$level,"$frame[0] - $frame[3]";
|
|
|
80 return wantarray ? @frame : $frame[0];
|
|
|
81 };
|
|
|
82 }
|
|
|
83 }
|
|
|
84
|
|
|
85 sub trap_all {
|
|
|
86 return if not $Enabled;
|
|
|
87 no strict 'refs';
|
|
|
88 foreach my $class (@_) {
|
|
|
89 next if $TrappedModules{$class};
|
|
|
90 $TrappedModules{$class} = 1;
|
|
|
91
|
|
|
92 eval "warn 'load $class'; require $class;" if not %{"${class}::"};
|
|
|
93 die $@ if $@;
|
|
|
94
|
|
|
95 no strict 'refs';
|
|
|
96 my $table = \%{"${class}::"};
|
|
|
97 trap($class,$_) foreach (grep eval { *{$table->{$_}}{CODE} }, keys %$table); # here can be a not a GLOB reference
|
|
|
98 }
|
|
|
99 }
|
|
|
100
|
|
|
101 sub trap {
|
|
|
102 my ($class,$method) = @_;
|
|
|
103
|
|
|
104 return if not $Enabled;
|
|
|
105
|
|
|
106 return if $method eq 'import';
|
|
|
107
|
|
|
108 no strict 'refs';
|
|
|
109 my $prevCode = \&{"${class}::${method}"};
|
|
|
110 my $proto = prototype $prevCode;
|
|
|
111
|
|
|
112 if (defined $proto and not $proto) {
|
|
|
113 return;
|
|
|
114 }
|
|
|
115 {
|
|
|
116 package IMPL::Profiler::Proxy;
|
|
|
117 no warnings 'redefine';
|
|
|
118 my $sub = sub {
|
|
|
119 my $t0 = [Time::HiRes::gettimeofday];
|
|
|
120 my @arr;
|
|
|
121 my $scalar;
|
|
|
122 my $entry = $prevCode;
|
|
|
123 my ($timeOwn,$timeTotal);
|
|
|
124 my $context = wantarray;
|
|
|
125 {
|
|
|
126 local $InvokeTime = 0;
|
|
|
127 #warn " "x$level,"enter ${class}::$method";
|
|
|
128 $level ++;
|
|
|
129 if ($context) {
|
|
|
130 @arr = &$entry(@_);
|
|
|
131 } else {
|
|
|
132 if (defined $context) {
|
|
|
133 $scalar = &$entry(@_);
|
|
|
134 } else {
|
|
|
135 &$entry(@_);
|
|
|
136 }
|
|
|
137 }
|
|
|
138 $timeTotal = Time::HiRes::tv_interval($t0);
|
|
|
139 $timeOwn = $timeTotal - $InvokeTime;
|
|
|
140 }
|
|
|
141 $InvokeInfo{"${class}::${method}"}{Count} ++;
|
|
|
142 $InvokeInfo{"${class}::${method}"}{Total} += $timeTotal;
|
|
|
143 $InvokeInfo{"${class}::${method}"}{Own} += $timeOwn;
|
|
|
144 $InvokeTime += $timeTotal;
|
|
|
145 $level --;
|
|
|
146 #warn " "x$level,"leave ${class}::$method";
|
|
|
147 return $context ? @arr : $scalar;
|
|
|
148 };
|
|
|
149 if ($proto) {
|
|
|
150 Scalar::Util::set_prototype($sub => $proto);
|
|
|
151 }
|
|
|
152 *{"${class}::${method}"} = $sub;
|
|
|
153 }
|
|
|
154
|
|
|
155 }
|
|
|
156
|
|
|
157 sub PrintStatistics {
|
|
|
158 my $hout = shift || *STDERR;
|
|
|
159 print $hout "-- modules --\n";
|
|
|
160 print $hout "$_\n" foreach sort keys %TrappedModules;
|
|
|
161 print $hout "\n-- stats --\n";
|
|
|
162 print $hout
|
|
|
163 pad($_,50),
|
|
|
164 pad("$InvokeInfo{$_}{Count}",10),
|
|
|
165 pad(sprintf("%.3f",$InvokeInfo{$_}{Own}),10),
|
|
|
166 pad(sprintf("%.3f",$InvokeInfo{$_}{Total}),10),
|
|
|
167 "\n"
|
|
|
168 foreach sort { $InvokeInfo{$b}{Own} <=> $InvokeInfo{$a}{Own} } keys %InvokeInfo;
|
|
|
169 }
|
|
|
170
|
|
|
171 sub ResetStatistics {
|
|
|
172 $InvokeTime = 0;
|
|
|
173 %InvokeInfo = ();
|
|
|
174 }
|
|
|
175
|
|
|
176 sub pad {
|
|
|
177 my ($str,$len) = @_;
|
|
|
178 if (length $str < $len) {
|
|
|
179 return $str.(' 'x ($len- length $str));
|
|
|
180 } else {
|
|
|
181 return $str;
|
|
|
182 }
|
|
|
183 }
|
|
|
184 1;
|
