Mercurial > pub > Impl
diff Lib/IMPL/Profiler.pm @ 134:44977efed303
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 |
line wrap: on
line diff
--- a/Lib/IMPL/Profiler.pm Fri Jun 18 16:27:28 2010 +0400 +++ b/Lib/IMPL/Profiler.pm Mon Jun 21 02:39:53 2010 +0400 @@ -1,15 +1,64 @@ package IMPL::Profiler; +use strict; +use warnings; +use Time::HiRes; +require Scalar::Util; + our $Enabled; our %TrappedModules; our %InvokeInfo; our $InvokeTime = 0; +our @TrapQueue; +our $Filter ||= qr//; my $level; BEGIN { $level = 0; if ($Enabled) { warn "profiler enabled"; + + unshift @INC, sub { + my ($self,$filename) = @_; + + (my $module = $filename) =~ s/\//::/g; + $module =~ s/\.\w+$//; + + return unless $module =~ $Filter; + + foreach my $dir (@INC) { + my $fullName = "$dir/$filename"; + if (-f $fullName) { + open my $hmod, $fullName or die "$fullName: $!" if $!; + + + + my @source; + local $/ = "\n"; + while (my $line = <$hmod>) { + last if $line =~ /^\s*__END__/; + push @source, $line; + } + + undef $hmod; + + push @source, + "IMPL::Profiler::trap_all(__PACKAGE__);\n", + "1;\n"; + + + return (sub { + if (@source) { + $_ = shift @source; + return 1; + } else { + return 0; + } + }, undef ); + } + } + }; + no warnings 'once'; *CORE::GLOBAL::caller = sub { my $target = (shift || 0)+1; @@ -32,12 +81,6 @@ }; } } -use strict; -use warnings; -use Time::HiRes; -require Scalar::Util; - - sub trap_all { return if not $Enabled; @@ -51,7 +94,7 @@ no strict 'refs'; my $table = \%{"${class}::"}; - trap($class,$_) foreach (grep *{$table->{$_}}{CODE}, keys %$table); + trap($class,$_) foreach (grep eval { *{$table->{$_}}{CODE} }, keys %$table); # here can be a not a GLOB reference } } @@ -60,6 +103,8 @@ return if not $Enabled; + return if $method eq 'import'; + no strict 'refs'; my $prevCode = \&{"${class}::${method}"}; my $proto = prototype $prevCode; @@ -68,43 +113,43 @@ 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; + 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; } }