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 "\t"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 "\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;