#!perl

# 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. 


use strict;
use warnings;

use Test::More;
use Data::Dumper;
use Smart::Comments;

our $VERSION     = 0.04;
my $IS_CPAN_VERSION = 1;

BEGIN {
    ### -
    ### -----------
    ### -
    ### TESTS BEGIN
    ### -
    ### -----------
    ### -

    use_ok ( 'File::Copy' );
    use_ok ( 'Carp' );
    use_ok ( 'Debug::Xray', qw( start_sub end_sub dprint set_debug_verbose watch_subs add_watch_var errorHandler warnHandler is_carp_debug 
        debug_warn_handling default_warn_handling debug_error_handling default_error_handling ) ) or die 'Can\'t use Debug::Xray';
    use_ok ( 'IO::CaptureOutput', qw(capture capture_exec) );
    #use_ok ( 'Debug::Xray::WatchScalar' ) or die 'Can\t use Debug::Xray::WatchScalar';
    use_ok ( 'PadWalker', qw(var_name) ) or die 'Can\'t use PadWalker';
};


### Validate my module construction by trying out skeletal modules
if (!$IS_CPAN_VERSION) {
    use_ok ( 'Minimal', qw(i_am_here) ) or die 'Something wrong with module access'; # Can I even use a module in this directory?
    use_ok ( 'Minimal2::Minimal3', qw(i_am_here_3) ) or die 'Something wrong with module access'; # Can I even use a module in this directory?
    can_ok  ( 'Minimal'                         , 'i_am_here'   ) or die 'Something wrong with module access - exiting';
    can_ok  ( 'main'                            , 'i_am_here'   ) or die 'Something wrong with module access - exiting';
    is      ( Minimal::i_am_here()              , 'I am here'   ) or die 'Something wrong with module access - exiting';
    is      ( i_am_here()                       , 'I am here'   ) or die 'Something wrong with module access - exiting';

    can_ok  ( 'Minimal2::Minimal3'              , 'i_am_here_3' )   or die 'Something wrong with module access - exiting';
    can_ok  ( 'main'                            , 'i_am_here_3' )   or die 'Something wrong with module access - exiting';
    is      ( Minimal2::Minimal3::i_am_here_3() , 'I am here 3' )   or die 'Something wrong with module access - exiting';
    is      ( i_am_here_3()                     , 'I am here 3' )   or die 'Something wrong with module access - exiting';

    ### Minimal module tests passed
}


### Validate subroutine access...

{
    can_ok ('Debug::Xray', 'start_sub' )            or die 'Can\'t start_sub - exiting';
    can_ok ('main', 'start_sub' )                   or die 'Can\'t start_sub - exiting';
    can_ok ('Debug::Xray', 'set_debug_verbose' )    or die 'Can\'t set_debug_verbose - exiting';
    can_ok ('main', 'set_debug_verbose' )           or die 'Can\'t set_debug_verbose - exiting';
    can_ok ('Debug::Xray', 'dprint' )               or die 'Can\'t dprint - exiting';
    can_ok ('main', 'dprint' )                      or die 'Can\'t dprint - exiting';
}


### Die if Debug is not configured to run this script...

{
    is ( Debug::Xray::is_verbose()            , 1               , 'Debug::Xray is verbose' ) or die 'Debug::Xray must be verbose';
    is ( Debug::Xray::dprint('this is a test'), 'this is a test', 'Debug::Xray::dprint ok' ) or die 'Can\t dprint';
    is ( Debug::Xray::dprint('this is a test'), 'this is a test', 'Debug::Xray::dprint ok' ) or die 'Can\t dprint';
    ok ( is_carp_debug, 'Carp::Assert on' ) or die 'Carp::Assert must be turned on in Xray to run tests';
}


### Test Hooks...

