Mercurial > pub > Impl

comparison Lib/IMPL/Profiler.pm @ 194:4d0e1962161c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Replaced tabs with spaces IMPL::Web::View - fixed document model, new features (control classes, document constructor parameters)
author cin
date Tue, 10 Apr 2012 20:08:29 +0400
parents 44977efed303
children c8fe3f84feba
comparison
equal deleted inserted replaced
193:8e8401c0aea4 194:4d0e1962161c
17 $level = 0; 17 $level = 0;
18 if ($Enabled) { 18 if ($Enabled) {
19 warn "profiler enabled"; 19 warn "profiler enabled";
20 20
21 unshift @INC, sub { 21 unshift @INC, sub {
22 my ($self,$filename) = @_; 22 my ($self,$filename) = @_;
23 23
24 (my $module = $filename) =~ s/\//::/g; 24 (my $module = $filename) =~ s/\//::/g;
25 $module =~ s/\.\w+$//; 25 $module =~ s/\.\w+$//;
26 26
27 return unless $module =~ $Filter; 27 return unless $module =~ $Filter;
28 28
29 foreach my $dir (@INC) { 29 foreach my $dir (@INC) {
30 my $fullName = "$dir/$filename"; 30 my $fullName = "$dir/$filename";
31 if (-f $fullName) { 31 if (-f $fullName) {
32 open my $hmod, $fullName or die "$fullName: $!" if $!; 32 open my $hmod, $fullName or die "$fullName: $!" if $!;
33 33
34 34
35 35
36 my @source; 36 my @source;
37 local $/ = "\n"; 37 local $/ = "\n";
38 while (my $line = <$hmod>) { 38 while (my $line = <$hmod>) {
39 last if $line =~ /^\s*__END__/; 39 last if $line =~ /^\s*__END__/;
40 push @source, $line; 40 push @source, $line;
41 } 41 }
42 42
43 undef $hmod; 43 undef $hmod;
44 44
45 push @source, 45 push @source,
46 "IMPL::Profiler::trap_all(__PACKAGE__);\n", 46 "IMPL::Profiler::trap_all(__PACKAGE__);\n",
47 "1;\n"; 47 "1;\n";
48 48
49 49
50 return (sub { 50 return (sub {
51 if (@source) { 51 if (@source) {
52 $_ = shift @source; 52 $_ = shift @source;
53 return 1; 53 return 1;
54 } else { 54 } else {
55 return 0; 55 return 0;
56 } 56 }
57 }, undef ); 57 }, undef );
58 } 58 }
59 } 59 }
60 }; 60 };
61 61
62 no warnings 'once'; 62 no warnings 'once';
63 *CORE::GLOBAL::caller = sub { 63 *CORE::GLOBAL::caller = sub {
64 my $target = (shift || 0)+1; 64 my $target = (shift || 0)+1;
65 my $realFrame = 1; 65 my $realFrame = 1;
111 111
112 if (defined $proto and not $proto) { 112 if (defined $proto and not $proto) {
113 return; 113 return;
114 } 114 }
115 { 115 {
116 package IMPL::Profiler::Proxy; 116 package IMPL::Profiler::Proxy;
117 no warnings 'redefine'; 117 no warnings 'redefine';
118 my $sub = sub { 118 my $sub = sub {
119 my $t0 = [Time::HiRes::gettimeofday]; 119 my $t0 = [Time::HiRes::gettimeofday];
120 my @arr; 120 my @arr;
121 my $scalar; 121 my $scalar;
122 my $entry = $prevCode; 122 my $entry = $prevCode;
123 my ($timeOwn,$timeTotal); 123 my ($timeOwn,$timeTotal);
124 my $context = wantarray; 124 my $context = wantarray;
125 { 125 {
126 local $InvokeTime = 0; 126 local $InvokeTime = 0;
127 #warn "\t"x$level,"enter ${class}::$method"; 127 #warn "\t"x$level,"enter ${class}::$method";
128 $level ++; 128 $level ++;
129 if ($context) { 129 if ($context) {
130 @arr = &$entry(@_); 130 @arr = &$entry(@_);
131 } else { 131 } else {
132 if (defined $context) { 132 if (defined $context) {
133 $scalar = &$entry(@_); 133 $scalar = &$entry(@_);
134 } else { 134 } else {
135 &$entry(@_); 135 &$entry(@_);
136 } 136 }
137 } 137 }
138 $timeTotal = Time::HiRes::tv_interval($t0); 138 $timeTotal = Time::HiRes::tv_interval($t0);
139 $timeOwn = $timeTotal - $InvokeTime; 139 $timeOwn = $timeTotal - $InvokeTime;
140 } 140 }
141 $InvokeInfo{"${class}::${method}"}{Count} ++; 141 $InvokeInfo{"${class}::${method}"}{Count} ++;
142 $InvokeInfo{"${class}::${method}"}{Total} += $timeTotal; 142 $InvokeInfo{"${class}::${method}"}{Total} += $timeTotal;
143 $InvokeInfo{"${class}::${method}"}{Own} += $timeOwn; 143 $InvokeInfo{"${class}::${method}"}{Own} += $timeOwn;
144 $InvokeTime += $timeTotal; 144 $InvokeTime += $timeTotal;
145 $level --; 145 $level --;
146 #warn "\t"x$level,"leave ${class}::$method"; 146 #warn "\t"x$level,"leave ${class}::$method";
147 return $context ? @arr : $scalar; 147 return $context ? @arr : $scalar;
148 }; 148 };
149 if ($proto) { 149 if ($proto) {
150 Scalar::Util::set_prototype($sub => $proto); 150 Scalar::Util::set_prototype($sub => $proto);
151 } 151 }
152 *{"${class}::${method}"} = $sub; 152 *{"${class}::${method}"} = $sub;
153 } 153 }
154 154
155 } 155 }
156 156
157 sub PrintStatistics { 157 sub PrintStatistics {