package ATR::TryProfiler;

use strict;
use warnings;

if (eval 'local $SIG{__DIE__}; require SITk::ProfileWindow; 1') {
    warn "Profiler enabled\n";
    # inits when we make a MainWindow

} else {
    my $prob = $@;
    $prob =~ s/BEGIN failed--compilation aborted.*//s;
    $prob =~ s/ in \@INC \(\@INC contains.*//s;
    warn "Info: Performance profiler absent: $prob\n";

    no strict 'refs';
    # provide dummy method, it's used in various places
    *{Tk::Widget::profileBlock} = sub { undef };
}

1;

 #  #----------------------------------------------------------------------------
 #  #
 #  # Histograms of calls to slow stuff
 #  
 #  my %func_hits;
 #  sub wrapSub {
 #      my ($funcName) = @_;
 #      warn "Wrapping $funcName for call origins\n";
 #      my $old;
 #      my $new = sub {
 #  	my @args = @_;
 #  	my @frames = ([caller(0)],
 #  		      [caller(1)],
 #  		      [caller(2)]);
 #  # ($package, $filename, $line, $subroutine, $hasargs,
 #  # $wantarray, $evaltext, $is_require, $hints, $bitmask) = caller($i);
 #  	my $src = join "\n", map {
 #  	    my ($pkg, $fn, $ln, $sub, $hasargs, $wantarray, $evaltext, $is_req, $hints, $bitmask) = @$_;
 #  	    "$fn:$ln: $sub";
 #  	} @frames;
 #  	$func_hits{$funcName}->{"\n$src\n\t"} ++;
 #  	return $old->(@args);
 #      };
 #      no strict 'refs';
 #      $old = *{$funcName}{CODE};
 #      *{$funcName} = $new;
 #  }
 #  
 #  END {
 #      warn "Call sources:\n";
 #      warn Tk::Pretty::Pretty(\%func_hits);
 #  }
 #  
 #  wrapSub('Tk::configure');

#----------------------------------------------------------------------------
#
# Picky GTx profiling by overriding

use ATR::GTx;

package ATR::GTx;

use strict;
use warnings;

BEGIN {
    no strict 'refs';
    my @got = (grep { *{$_} && *{$_}{CODE} }
	       map {__PACKAGE__."::$_"}
	       qw(getAttribute getPhysicalEntity getSubEntity));
    die "oops - methods (@got) already exist in real code" if @got;
}

sub getAttribute {
    my ($self, %args) = @_;
    my $prof = Tk::Widget->profileBlock($args{-idAttribute} ? 'GTx/getAttribute/adopt' : 'GTx/getAttribute/find');
    return $self->SUPER::getAttribute(%args);
}

sub getPhysicalEntity {
    my ($self, %args) = @_;
    my $prof = Tk::Widget->profileBlock('GTx/getPhysicalEntity');
    return $self->SUPER::getPhysicalEntity(%args);
}

sub getSubEntity {
    my ($self, %args) = @_;
    my $prof = Tk::Widget->profileBlock('GTx/getSubEntity');
    return $self->SUPER::getSubEntity(%args);
}

#----------------------------------------------------------------------------
#
# Bulk GTx profiling by code replacement

#_profilePackage('GTx');

# haven't checked that this is actually safe to do...
sub SUSPECT_profilePackage {
    my $pkg = shift;

    our %profileEvent;
    no strict 'refs';
    foreach my $symName (keys %{$pkg.'::'}) {
	next if $symName =~ /^[A-Z0-9_]+$/; # ignore block-caps, will be a constant
#	next if $symName =~ /^_/; # ignore privates
	next if $symName =~ /::$/; # ignore sub-namespaces
	my $subName = $pkg.'::'.$symName;
	my $orig = *{$subName}{CODE};
	next if !$orig; # no code to replace

	# Code to profile only the first call into package; internal calls aren't interesting yet
	no warnings;
	*{$subName} = sub {
	    my @args = @_;
	    if ($profileEvent{$pkg}) {
		return $orig->(@args);
	    } else {
		local $profileEvent{$pkg} = Tk::Widget->profileBlock($pkg, -method => $symName);
		return $orig->(@args);
	    }
	};
    }
}


#----------------------------------------------------------------------------

package ATR::Profile::ObjectScope;
sub new {
    my ($pkg, $name, $object) = @_;
    my $self = bless {}, ref($pkg) || $pkg;
    $self->{ev} = Tk::Widget->profileBlock($name);
    $self->{obj} = $object;
    return $self;
}

sub new_GTx { $_[0]->new('GTxScope', ATR::GTx->singleton) }

our $AUTOLOAD;
sub AUTOLOAD {
    my ($self, @args) = @_;
    my $meth = $1 if $AUTOLOAD =~ /::([^:]+)$/;
    my $obj = $self->{obj};
    return if $meth eq 'DESTROY' && !$obj->can('DESTROY');
    return $obj->$meth(@args);
}


1;
