Mercurial > pub > Impl

comparison Lib/IMPL/Profiler.pm @ 0:03e58a454b20

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Создан репозитарий
author Sergey
date Tue, 14 Jul 2009 12:54:37 +0400
parents
children 16ada169ca75
comparison
equal deleted inserted replaced
-1:000000000000 0:03e58a454b20
1 package IMPL::Profiler;
2
3 our $Enabled;
4 our %TrappedModules;
5 our %InvokeInfo;
6 our $InvokeTime = 0;
7 my $level;
8
9 BEGIN {
10 $level = 0;
11 if ($Enabled) {
12 warn "profiler enabled";
13 no warnings 'once';
14 *CORE::GLOBAL::caller = sub {
15 my $target = (shift || 0)+1;
16 my $realFrame = 1;
17
18 for (my $i = 1; $i<$target; $i++) {
19 $realFrame ++;
20 my $caller = CORE::caller($realFrame-1) or return;
21 $realFrame ++ if $caller eq 'IMPL::Profiler::Proxy'; #current frame is proxy
22 }
23
24 my @frame = CORE::caller($realFrame) or return;
25 if ( $frame[0] eq 'IMPL::Profiler::Proxy' ) {
26 my @next = CORE::caller($realFrame+1) or return;
27 @frame[0..2] = @next[0..2];
28 }
29
30 #warn "\t"x$level,"$frame[0] - $frame[3]";
31 return wantarray ? @frame : $frame[0];
32 };
33 }
34 }
35 use strict;
36 use warnings;
37 use Time::HiRes;
38 require Scalar::Util;
39
40
41
42 sub trap_all {
43 return if not $Enabled;
44 no strict 'refs';
45 foreach my $class (@_) {
46 next if $TrappedModules{$class};
47 $TrappedModules{$class} = 1;
48
49 eval "warn 'load $class'; require $class;" if not %{"${class}::"};
50 die $@ if $@;
51
52 no strict 'refs';
53 my $table = \%{"${class}::"};
54 trap($class,$_) foreach (grep *{$table->{$_}}{CODE}, keys %$table);
55 }
56 }
57
58 sub trap {
59 my ($class,$method) = @_;
60
61 return if not $Enabled;
62
63 no strict 'refs';
64 my $prevCode = \&{"${class}::${method}"};
65 my $proto = prototype $prevCode;
66
67 if (defined $proto and not $proto) {
68 return;
69 }
70 {
71 package IMPL::Profiler::Proxy;
72 no warnings 'redefine';
73 my $sub = sub {
74 my $t0 = [Time::HiRes::gettimeofday];
75 my @arr;
76 my $scalar;
77 my $entry = $prevCode;
78 my ($timeOwn,$timeTotal);
79 my $context = wantarray;
80 {
81 local $InvokeTime = 0;
82 #warn "\t"x$level,"enter ${class}::$method";
83 $level ++;
84 if ($context) {
85 @arr = &$entry(@_);
86 } else {
87 if (defined $context) {
88 $scalar = &$entry(@_);
89 } else {
90 &$entry(@_);
91 }
92 }
93 $timeTotal = Time::HiRes::tv_interval($t0);
94 $timeOwn = $timeTotal - $InvokeTime;
95 }
96 $InvokeInfo{"${class}::${method}"}{Count} ++;
97 $InvokeInfo{"${class}::${method}"}{Total} += $timeTotal;
98 $InvokeInfo{"${class}::${method}"}{Own} += $timeOwn;
99 $InvokeTime += $timeTotal;
100 $level --;
101 #warn "\t"x$level,"leave ${class}::$method";
102 return $context ? @arr : $scalar;
103 };
104 if ($proto) {
105 Scalar::Util::set_prototype($sub => $proto);
106 }
107 *{"${class}::${method}"} = $sub;
108 }
109
110 }
111
112 sub PrintStatistics {
113 my $hout = shift || *STDERR;
114 print $hout "-- modules --\n";
115 print $hout "$_\n" foreach sort keys %TrappedModules;
116 print $hout "\n-- stats --\n";
117 print $hout
118 pad($_,50),
119 pad("$InvokeInfo{$_}{Count}",10),
120 pad(sprintf("%.3f",$InvokeInfo{$_}{Own}),10),
121 pad(sprintf("%.3f",$InvokeInfo{$_}{Total}),10),
122 "\n"
123 foreach sort { $InvokeInfo{$b}{Own} <=> $InvokeInfo{$a}{Own} } keys %InvokeInfo;
124 }
125
126 sub ResetStatistics {
127 $InvokeTime = 0;
128 %InvokeInfo = ();
129 }
130
131 sub pad {
132 my ($str,$len) = @_;
133 if (length $str < $len) {
134 return $str.(' 'x ($len- length $str));
135 } else {
136 return $str;
137 }
138 }
139 1;