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

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

use strict;
use warnings;

use Test::More;
use Data::Dumper;
use Smart::Comments;
use feature qw(state say);


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

    use_ok ( 'File::Copy' );
    use_ok ( 'Carp' );
    use_ok ( 'Debug::Xray', qw( start_sub end_sub dprint set_debug_verbose hook_subs add_watch_var errorHandler warnHandler is_carp_debug ) ) 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';
};


### Validate my module construction by trying out skeletal modules
if (0) {
    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 $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 ($stdout, $stderr);
            my $hook = Debug::Xray::hook_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::hook_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' );
    #isnt ( $stdout, "\nTIE: TIESCALAR undef\n", 'TIESCALAR ran, but I don\t like the undef' );
    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...

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

    capture sub { add_watch_var($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, '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 (SKIPPED FOR NOW)...

if (0) {
    sub divide_by_zero {
        my $result = 100/0;
    }

    my $hook = hook_subs( 'main::divide_by_zero' );
    
    eval {divide_by_zero()};
    ok ( $@ =~ /^\s*Illegal division by zero/, 'Handled error ok' );
}


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

}

### You are advised to turn off assertions in Debug/Xray.pm...
### Change the line that uses Carp's Assert module; Change 'use ' to 'no'
### Assertions must be on to run this test script...
### 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 {
}