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;
     }
     
 }