Mercurial > pub > Impl

comparison lib/IMPL/Profiler.pm @ 407:c6e90e02dd17 ref20150831

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
renamed Lib->lib
author cin
date Fri, 04 Sep 2015 19:40:23 +0300
parents
children
comparison
equal deleted inserted replaced
406:f23fcb19d3c1 407:c6e90e02dd17
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;