view release on metacpan or  search on metacpan

t/DebugStatementsTest.t  view on Meta::CPAN

    ls '/home/ate/scripts/regression/DebugStatementsTest.t /home/ate/scripts/regression/DebugStatementsTest.t';
    die;
    ls '/home/ate/scripts/regression/pintable';
    ls('/home/ate/scripts/regression');
    ls('/home/ate/scripts/regression', '-lR'); 
    die;

    ls '/home/ate/scripts/regression/DebugStatementsTest.t';
    ls '/home/ate/scripts/regression/DebugStatementsTest.doesnotexist';
    ls '$scalar';
    cp '/home/ate/scripts/regression/pintable';
    cp '/home/ate/scripts/regression/DebugStatementsTest.t';
    cp '/home/ate/scripts/regression/DebugStatementsTest.doesnotexist';
    cp '$scalar';
    die;
}


# Setup
my $header  = 'DEBUG sub __ANON__:';
my $header2 = 'DEBUG2 sub __ANON__:';
my $vr    = '\s+[\$\@\%]\S+\s+=\s+';  # variable regex  '$var ='
my $r1    = qr($header${vr}2);

my $rn    = qr($header${vr}\{\s+'flintstones'\s+=>\s+\{\s+'husband'\s+=>\s+'fred',\s+'pal'\s+=>\s+'barney'\s+\}\s+\});
my $rnt   = qr($header${vr}\{\s+'flintstones'\s+=>\s+\{\s+'husband'\s+=>\s+'fred',\s+\.\.\.);  # truncated
#my $n      = '\\{\\s+\'flintstones\'\\s+=>\\s+\\{\\s+\'husband\'\\s+=>\\s+\'fred\',\\s+\'pal\'\s+=>\\s+\'barney\'\\s+\\}\\s+\\}';
#my $nt     = '\\{\\s+\'flintstones\'\\s+=>\\s+\\{\\s+\'husband\'\\s+=>\\s+\'fred\',\\s+\\.\\.\\.';
#(my $nt2     = $n) =~ s/\'pal.*/\\.\\.\\./;
#say "$nt\n$nt2";die;
#$nt = $nt2;
#my $rn    = qr($header${vr}$n);
#my $rnt   = qr($header${vr}$nt);
#(my $rnt2 = $rn) =~ s/'pal'.*/\\.\\.\\.)/;
#say "$rnt\n$rnt2";die;
#$rnt = $rnt2;
my $rnf   = qr($header${vr}\{\s+'husband'\s+=>\s+'fred',\s+'pal'\s+=>\s+'barney'\s+\});  # ->{flintstones}
my $rnfh  = qr($header${vr}'fred');  # ->{flintstones}{husband}
my $rnfp  = qr($header${vr}'barney');  # ->{flintstones}{pal}
my $rnfhp = qr($header${vr}'(fred|barney)');  # ->{flintstones}{husband} or ->{flintstones}{pal}

my $l     = '\[\s+\'zero\',\s+1,\s+\'two\',\s+\'3\'\s+\]';  # list
my $rl    = qr($header${vr}${l});
my $rld2  = qr($header2${vr}${l});
my $lsort = '\[\s+1,\s+\'3\',\s+\'two\',\s+\'zero\'\s+\]';
my $rl1   = qr($header${vr}\[ 'zero', 1, 'two', '3' ]);  # uncompressed
my $rle   = qr($header${vr}.*\d+.*\s+${l});
my $rls   = qr($header${vr}${lsort});

my $h     = '\{\s+\'one\'\s+=>\s+2,\s+\'three\'\s+=>\s+4\s+\}';  # hash
my $rh    = qr($header${vr}${h}); # hash
my $rhd2  = qr($header2${vr}${h}); # hash with DEBUG2
my $rh1   = qr($header${vr}\{ 'one' => 2, 'three' => 4 \});  # uncompressed
my $rhe   = qr($header${vr}.*\d+.*\s+${h}); # hash with number of elements
my $rhs   = qr($header${vr}${h}); # hash sorted

if ( runtests('use') ) {
    use_ok('Test::More') or die; 
    use_ok('Test::Fatal') or die; 
    use_ok('Test::Output') or die; 
    use_ok('PadWalker') or die; 
    use_ok('Debug::Statements') or die; 
}

# All these are equivalent:
#     tdd { d('$scalar')  } $exp, 'scalar';
#     tsub 'd', '$scalar', $exp, '';
#     td '$scalar', $exp, '';

# These subs are listed early so that they can be used without parentheses
# td() is the easiest to use since it assumes d() with one argument.  Internally it calls tsub().  td0() td1() td2() also call tsub().
# tdd() is similar, but supports d() d2() d3().  Also supports a second argument.  Does not automatically assume a description if none is given.

# tsub 'd', '$scalar', $exp, '';
sub tsub {
    my ($sub, $argument, $expected, $addl_description) = @_;
    $addl_description = '' if ! defined $addl_description;
    no strict;
    if ( $opt{print} ) {
        $sub->($argument) if defined $opt{print} and $opt{print};
    } else {
        if ( ref($argument) =~ /^(SCALAR|ARRAY|HASH|REF|CODE|GLOB)$/ ) {
            my $warning = qr(WARNING:.*was given a reference to a variable instead of a single-quoted string);
            die if ! like( $warning, $expected )  and $opt{die};
            return;
        }
        my $dummy = eval{$argument};
        $$argument = eval $dummy;
        if( ref $expected eq ref(qr//) ) {
            #die if ! stdout_like {$sub->($argument)} $expected, "$argument  $addl_description"  and $opt{die};  # Not working in 5.18 and 5.20
            die if ! stdout_like {$$argument = eval $dummy ; $sub->($argument)} $expected, "$argument  $addl_description"  and $opt{die}; # works
        } else {
            #D 'No regex';
            #die if ! stdout_is {$sub->($argument)} $expected, "$argument  $addl_description"  and $opt{die}; # Not working in 5.18 and 5.20
            #use Capture::Tiny 'capture_merged'; my ($merged, $status) = Capture::Tiny::capture_merged {$sub->($argument)}; say "\$merged = $merged"; # Not working in 5.18 and 5.20
            die if ! stdout_is {$$argument = eval $dummy ; $sub->($argument)} $expected, "$argument  $addl_description"  and $opt{die}; # works
        }
    }
    use strict;
}

# tdd { d('$scalar')  } $exp, 'scalar';
sub tdd (&$$) {
    my ($coderef, $expected, $description) = @_;
    $description = "test $description";
    if ( $opt{print} ) {
        $coderef->();
    } else {
        if( ref $expected eq ref qr// ) {
            die if ! stdout_like {$coderef->()} $expected, $description  and $opt{die};
        } else {
            die if ! stdout_is {$coderef->()} $expected, $description  and $opt{die};
        }
    }
}
sub td {
    my ($argument, $expected, $addl_description) = @_;
    tsub ('d', $argument, $expected, $addl_description);
}
sub td0 {
    my ($argument, $expected, $addl_description) = @_;