{
    {
        my $expected_sub_1_output = <<END_SUB_1;
SUB: main::sub_1
    this is sub 1
    SUB: main::sub_2
        this is sub 2
        SUB: main::sub_3
            this is sub 3
        END: main::sub_3
    END: main::sub_2
END: main::sub_1
END_SUB_1

        {   
            require Hook::LexWrap;
            my ($stdout, $stderr);
            capture( sub { sub_1() }, \$stdout, \$stderr);
            is ($stdout, $expected_sub_1_output, 'start_sub, dprint, end_sub ok' ) or die 'Hook failed';
            is ( $stderr, '', 'No standard error');
        }


        {
            my ($stdout, $stderr);
            my $expected_sub_10_output = $expected_sub_1_output;
            
            $expected_sub_10_output =~ s/$/0/gm;
            $expected_sub_10_output =~ s/^0$//gm; # fix last line

            my $hook = Debug::Xray::watch_subs( 'main::sub_10', 'main::sub_20', 'main::sub_30' );
            capture sub {sub_10()}, \$stdout, \$stderr;

            is ($stdout, $expected_sub_10_output, 'start_sub, dprint, end_sub ok' ) or die 'Hook failed';
            is ( $stderr, '', 'No standard error');
        }

    }
}


{
    my $expected_sub_10_output = <<END_SUB_10;
SUB: main::sub_10
    this is sub 10
    SUB: main::sub_20
        this is sub 20
        SUB: main::sub_30
            this is sub 30
            SUB: main::sub_40
            END: main::sub_40
        END: main::sub_30
    END: main::sub_20
END: main::sub_10
END_SUB_10

    {
        my ($stdout, $stderr);
        my $hook = Debug::Xray::watch_all_subs();
        capture sub {sub_10()}, \$stdout, \$stderr;

        is ($stdout, $expected_sub_10_output, 'start_sub, dprint, end_sub ok' ) or die 'Hook failed';
        is ( $stderr, '', 'No standard error');
    }

}


### Make sure that when lexical hooks are out of scope, they are no longer in effect...

{
    {
        my ($stdout, $stderr);
        capture sub {sub_10()}, \$stdout, \$stderr;
        is ($stdout, "this is sub 10\nthis is sub 20\nthis is sub 30\n", 'Lexical hooks are gone' ) or die 'Hook failed';
        is ( $stderr, '', 'No standard error');
    }
}


### Test tie...

{

    my ($stderr, $stdout);
    my $var = 15;
    capture sub { tie $var, 'Debug::Xray::WatchScalar', '$var', $var }, \$stdout, \$stderr; 
    is ( $stdout, "TIE: TIESCALAR \$var=15\n", 'TIESCALAR ran' );
    is ( $stderr, '', 'No standard error');

}

{
    my ($stderr, $stdout);
    my $var;
    capture sub { tie $var, 'Debug::Xray::WatchScalar', '$var', $var }, \$stdout, \$stderr; 
    is ( $stdout, "TIE: TIESCALAR \$var=undef\n", 'TIESCALAR ran' );
    is ( $stderr, '', 'No standard error');
}

{
    # TODO Check how tie events get logged
    my $var;

    my ($stdout, $stderr);

    capture sub { tie $var, 'Debug::Xray::WatchScalar', '$var', $var }, \$stdout, \$stderr; 
    is ( $stdout, "TIE: TIESCALAR \$var=undef\n", 'TIESCALAR ran' );
    is ( $stderr, '', 'No standard error');

    capture sub { $var = 1 }, \$stdout, \$stderr;
    is ( $var, 1, '$var ok after tie and assignment' );
    is ( $stdout, "TIE: STORE 1 to \$var\n", 'Store 1 to \$var ok' );
    is ( $stderr, '', 'No standard error');

    capture sub { $var = 2 }, \$stdout, \$stderr;
    is ( $var, 2, '$var ok after re-assignment' );
    is ( $stdout, "TIE: STORE 2 to \$var\n", 'Store 2 to \$var ok' );
    is ( $stderr, '', 'No standard error');

    my $var2 = 5;
    capture sub { tie $var2, 'Debug::Xray::WatchScalar', '$var2', $var2 }, \$stdout, \$stderr; 
    is ( $stdout, "TIE: TIESCALAR \$var2=5\n", 'TIESCALAR ran' );
    is ( $var2, 5, '$var2 did not lose the value of 4 when tied' );
}


