Mercurial > pub > Impl
view Lib/IMPL/Profiler.pm @ 250:129e48bb5afb
DOM refactoring
ObjectToDOM methods are virtual
QueryToDOM uses inflators
Fixed transform for the complex values in the ObjectToDOM
QueryToDOM doesn't allow to use complex values (HASHes) as values for nodes (overpost problem)
author | sergey |
---|---|
date | Wed, 07 Nov 2012 04:17:53 +0400 |
parents | c8fe3f84feba |
children |
line wrap: on
line source
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; 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 " "x$level,"$frame[0] - $frame[3]"; return wantarray ? @frame : $frame[0]; }; } } 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 eval { *{$table->{$_}}{CODE} }, keys %$table); # here can be a not a GLOB reference } } sub trap { my ($class,$method) = @_; return if not $Enabled; return if $method eq 'import'; 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 " "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 " "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;