#!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 {
}

You are viewing proxied material from ftp.icm.edu.pl. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.