File Coverage

blib/lib/Debug/Xray.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

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

use feature qw(state);

use Exporter qw(import);

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

no 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 );


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

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

# WARNING AND ERROR HANDLING
push @EXPORT_OK, qw{
    &debug_warn_handling
    &default_warn_handling
    &debug_error_handling
    &default_error_handling
};


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



sub debug_warn_handling {
    $SIG{__WARN__} = sub { &_warn_handler(@_); };

}
sub default_warn_handling {
    $SIG{__WARN__} = 'DEFAULT';
}


sub debug_error_handling {
    $SIG{__DIE__} = sub { &_error_handler(@_); };
}
sub default_error_handling {
    $SIG{__DIE__} = 'DEFAULT';
}

# TODO Call Stack for error handlers
sub _warn_handler {
    my @msgs = @_;

    for my $msg (@msgs) {
        dprint ("Warning: $msg");
    }
    #return @_;
}

sub _error_handler {
    my @msgs = @_;
    for my $msg (@msgs) {
        dprint ("Error: $msg");
    }
    #return @_;
}




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


__END__