Mercurial > pub > Impl
diff Lib/IMPL/Profiler.pm @ 49:16ada169ca75
migrating to the Eclipse IDE
author | wizard@linux-odin.local |
---|---|
date | Fri, 26 Feb 2010 10:49:21 +0300 |
parents | 03e58a454b20 |
children | 44977efed303 |
line wrap: on
line diff
--- a/Lib/IMPL/Profiler.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Profiler.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,139 +1,139 @@ -package IMPL::Profiler; - -our $Enabled; -our %TrappedModules; -our %InvokeInfo; -our $InvokeTime = 0; -my $level; - -BEGIN { - $level = 0; - if ($Enabled) { - warn "profiler enabled"; - no warnings 'once'; - *CORE::GLOBAL::caller = sub { - my $target = (shift || 0)+1; - my $realFrame = 1; - - for (my $i = 1; $i<$target; $i++) { - $realFrame ++; - my $caller = CORE::caller($realFrame-1) or return; - $realFrame ++ if $caller eq 'IMPL::Profiler::Proxy'; #current frame is proxy - } - - my @frame = CORE::caller($realFrame) or return; - if ( $frame[0] eq 'IMPL::Profiler::Proxy' ) { - my @next = CORE::caller($realFrame+1) or return; - @frame[0..2] = @next[0..2]; - } - - #warn "\t"x$level,"$frame[0] - $frame[3]"; - return wantarray ? @frame : $frame[0]; - }; - } -} -use strict; -use warnings; -use Time::HiRes; -require Scalar::Util; - - - -sub trap_all { - return if not $Enabled; - no strict 'refs'; - foreach my $class (@_) { - next if $TrappedModules{$class}; - $TrappedModules{$class} = 1; - - eval "warn 'load $class'; require $class;" if not %{"${class}::"}; - die $@ if $@; - - no strict 'refs'; - my $table = \%{"${class}::"}; - trap($class,$_) foreach (grep *{$table->{$_}}{CODE}, keys %$table); - } -} - -sub trap { - my ($class,$method) = @_; - - return if not $Enabled; - - no strict 'refs'; - my $prevCode = \&{"${class}::${method}"}; - my $proto = prototype $prevCode; - - if (defined $proto and not $proto) { - return; - } - { - package IMPL::Profiler::Proxy; - no warnings 'redefine'; - my $sub = sub { - my $t0 = [Time::HiRes::gettimeofday]; - my @arr; - my $scalar; - my $entry = $prevCode; - my ($timeOwn,$timeTotal); - my $context = wantarray; - { - local $InvokeTime = 0; - #warn "\t"x$level,"enter ${class}::$method"; - $level ++; - if ($context) { - @arr = &$entry(@_); - } else { - if (defined $context) { - $scalar = &$entry(@_); - } else { - &$entry(@_); - } - } - $timeTotal = Time::HiRes::tv_interval($t0); - $timeOwn = $timeTotal - $InvokeTime; - } - $InvokeInfo{"${class}::${method}"}{Count} ++; - $InvokeInfo{"${class}::${method}"}{Total} += $timeTotal; - $InvokeInfo{"${class}::${method}"}{Own} += $timeOwn; - $InvokeTime += $timeTotal; - $level --; - #warn "\t"x$level,"leave ${class}::$method"; - return $context ? @arr : $scalar; - }; - if ($proto) { - Scalar::Util::set_prototype($sub => $proto); - } - *{"${class}::${method}"} = $sub; - } - -} - -sub PrintStatistics { - my $hout = shift || *STDERR; - print $hout "-- modules --\n"; - print $hout "$_\n" foreach sort keys %TrappedModules; - print $hout "\n-- stats --\n"; - print $hout - pad($_,50), - pad("$InvokeInfo{$_}{Count}",10), - pad(sprintf("%.3f",$InvokeInfo{$_}{Own}),10), - pad(sprintf("%.3f",$InvokeInfo{$_}{Total}),10), - "\n" - foreach sort { $InvokeInfo{$b}{Own} <=> $InvokeInfo{$a}{Own} } keys %InvokeInfo; -} - -sub ResetStatistics { - $InvokeTime = 0; - %InvokeInfo = (); -} - -sub pad { - my ($str,$len) = @_; - if (length $str < $len) { - return $str.(' 'x ($len- length $str)); - } else { - return $str; - } -} -1; +package IMPL::Profiler; + +our $Enabled; +our %TrappedModules; +our %InvokeInfo; +our $InvokeTime = 0; +my $level; + +BEGIN { + $level = 0; + if ($Enabled) { + warn "profiler enabled"; + no warnings 'once'; + *CORE::GLOBAL::caller = sub { + my $target = (shift || 0)+1; + my $realFrame = 1; + + for (my $i = 1; $i<$target; $i++) { + $realFrame ++; + my $caller = CORE::caller($realFrame-1) or return; + $realFrame ++ if $caller eq 'IMPL::Profiler::Proxy'; #current frame is proxy + } + + my @frame = CORE::caller($realFrame) or return; + if ( $frame[0] eq 'IMPL::Profiler::Proxy' ) { + my @next = CORE::caller($realFrame+1) or return; + @frame[0..2] = @next[0..2]; + } + + #warn "\t"x$level,"$frame[0] - $frame[3]"; + return wantarray ? @frame : $frame[0]; + }; + } +} +use strict; +use warnings; +use Time::HiRes; +require Scalar::Util; + + + +sub trap_all { + return if not $Enabled; + no strict 'refs'; + foreach my $class (@_) { + next if $TrappedModules{$class}; + $TrappedModules{$class} = 1; + + eval "warn 'load $class'; require $class;" if not %{"${class}::"}; + die $@ if $@; + + no strict 'refs'; + my $table = \%{"${class}::"}; + trap($class,$_) foreach (grep *{$table->{$_}}{CODE}, keys %$table); + } +} + +sub trap { + my ($class,$method) = @_; + + return if not $Enabled; + + no strict 'refs'; + my $prevCode = \&{"${class}::${method}"}; + my $proto = prototype $prevCode; + + if (defined $proto and not $proto) { + return; + } + { + package IMPL::Profiler::Proxy; + no warnings 'redefine'; + my $sub = sub { + my $t0 = [Time::HiRes::gettimeofday]; + my @arr; + my $scalar; + my $entry = $prevCode; + my ($timeOwn,$timeTotal); + my $context = wantarray; + { + local $InvokeTime = 0; + #warn "\t"x$level,"enter ${class}::$method"; + $level ++; + if ($context) { + @arr = &$entry(@_); + } else { + if (defined $context) { + $scalar = &$entry(@_); + } else { + &$entry(@_); + } + } + $timeTotal = Time::HiRes::tv_interval($t0); + $timeOwn = $timeTotal - $InvokeTime; + } + $InvokeInfo{"${class}::${method}"}{Count} ++; + $InvokeInfo{"${class}::${method}"}{Total} += $timeTotal; + $InvokeInfo{"${class}::${method}"}{Own} += $timeOwn; + $InvokeTime += $timeTotal; + $level --; + #warn "\t"x$level,"leave ${class}::$method"; + return $context ? @arr : $scalar; + }; + if ($proto) { + Scalar::Util::set_prototype($sub => $proto); + } + *{"${class}::${method}"} = $sub; + } + +} + +sub PrintStatistics { + my $hout = shift || *STDERR; + print $hout "-- modules --\n"; + print $hout "$_\n" foreach sort keys %TrappedModules; + print $hout "\n-- stats --\n"; + print $hout + pad($_,50), + pad("$InvokeInfo{$_}{Count}",10), + pad(sprintf("%.3f",$InvokeInfo{$_}{Own}),10), + pad(sprintf("%.3f",$InvokeInfo{$_}{Total}),10), + "\n" + foreach sort { $InvokeInfo{$b}{Own} <=> $InvokeInfo{$a}{Own} } keys %InvokeInfo; +} + +sub ResetStatistics { + $InvokeTime = 0; + %InvokeInfo = (); +} + +sub pad { + my ($str,$len) = @_; + if (length $str < $len) { + return $str.(' 'x ($len- length $str)); + } else { + return $str; + } +} +1;