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

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.