### Test watch scalars...

sub test_watch_scalars {

    my $TEST = 1;
    is ( add_watch_var(\$TEST), '$TEST' );

    # my @TEST;
    # is ( add_watch_var(\@TEST), '@TEST' );
}

{
  my $foo;
  is ( var_name(0, \$foo), '$foo', 'var_name() works' );    # prints '$foo'
  
  sub my_name {
    return var_name(1, shift);
  }

  is ( my_name(\$foo), '$foo', 'var_name() within subroutine works' );        # ditto

   test_watch_scalars();

  is ( add_watch_var(\$foo), '$foo', 'Experimental var_name() within Xref::Xray::my_name subroutine works' );        # ditto
}


{

    my ($stdout, $stderr);
    my $var;

    capture sub { add_watch_var(\$var) }, \$stdout, \$stderr;
    is ( $stdout, "TIE: TIESCALAR \$var=undef\n", 'TIESCALAR on $var' );
    is ( $stderr, '', 'No standard error');

    capture sub { $var = 1 }, \$stdout, \$stderr;
    is ( $var, 1, 'Stored 1' );
    is ( $stdout, "TIE: STORE 1 to \$var\n", 'STORE 1 to \$var' );
    ok ( $stdout, 'Hope to have something from stdout' ); #  or die 'Got nothing from storing 1 to $var - Exiting';
    is ( $stderr, '', 'No standard error');

    capture sub { $var = 2 }, \$stdout, \$stderr;
    is ( $var, 2, 'Stored 2' );
    is ( $stdout, "TIE: STORE 2 to \$var\n", 'STORE 2 to \$var' ); 
    is ( $stderr, '', 'No standard error');

    my $var2 = 3;
    is ( $var2, 3, '$var2 is created and assigned a value of 3' );

    capture sub { add_watch_var(\$var2) }, \$stdout, \$stderr;
    is ( $var2, 3, '$var2 tied with pre-exisiting value of 3' );
    is ( $stdout, "TIE: TIESCALAR \$var2=3\n", 'Tied var2 with a pre-existing value of 3 - should see in std out from logging' );
    is ( $stderr, '', 'No standard error');

    capture sub { $var2 = 4 }, \$stdout, \$stderr;
    is ( $var2, 4, 'Stored 4 in $var2' );
    is ( $stdout, "TIE: STORE 4 to \$var2\n", 'STORE 4 to $var2' );
    is ( $stderr, '', 'No standard error');

    is ( $var, 2, '$var is undisturbed' );

    capture sub { $var = 5 }, \$stdout, \$stderr;
    is ( $var, 5, 'Stored 5 in $var' );
    is ( $stdout, "TIE: STORE 5 to \$var\n", 'STORE 5 to $var' );
    is ( $stderr, '', 'No standard error');

    capture sub { $var = 6 }, \$stdout, \$stderr;
    is ( $var, 6, 'Stored 6 in $var' );
    is ( $var2, 4, '$var2 is undisturbed' );
    is ( $stdout, "TIE: STORE 6 to \$var\n", 'STORE 6 to $var' );
    is ( $stderr, '', 'No standard error');

    capture sub { $var = $var2 }, \$stdout, \$stderr;
    is ( $var, 4, '$var is undisturbed after assignment' );
    is ( $var2, 4, '$var2 is undisturbed after Fetch' );
    is ( $stdout, "TIE: FETCH 4 from \$var2\nTIE: STORE 4 to \$var\n"); #, "Assignment causes fetch and store. stdout='$stdout'" );

    is ( $stderr, '', 'No standard error');

    capture sub { print $var2 }, \$stdout, \$stderr;
    isnt ( $stdout, '', "We should see a FETCH message. We got $stdout" );
    is ( $stderr, '', 'No standard error');
}


