Mercurial > pub > Impl

comparison Lib/IMPL/Profiler.pm @ 134:44977efed303

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Significant performance optimizations Fixed recursion problems due converting objects to JSON Added cache support for the templates Added discovery feature for the web methods
author wizard
date Mon, 21 Jun 2010 02:39:53 +0400
parents 16ada169ca75
children 4d0e1962161c
comparison
equal deleted inserted replaced
133:a07a66fd8d5c 134:44977efed303
1 package IMPL::Profiler; 1 package IMPL::Profiler;
2
3 use strict;
4 use warnings;
5 use Time::HiRes;
6 require Scalar::Util;
2 7
3 our $Enabled; 8 our $Enabled;
4 our %TrappedModules; 9 our %TrappedModules;
5 our %InvokeInfo; 10 our %InvokeInfo;
6 our $InvokeTime = 0; 11 our $InvokeTime = 0;
12 our @TrapQueue;
13 our $Filter ||= qr//;
7 my $level; 14 my $level;
8 15
9 BEGIN { 16 BEGIN {
10 $level = 0; 17 $level = 0;
11 if ($Enabled) { 18 if ($Enabled) {
12 warn "profiler 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
13 no warnings 'once'; 62 no warnings 'once';
14 *CORE::GLOBAL::caller = sub { 63 *CORE::GLOBAL::caller = sub {
15 my $target = (shift || 0)+1; 64 my $target = (shift || 0)+1;
16 my $realFrame = 1; 65 my $realFrame = 1;
17 66
30 #warn "\t"x$level,"$frame[0] - $frame[3]"; 79 #warn "\t"x$level,"$frame[0] - $frame[3]";
31 return wantarray ? @frame : $frame[0]; 80 return wantarray ? @frame : $frame[0];
32 }; 81 };
33 } 82 }
34 } 83 }
35 use strict;
36 use warnings;
37 use Time::HiRes;
38 require Scalar::Util;
39
40
41 84
42 sub trap_all { 85 sub trap_all {
43 return if not $Enabled; 86 return if not $Enabled;
44 no strict 'refs'; 87 no strict 'refs';
45 foreach my $class (@_) { 88 foreach my $class (@_) {
49 eval "warn 'load $class'; require $class;" if not %{"${class}::"}; 92 eval "warn 'load $class'; require $class;" if not %{"${class}::"};
50 die $@ if $@; 93 die $@ if $@;
51 94
52 no strict 'refs'; 95 no strict 'refs';
53 my $table = \%{"${class}::"}; 96 my $table = \%{"${class}::"};
54 trap($class,$_) foreach (grep *{$table->{$_}}{CODE}, keys %$table); 97 trap($class,$_) foreach (grep eval { *{$table->{$_}}{CODE} }, keys %$table); # here can be a not a GLOB reference
55 } 98 }
56 } 99 }
57 100
58 sub trap { 101 sub trap {
59 my ($class,$method) = @_; 102 my ($class,$method) = @_;
60 103
61 return if not $Enabled; 104 return if not $Enabled;
105
106 return if $method eq 'import';
62 107
63 no strict 'refs'; 108 no strict 'refs';
64 my $prevCode = \&{"${class}::${method}"}; 109 my $prevCode = \&{"${class}::${method}"};
65 my $proto = prototype $prevCode; 110 my $proto = prototype $prevCode;
66 111
67 if (defined $proto and not $proto) { 112 if (defined $proto and not $proto) {
68 return; 113 return;
69 } 114 }
70 { 115 {
71 package IMPL::Profiler::Proxy; 116 package IMPL::Profiler::Proxy;
72 no warnings 'redefine'; 117 no warnings 'redefine';
73 my $sub = sub { 118 my $sub = sub {
74 my $t0 = [Time::HiRes::gettimeofday]; 119 my $t0 = [Time::HiRes::gettimeofday];
75 my @arr; 120 my @arr;
76 my $scalar; 121 my $scalar;
77 my $entry = $prevCode; 122 my $entry = $prevCode;
78 my ($timeOwn,$timeTotal); 123 my ($timeOwn,$timeTotal);
79 my $context = wantarray; 124 my $context = wantarray;
80 { 125 {
81 local $InvokeTime = 0; 126 local $InvokeTime = 0;
82 #warn "\t"x$level,"enter ${class}::$method"; 127 #warn "\t"x$level,"enter ${class}::$method";
83 $level ++; 128 $level ++;
84 if ($context) { 129 if ($context) {
85 @arr = &$entry(@_); 130 @arr = &$entry(@_);
86 } else { 131 } else {
87 if (defined $context) { 132 if (defined $context) {
88 $scalar = &$entry(@_); 133 $scalar = &$entry(@_);
89 } else { 134 } else {
90 &$entry(@_); 135 &$entry(@_);
91 } 136 }
92 } 137 }
93 $timeTotal = Time::HiRes::tv_interval($t0); 138 $timeTotal = Time::HiRes::tv_interval($t0);
94 $timeOwn = $timeTotal - $InvokeTime; 139 $timeOwn = $timeTotal - $InvokeTime;
95 } 140 }
96 $InvokeInfo{"${class}::${method}"}{Count} ++; 141 $InvokeInfo{"${class}::${method}"}{Count} ++;
97 $InvokeInfo{"${class}::${method}"}{Total} += $timeTotal; 142 $InvokeInfo{"${class}::${method}"}{Total} += $timeTotal;
98 $InvokeInfo{"${class}::${method}"}{Own} += $timeOwn; 143 $InvokeInfo{"${class}::${method}"}{Own} += $timeOwn;
99 $InvokeTime += $timeTotal; 144 $InvokeTime += $timeTotal;
100 $level --; 145 $level --;
101 #warn "\t"x$level,"leave ${class}::$method"; 146 #warn "\t"x$level,"leave ${class}::$method";
102 return $context ? @arr : $scalar; 147 return $context ? @arr : $scalar;
103 }; 148 };
104 if ($proto) { 149 if ($proto) {
105 Scalar::Util::set_prototype($sub => $proto); 150 Scalar::Util::set_prototype($sub => $proto);
106 } 151 }
107 *{"${class}::${method}"} = $sub; 152 *{"${class}::${method}"} = $sub;
108 } 153 }
109 154
110 } 155 }
111 156
112 sub PrintStatistics { 157 sub PrintStatistics {