<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;"># 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     = 1.00;
our @ISA         = qw(Exporter);
our @EXPORT_OK;

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


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

# TODO Oranize subs into EXPORT_TAGS
# CONFIGURATION
push @EXPORT_OK, qw{
    &amp;set_debug_verbose
    &amp;set_debug_quiet
    &amp;hook_subs
    &amp;hook_all_subs
};


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

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

# TESTING OF THIS MODULE
push @EXPORT_OK, qw{
    &amp;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-&gt;set_log_handler(\&amp;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, "&gt;$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 &lt; $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 hook_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  =&gt; sub { start_sub ($sub_name) },
             post =&gt; sub { end_sub ($sub_name) };
    }

    return $hooks;
}


sub hook_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-&gt;new("$caller[1]");
    my $sub_nodes = $Document-&gt;find( 
        sub { $_[1]-&gt;isa('PPI::Statement::Sub') }
    );
    
    my @sub_names;
    for my $sub_node (@$sub_nodes) {
        next if $sub_node-&gt;name eq 'BEGIN';
        push @sub_names, $caller[0].'::'.$sub_node-&gt;name;
    }    

    return hook_subs(@sub_names);
}


sub add_watch_var {
    assert ( $#_==1, 'Parms' ) if DEBUG;
    # @_ = ( Actual variable, Variable name )

    assert ( $_[1], "var_name has a value: $_[1]" ) if DEBUG;
    tie $_[0], 'Debug::Xray::WatchScalar', $_[1], $_[0]; 
}




1;



__END__
</pre></body></html>