### Error Handling...

{

    sub divide_by_zero_default { my $result = 100/0 }
    sub divide_by_zero_debug   { my $result = 100/0 }

    my ($stderr, $stdout);
    my $hook_default = watch_subs( 'main::divide_by_zero_default' );
    my $hook_debug   = watch_subs( 'main::divide_by_zero_debug' );

    ### Test Default Error Handling...
    {
        
        default_error_handling();
        eval {capture sub { divide_by_zero_default()}, \$stdout, \$stderr;};

        ok ( $@ =~ /^\s*Illegal division by zero/, 'Handled error ok' );
        ok ($stdout =~ /^\s*SUB: main::divide_by_zero_default\s*\n/, "Default Error processed ok.");
        ok ( $stderr eq '', "stderr is blank." );

    }

    # Test Debug Error Handling...
    {
        debug_error_handling();
        eval { capture sub { divide_by_zero_debug()}, \$stdout, \$stderr };

        ok ( $@ =~ /^\s*Illegal division by zero/, 'Handled error ok' );
        ok ( $stdout =~ /^\s*SUB: main\:\:divide_by_zero_debug\s*\n\s*Error\: Illegal division by zero at/, "Debug Error processed ok");
        ok ( $stderr eq '', "stderr is blank." );
    }

    ### Retest Default Error Handling to make sure it got set back...
    {
        
        default_error_handling();
        eval {capture sub { divide_by_zero_default()}, \$stdout, \$stderr;};

        ok ( $@ =~ /^\s*Illegal division by zero/, 'Handled error ok' );
        ok ($stdout =~ /^\s*SUB: main::divide_by_zero_default\s*\n/, "Default Error processed ok.");
        ok ( $stderr eq '', "stderr is blank" );

    }
}


### Test CallerStack (SKIPPED FOR NOW)...

if (0) {

    use Devel::CallerStack qw/caller_stack/;

   # my $stack = Devel::CallerStack->new();
    # or
    my $stack = caller_stack();

    # Get all callers
    my @callers = $stack->all_list();

    # Limit to specific callers:
    $stack->filter( 'line', 100 );
    $stack->filter( 'subroutine', qr/mysub$/ );
    $stack->filter( 'package', 'My::Package' );

    #my @specific_callers = $stack->filtered_list()

    while ( my $level = $stack->next ) {
        warn $level;
    }

}

### End of test script...

done_testing();


sub sub_1 {
    start_sub();
    dprint ('this is sub 1');
    sub_2();
    end_sub();
}

sub sub_2 {
    start_sub();
    dprint ('this is sub 2');
    sub_3();
    end_sub();
}

sub sub_3 {
    start_sub();
    dprint ('this is sub 3');
    end_sub();
}

sub sub_4 {
    start_sub();
    dprint ('this is sub 4');
    end_sub();
}

sub sub_10 {
    dprint ('this is sub 10');
    sub_20();
}

sub sub_20 {
    dprint ('this is sub 20');
    sub_30();
}

sub sub_30 {
    dprint ('this is sub 30');
    sub_40();
}

sub sub_40 {
}



=pod

CHANGE LOG
===============================

Version 0.03
------------
12/17/2011  : Streamlined watch_vars to only take a reference to a scalar and figure out the variable name from that. (Need to implement on arrays and hashes.)
            : More consistent naming. Routines with the word 'hook' in the name are changed to 'watch' to be more consistent with the watch variables routines.  

Version 0.04
------------
12/18/2011  : Fixed signal trapping so it could be turned off and on. It passes tests, but needs a better workout.


=cut