# THIS IS A WORK IN PROGRESS

# THIS IS A WORK IN PROGRESS
# IT SHOULD BE CONSIDERED ALPHA
# BUT I EXPECT IT TO IMPROVE
# THIS IS A RE-IMPLEMENTATION OF PREVIOUS CODE THAT WAS WRITTEN
# ON-THE-FLY AS NEEDED.

# YOU ARE ADVISED TO RUN THE TEST SCRIPT!!!

package Debug::Xray;
use strict;
use warnings;

use feature qw(state);

use Exporter qw(import);

our $VERSION = 0.03;
our @ISA = qw(Exporter);
our @EXPORT_OK;

use Carp::Assert;
use Hook::LexWrap;
use Data::Dumper;
use PPI;
use PadWalker qw(var_name);
use Debug::Xray::WatchScalar qw( set_log_handler TIESCALAR STORE FETCH);

BEGIN {
#$SIG{__WARN__} = sub { &warn_handler(9, @_); };
#$SIG{__DIE__} = sub { &error_handler(11, @_); };
}

# TODO Oranize subs into EXPORT_TAGS
# CONFIGURATION
push @EXPORT_OK, qw{
&set_debug_verbose
&set_debug_quiet
&watch_subs
&watch_all_subs
};

# TRACK SUBROUTINE EXECUTION
push @EXPORT_OK, qw{
&start_sub
&end_sub
&dprint
};

# WATCH VARIABLE ROUTINES
push @EXPORT_OK, qw{
&add_watch_var
&warnHandler
&errorHandler
};

# TESTING OF THIS MODULE
push @EXPORT_OK, qw{
&is_carp_debug
};

# TODO - do handlers need to be exported

## END EXPORTED SUBROUTINES

my $Verbose = 1;
my $SUB_NEST_LIMIT = 200;

my $LogFile = '/home/dave/Desktop/Jobs/computer_exercises/perl/debug/Debug.log';

my $VOID_CONTEXT_ERROR_MESSAGE = 'The caller of this function must assign the return value. ' .
'The hooks remain in effect only when the returned value is in lexical scope.';

my @SubStack;

Debug::Xray::WatchScalar->set_log_handler(\&dprint);

sub set_debug_verbose { $Verbose = 1 };
sub set_debug_quiet { $Verbose = 0 };
sub is_verbose { return $Verbose };
sub is_carp_debug {
return 1 if DEBUG;
return 0;
}

# MESSAGE PRINT ROUTINES

sub dprint($) {
return unless $Verbose;

my ($mesg) = shift;
my $print_line = indentation() . $mesg;

print "$print_line\n";

log_to_file($print_line) if $LogFile;
return $print_line;
}

sub log_to_file {
assert ( $#_==0, 'Parms' ) if DEBUG;
state $HLog;

unless ($HLog) {open ( $HLog, ">$LogFile" ) or die "Could not open log file $LogFile: $!"};

my $print_line = shift;
print $HLog "$print_line\n";
}

# TODO Call Stack for error handlers
sub warn_handler {
my $level = shift;
my @msgs = @_;

dprint ("Error: level=$level, messages: " . Dumper \@msgs);
# die ("Error: level=$level, messages: " . @msgs);
}

sub error_handler {
my $level = shift;
my @msgs = @_;
dprint ("Warn: level=$level, messages: " . Dumper \@msgs);
}

sub start_sub {
return unless $Verbose;

my $msg = shift || (caller(1))[3];
assert ( $#SubStack < $SUB_NEST_LIMIT, "Too many subs on stack " . Dumper \@SubStack) if DEBUG;
assert ( defined $msg ) if DEBUG;

dprint "SUB: $msg";
push @SubStack, $msg;
}

sub end_sub {
return unless $Verbose;

my $msg = shift || (caller(1))[3];
assert ( $msg !~ m/start_sub/) if DEBUG;
assert ( $msg !~ m/end_sub/) if DEBUG;
assert ( $SubStack[$#SubStack] eq $msg,
"Stack of size $#SubStack out of synch. Popping $SubStack[$#SubStack], expected $msg\nStack is " .
Dumper (\@SubStack) . "\n" ) if DEBUG;

pop @SubStack;

dprint "END: $msg";
}

sub indentation() {
return " " x ($#SubStack+1);
}

# SUBROUTINE HOOK ROUTINES

sub watch_subs { # NOTE: Hooks stay in effect within the lexical scope of the return value
assert ( defined wantarray, $VOID_CONTEXT_ERROR_MESSAGE ) if DEBUG;

my @sub_names = @_;

my $hooks;
for my $sub_name (@sub_names) {
push @$hooks, wrap $sub_name,
pre => sub { start_sub ($sub_name) },
post => sub { end_sub ($sub_name) };
}

return $hooks;
}

sub watch_all_subs { # NOTE: Hooks stay in effect within the lexical scope of the return value
assert ( defined wantarray, $VOID_CONTEXT_ERROR_MESSAGE ) if DEBUG;

my @caller = caller();
my $Document = PPI::Document->new("$caller[1]");
my $sub_nodes = $Document->find(
sub { $_[1]->isa('PPI::Statement::Sub') }
);

my @sub_names;
for my $sub_node (@$sub_nodes) {
next if $sub_node->name eq 'BEGIN';
push @sub_names, $caller[0].'::'.$sub_node->name;
}

return watch_subs(@sub_names);
}

sub add_watch_var {
assert ( $#_==0, 'Parms' ) if DEBUG;
my $var_ref = shift;
my $var_name = var_name(1, $var_ref);
assert ( $var_name, "var_name has a value: $var_name]" ) if DEBUG;

if ($var_name =~ /^\$/) {
tie $$var_ref, 'Debug::Xray::WatchScalar', $var_name, $$var_ref;
}
elsif ($var_name =~ /^\@/) { die 'Not implemented yet' }
elsif ($var_name =~ /^\%/) { die 'Not implemented yet' }
else { die "Invalid variable name '$var_name'" if DEBUG }

return $var_name if DEBUG;
}

1;

__END__