Debug-Statements
view release on metacpan or search on metacpan
t/DebugStatementsTest.t view on Meta::CPAN
# 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) = @_;
tsub ('d0', $argument, $expected, $addl_description);
}
sub td1 {
my ($argument, $expected, $addl_description) = @_;
tsub ('d1', $argument, $expected, $addl_description);
}
sub td2 {
my ($argument, $expected, $addl_description) = @_;
tsub ('d2', $argument, $expected, $addl_description);
}
if ( runtests('testScalar') ) {
say "\n### testScalar";
my $exp = "$header \$scalar = 'myvalue'\n";
$d = 1;
stdout_like { d('$scalar')} qr(is printing debug statements), 'First run of Debug::Statements, inside $scalar';
stdout_is { d('$scalar')} $exp, '$scalar d()';
stdout_is { d '$scalar'} $exp, '$scalar d';
tdd { d('$scalar') } $exp, '$scalar tdd()';
# td() is a wrapper around Test::Output::stdout_is { d() } and Test::Output::stdout_like { d() }
# It will be used instead of stdout_is for brevity
# The next text is exactly the same as the previous test
td '$scalar', $exp, '$scalar td()';
td '${scalar}', "$header \${scalar} = 'myvalue'\n", '';
td1 '$scalar', $exp;
td '$scalar', $exp;
my $err1 = "$header myvalue\n";
td "$scalar", $err1, 'error - used double-quotes by mistake instead of single-quotes';
td '\$scalar', "\\$exp", 'backslash in front of DEBUG (user error)'; # this should not really be a test
my $r_spell = qr(Check if you misspelled your variable name when you called);
my $d_spell = 'scalar misspelled variable or wrong sigil';
td '$misspelledvar', $r_spell, $d_spell;
td '$list', $r_spell, $d_spell;
td '$nestedlist', $r_spell, $d_spell;
td '$hash', $r_spell, $d_spell;
td '$nestedhash', $r_spell, $d_spell;
td '$list[10]', $r_spell, $d_spell;
td '$hash{ten}', $r_spell, $d_spell;
my $warning = qr(WARNING:.*was given a reference to a variable instead of a single-quoted string);
if ( $] lt '5.018' ) {
#tsub 'd', '$scalar', $warning, 'scalar warning';
tdd { d( \$scalar ) } $warning, 'scalar warning'; # 5.18
}
#td '\$scalar', $warning, 'warning';
my $undefinedvar;
my $expundef = "$header \$undefinedvar = undef\n";
tdd { d('$undefinedvar') } $expundef, 'scalar undef';
#td '$undefinedvar', $expundef, 'undef';
CLOSURE: {
# Needed because $d is undef'd
undef $d;
td '$scalar', '', '$d has not been declared';
tdd { d0 '$scalar' } $exp, '$scalar d0';
tdd { D '$scalar' } $exp, '$scalar D';
td0 '$scalar', $exp;
my $d;
td '$scalar', '', '$d is not defined';
tdd { d0 '$scalar' } $exp, '$scalar d0';
tdd { D '$scalar' } $exp, '$scalar D';
td0 '$scalar', $exp;
$d = 0;
td '$scalar', '', '$d = 0';
td0 '$scalar', $exp;
tdd { d0 '$scalar' } "$header \$scalar = 'myvalue'\n", '$scalar d0';
tdd { d0 '@list' } $rl, '@list d0';
tdd { d0 '%hash' } $rh, '%hash d0';
tdd { D '$scalar' } "$header \$scalar = 'myvalue'\n", '$scalar D';
tdd { D '@list' } $rl, '@list D';
tdd { D '%hash' } $rh, '%hash D';
}
}
if ( runtests('testArray') ) {
say "\n### testArray";
$d = 1;
stdout_like { d('@list') } $rl, '@list';
stdout_like { d '@list' } $rl, '@list';
td '@list', $rl;
td '@list', $rl;
td '$listref', $rl;
# The next two tests use stdout_like since td() only takes one argument for d()
stdout_like { d('@list', 1 ) } $rl, '@list 1';
stdout_like { d '@list', 1 } $rl, '@list 1';
td '$list[0]', "$header \$list[0] = 'zero'\n";
td '$list[-1]', "$header \$list[-1] = '3'\n";
td '$listref->[0]', "$header \$listref->[0] = 'zero'\n";
td '$listref->[-1]', "$header \$listref->[-1] = '3'\n";
td '${listref}', $rl;
td '@{list}', $rl;
td '$nestedlist[1]', qr($header${vr}\[\s+2,\s+3\s+\]);
td '$nestedlist[1][1]', "$header \$nestedlist[1][1] = 3\n";
for $i ( 0 .. 1 ) {
# Needed to change call for testing purposes
# This does not do a good job of testing, but I don't have any better ideas yet
# The same problem is in the hash tests
#d('$list[$i]');
#d('$listref->[$i]');
#td "\$list[\$i]", qr($header${vr}'?$list[$i]'?);
#td '$list[$i]', qr($header${vr}'?$list[$i]'?);
td "\$list[$i]", qr($header${vr}'?$list[$i]'?);
t/DebugStatementsTest.t view on Meta::CPAN
tdd { d('%hash') } $rh, '%hash normal';
tdd { d('@list', 'e') } $rle, '@list with number of elements';
tdd { d('%hash', 'e') } $rhe, '%hash with number of elements';
tdd { d('@list') } $rl, '@list normal';
tdd { d('%hash') } $rh, '%hash normal';
tdd { d('@list', 'e*') } $rle, '@list with number of elements';
tdd { d('%hash', 'e*') } $rhe, '%hash with number of elements';
tdd { d('@list', 'E*') } $rl, '@list normal';
tdd { d('%hash', 'E*') } $rh, '%hash normal';
}
if ( runtests('testOption_lineNumber') ) {
say "\n### testOption_lineNumber";
tdd { d('$scalar') } "$header \$scalar = 'myvalue'\n", 'normal';
tdd { d('$scalar', 'n') } "$header At line undef: \$scalar = 'myvalue'\n", 'with line number';
tdd { d('$scalar') } "$header \$scalar = 'myvalue'\n", 'normal';
tdd { d('$scalar', 'n*') } "$header At line undef: \$scalar = 'myvalue'\n", 'with line number';
tdd { d('$scalar', 'N*') } "$header \$scalar = 'myvalue'\n", 'normal';
}
if ( runtests('testOption_tRuncate') ) {
say "\n### testOption_tRuncate";
tdd { d('%nestedhash') } $rn, '%nestedhash normal';
Debug::Statements::setTruncate(3);
tdd { d('%nestedhash', 'r') } $rnt, '%nestedhash truncated';
Debug::Statements::setTruncate(5);
tdd { d('%nestedhash') } $rn, '%nestedhash normal';
}
if ( runtests('testOption_Sort') ) {
say "\n### testOption_Sort";
tdd { d('@list') } $rl, '@list normal';
tdd { d('%hash') } $rh, '%hash normal';
tdd { d('@list', 's') } $rls, '@list sorted';
tdd { d('%hash', 's') } $rhs, '%hash sorted';
tdd { d('@list') } $rl, '@list normal';
tdd { d('%hash') } $rh, '%hash normal';
tdd { d('@list', 's*') } $rls, '@list sorted';
tdd { d('%hash', 's*') } $rhs, '%hash sorted';
tdd { d('@list', 'S*') } $rl, '@list normal';
tdd { d('%hash', 'S*') } $rh, '%hash normal';
}
if ( runtests('testOption_Timestamp') ) {
say "\n### testOption_Timestamp";
tdd { d('$scalar') } qr($header${vr}'myvalue'), 'normal';
tdd { d('$scalar', 't') } qr($header${vr}'myvalue'\s+at\s+\S+), 'timestamp';
}
if ( runtests('testOptions_multiple') ) {
say "\n### testOptions_multiple";
tdd { d('$scalar') } qr($header${vr}'myvalue'), '$scalar normal';
tdd { d('@list') } $rl, '@list normal';
tdd { d('%hash') } $rh, '%hash normal';
my $i = 1;
tdd { d('$listref->[$i]') } qr($header${vr}'?$listref->[$i]'?), '$listref->[$i]';
my $ref = 'flintstones';
tdd { d('$nestedhashref->{$ref}') } $rnf, '$nestedhashref->{flintstones}';
tdd { d('$Data::Dumper::Terse') } "$header \$Data::Dumper::Terse = 1\n", 'package variable';
my $allopt = 'bcenstz';
if ( $] lt '5.018' ) {
tdd { d('$scalar', $allopt) } qr($header At line undef:\s+[\$\@\%]\S+\s+=\s+'myvalue'\s+at\s+\S+), '$scalar with all options';
my $rlest = qr($header\s+At line undef:.*\d+.*\s+${lsort}\s+at\s+\S+);
my $rhest = qr($header\s+At line undef:.*\d+.*\s+${h}\s+at\s+\S+);
tdd { d('@list', $allopt) } $rlest, '@list with all options';
tdd { d('%hash', $allopt) } $rhest, '%hash with all options';
tdd { d('$scalar', 'a') } qr(does not understand your option), 'invalid option a';
}
# tests not implemented
#d( '$listref->[$i]', $allopt );
#d( '$nestedhashref->{$ref}', $allopt );
#d( '$Data::Dumper::Terse', $allopt );
}
if ( runtests('testOption_Q') ) {
say "\n### testOption_Q";
tdd { d('$scalar = "foo";') } qr($header${vr}'myvalue'\s+=\s+"foo";), 'default handling of parsed line from Perl script';
tdd { d('$scalar = "foo";', 'q') } qr($header\s+\$scalar\s+=\s+"foo";), 'desired behavior';
}
if ( runtests('testOption_Die') ) {
say "\n### testOption_Die";
tdd { d('$scalar') } qr($header${vr}'myvalue'), 'normal';
$d = 0;
lives_ok { d('$scalar', 'x') } 'should not die (will print DEBUG line underneath)';
$d = 1;
dies_ok { d('$scalar', 'x') } 'should die';
}
if ( runtests('testLsl') ) {
say "\n### testLsl";
my $rd;
my $windows = ($^O =~ /Win/) ? 1 : 0;
if ( $windows ) {
# do nothing
} else {
if ( $windows ) {
# Volume in drive C is OSDisk
$rd = '\s*Volume in';
#$rd = '\s*';
#return; # ls() seems to work on Windows, but my tests fail
} else {
# -rwxrwxr-x 1 ckoknat hardware 29506 Dec 18 11:28 DebugStatementsTest.t
$rd = '\S+\s+\d+\s+\S+\s+\S+\s+\S+\s+\S+\s+\S+\s+\S+\s+\S+';
}
my $header = 'DEBUG: ls -l = ';
$d = 0;
tdd { ls($0) } qr(), "File ls($0)";
tdd { LS($0) } qr($header$rd), "File ls($0)";
$d = 1;
tdd { ls("filename_does_not_exist") } qr(does not exist), 'ls(filename_does_not_exist)';
tdd { ls('$filename') } qr(did not understand file name), "ls('\$filename') error";
tdd { ls($0) } qr($header$rd), "File ls($0)";
if ( $] lt '5.018' ) {
tdd { ls('.') } qr($header$rd), "Directory ls(.)";
tdd { ls("$0 $0") } qr($header$rd.*\n$header$rd), "ls($0 $0)";
tdd { ls("$0 .") } qr($header$rd.*\n$header$rd), "ls($0 .)";
##tdd { ls($filename), 2 } '', 'ls() with too high a debug level';
}
######### Need to create test for directory
######### Need to create test for ls('$dir', '-lR')
}
}
#test_PerlCritic("/home/ckoknat/s/regression/Debug/Statements.pm");die; ########
Test::More::done_testing();
## Print pass/fail summary
summary();
exit 0;
#####################################################################
sub summary {
# Print message if any test failed
my ($passed,$failed) = (0,0);
my @tests = Test::More->builder->details;
my @failed;
my $i = 0;
for my $test (@tests) {
$i++;
if ($test->{ok}) {$passed++} else {$failed++; push @failed, $i};
}
if ( $failed ) {
#print "\n################################ $failed tests FAILED ################################\n";
print "\n################################ tests " . (join " ", @failed) . " FAILED ################################\n";
} else {
#print "\nAll tests passed\n";
print "\n################################ all tests passed ################################\n";
}
return $failed;
}
sub runtests {
my $regex = shift;
if ( $t =~ /^($regex|ALL)$/ ) {
print "\n*** $regex ***\n";
return 1;
} else {
return 0;
}
}
#test_PerlCritic($file)
sub test_PerlCritic {
my $file = shift;
# 5.8.6 does not have Test::Perl::Critic
#my @exclude = ( qw( RequireExtendedFormatting RequireDotMatchAnything RequireLineBoundaryMatching ProhibitImplicitNewlines ProhibitReusedNames ProhibitConstantPragma ProhibitPostfixControls ProhibitExcessMainComplexity ) );
###### fix the next few lines and copy to k.t and CPN.t and cpn.t OR better yet include it with regression
##use Test::Perl::Critic( -severity => 3, -exclude => ['RequireExtendedFormatting','RequireDotMatchAnything','RequireLineBoundaryMatching','ProhibitImplicitNewlines','ProhibitReusedNames','ProhibitConstantPragma','ProhibitPostfixControls','Prohib...
##Test::Perl::Critic::critic_ok($file, "Test::Perl::Critic for $file with severity level 3 but excluding:\n " . join "\n ", ('RequireExtendedFormatting','RequireDotMatchAnything','RequireLineBoundaryMatching','ProhibitImplicitNewlines','...
#use Test::Perl::Critic( -severity => 3, -exclude => [ qw( RequireExtendedFormatting RequireDotMatchAnything RequireLineBoundaryMatching ProhibitImplicitNewlines ProhibitReusedNames ProhibitConstantPragma ProhibitPostfixControls ProhibitExcessMa...
#use Test::Perl::Critic(
( run in 2.673 seconds using v1.01-cache-2.11-cpan-a49fcb8fa48 )