diff options
Diffstat (limited to 'lib/DB.t')
-rw-r--r-- | lib/DB.t | 686 |
1 files changed, 343 insertions, 343 deletions
@@ -1,8 +1,8 @@ #!./perl -w BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; + chdir 't' if -d 't'; + @INC = '../lib'; } # symbolic references used later @@ -17,65 +17,65 @@ use Test::More tests => 106; # must happen at compile time for DB:: package variable localizations to work BEGIN { - use_ok( 'DB' ); + use_ok( 'DB' ); } # test DB::sub() { - my $callflag = 0; - local $DB::sub = sub { - $callflag += shift || 1; - my @vals = (1, 4, 9); - return @vals; - }; - my $ret = DB::sub; - is( $ret, 3, 'DB::sub() should handle scalar context' ); - is( $callflag, 1, '... should call $DB::sub contents' ); - $ret = join(' ', DB::sub(2)); - is( $ret, '1 4 9', '... should handle scalar context' ); - is( $callflag, 3, '... should pass along arguments to the sub' ); - ok( defined($DB::ret),'$DB::ret should be defined after successful return'); - DB::sub; - ok( !defined($DB::ret), '... should respect void context' ); - $DB::sub = '::DESTROY'; - ok( !defined($DB::ret), '... should return undef for DESTROY()' ); + my $callflag = 0; + local $DB::sub = sub { + $callflag += shift || 1; + my @vals = (1, 4, 9); + return @vals; + }; + my $ret = DB::sub; + is( $ret, 3, 'DB::sub() should handle scalar context' ); + is( $callflag, 1, '... should call $DB::sub contents' ); + $ret = join(' ', DB::sub(2)); + is( $ret, '1 4 9', '... should handle scalar context' ); + is( $callflag, 3, '... should pass along arguments to the sub' ); + ok( defined($DB::ret),'$DB::ret should be defined after successful return'); + DB::sub; + ok( !defined($DB::ret), '... should respect void context' ); + $DB::sub = '::DESTROY'; + ok( !defined($DB::ret), '... should return undef for DESTROY()' ); } # test DB::DB() { - ok( ! defined DB::DB(), - 'DB::DB() should return undef if $DB::ready is false'); - is( DB::catch(), 1, 'DB::catch() should work' ); - is( DB->skippkg('foo'), 1, 'DB->skippkg() should push args' ); + ok( ! defined DB::DB(), + 'DB::DB() should return undef if $DB::ready is false'); + is( DB::catch(), 1, 'DB::catch() should work' ); + is( DB->skippkg('foo'), 1, 'DB->skippkg() should push args' ); - # change packages to mess with caller() - package foo; - ::ok( ! defined DB::DB(), 'DB::DB() should skip skippable packages' ); + # change packages to mess with caller() + package foo; + ::ok( ! defined DB::DB(), 'DB::DB() should skip skippable packages' ); - package main; - is( $DB::filename, $0, '... should set $DB::filename' ); - is( $DB::lineno, __LINE__ - 4, '... should set $DB::lineno' ); + package main; + is( $DB::filename, $0, '... should set $DB::filename' ); + is( $DB::lineno, __LINE__ - 4, '... should set $DB::lineno' ); - DB::DB(); - # stops at line 94 + DB::DB(); + # stops at line 94 } # test DB::save() { no warnings 'uninitialized'; - # assigning a number to $! seems to produce an error message, when read - local ($@, $,, $/, $\, $^W, $!) = (1 .. 5); - DB::save(); - is( "$@$!$,$/$\$^W", "1\n0", 'DB::save() should reset punctuation vars' ); + # assigning a number to $! seems to produce an error message, when read + local ($@, $,, $/, $\, $^W, $!) = (1 .. 5); + DB::save(); + is( "$@$!$,$/$\$^W", "1\n0", 'DB::save() should reset punctuation vars' ); } # test DB::catch() { - local $DB::signal; - DB::catch(); - ok( $DB::signal, 'DB::catch() should set $DB::signal' ); - # add clients and test to see if they are awakened + local $DB::signal; + DB::catch(); + ok( $DB::signal, 'DB::catch() should set $DB::signal' ); + # add clients and test to see if they are awakened } # test DB::_clientname() @@ -84,61 +84,61 @@ is( DB::_clientname('bar'), '','DB::_clientname should not return non refname'); # test DB::next() and DB::step() { - local $DB::single; - DB->next(); - is( $DB::single, 2, 'DB->next() should set $DB::single to 2' ); - DB->step(); - is( $DB::single, 1, 'DB->step() should set $DB::single to 1' ); + local $DB::single; + DB->next(); + is( $DB::single, 2, 'DB->next() should set $DB::single to 2' ); + DB->step(); + is( $DB::single, 1, 'DB->step() should set $DB::single to 1' ); } # test DB::cont() { - # cannot test @stack + # cannot test @stack - local $DB::single = 1; - my $fdb = FakeDB->new(); - DB::cont($fdb, 2); - is( $fdb->{tbreak}, 2, 'DB::cont() should set tbreak in object' ); - is( $DB::single, 0, '... should set $DB::single to 0' ); + local $DB::single = 1; + my $fdb = FakeDB->new(); + DB::cont($fdb, 2); + is( $fdb->{tbreak}, 2, 'DB::cont() should set tbreak in object' ); + is( $DB::single, 0, '... should set $DB::single to 0' ); } # test DB::ret() { - # cannot test @stack + # cannot test @stack - local $DB::single = 1; - DB::ret(); - is( $DB::single, 0, 'DB::ret() should set $DB::single to 0' ); + local $DB::single = 1; + DB::ret(); + is( $DB::single, 0, 'DB::ret() should set $DB::single to 0' ); } # test DB::backtrace() { - local (@DB::args, $DB::signal); - - my $line = __LINE__ + 1; - my @ret = eval { DB->backtrace() }; - like( $ret[0], qr/file.+\Q$0\Q/, 'DB::backtrace() should report current file'); - like( $ret[0], qr/line $line/, '... should report calling line number' ); - like( $ret[0], qr/eval {...}/, '... should catch eval BLOCK' ); - - @ret = eval "one(2)"; - is( scalar @ret, 1, '... should report from provided stack frame number' ); - like( $ret[0], qr/\@ = &eval \'one.+?2\)\'/, #' - '... should find eval STRING construct'); - $ret[0] = check_context(1); - like( $ret[0], qr/\$ = &main::check_context/, - '... should respect context of calling construct'); - - $DB::signal = 1; - @DB::args = (1, 7); - @ret = three(1); - is( scalar @ret, 1, '... should end loop if $DB::signal is true' ); - - # does not check 'require' or @DB::args mangling + local (@DB::args, $DB::signal); + + my $line = __LINE__ + 1; + my @ret = eval { DB->backtrace() }; + like( $ret[0], qr/file.+\Q$0\E/, 'DB::backtrace() should report current file'); + like( $ret[0], qr/line $line/, '... should report calling line number' ); + like( $ret[0], qr/eval {...}/, '... should catch eval BLOCK' ); + + @ret = eval "one(2)"; + is( scalar @ret, 1, '... should report from provided stack frame number' ); + like( $ret[0], qr/\@ = &eval \'one.+?2\)\'/, #' + '... should find eval STRING construct'); + $ret[0] = check_context(1); + like( $ret[0], qr/\$ = &main::check_context/, + '... should respect context of calling construct'); + + $DB::signal = 1; + @DB::args = (1, 7); + @ret = three(1); + is( scalar @ret, 1, '... should end loop if $DB::signal is true' ); + + # does not check 'require' or @DB::args mangling } sub check_context { - return (eval "one($_[0])")[-1]; + return (eval "one($_[0])")[-1]; } sub one { DB->backtrace(@_) } sub two { one(@_) } @@ -146,334 +146,334 @@ sub three { two(@_) } # test DB::trace_toggle { - local $DB::trace = 0; - DB->trace_toggle; - ok( $DB::trace, 'DB::trace_toggle() should toggle $DB::trace' ); - DB->trace_toggle; - ok( !$DB::trace, '... should toggle $DB::trace (back)' ); + local $DB::trace = 0; + DB->trace_toggle; + ok( $DB::trace, 'DB::trace_toggle() should toggle $DB::trace' ); + DB->trace_toggle; + ok( !$DB::trace, '... should toggle $DB::trace (back)' ); } # test DB::subs() { - local %DB::sub; - my $subs = DB->subs; - is( $subs, 0, 'DB::subs() should return keys of %DB::subs' ); - %DB::sub = ( foo => 'foo:23-45' , bar => 'ba:r:7-890' ); - $subs = DB->subs; - is( $subs, 2, '... same song, different key' ); - my @subs = DB->subs( 'foo', 'boo', 'bar' ); - is( scalar @subs, 2, '... should report only for requested subs' ); - my @expected = ( [ 'foo', 23, 45 ], [ 'ba:r', 7, 890 ] ); - ok( eq_array( \@subs, \@expected ), '... find file, start, end for subs' ); + local %DB::sub; + my $subs = DB->subs; + is( $subs, 0, 'DB::subs() should return keys of %DB::subs' ); + %DB::sub = ( foo => 'foo:23-45' , bar => 'ba:r:7-890' ); + $subs = DB->subs; + is( $subs, 2, '... same song, different key' ); + my @subs = DB->subs( 'foo', 'boo', 'bar' ); + is( scalar @subs, 2, '... should report only for requested subs' ); + my @expected = ( [ 'foo', 23, 45 ], [ 'ba:r', 7, 890 ] ); + ok( eq_array( \@subs, \@expected ), '... find file, start, end for subs' ); } # test DB::filesubs() { - local ($DB::filename, %DB::sub); - $DB::filename = 'baz'; - %DB::sub = map { $_ => $_ } qw( bazbar bazboo boobar booboo boobaz ); - my @ret = DB->filesubs(); - is( scalar @ret, 2, 'DB::filesubs() should use $DB::filename with no args'); - @ret = grep { /^baz/ } @ret; - is( scalar @ret, 2, '... should pick up subs in proper file' ); - @ret = DB->filesubs('boo'); - is( scalar @ret, 3, '... should use argument to find subs' ); - @ret = grep { /^boo/ } @ret; - is( scalar @ret, 3, '... should pick up subs in proper file with argument'); + local ($DB::filename, %DB::sub); + $DB::filename = 'baz'; + %DB::sub = map { $_ => $_ } qw( bazbar bazboo boobar booboo boobaz ); + my @ret = DB->filesubs(); + is( scalar @ret, 2, 'DB::filesubs() should use $DB::filename with no args'); + @ret = grep { /^baz/ } @ret; + is( scalar @ret, 2, '... should pick up subs in proper file' ); + @ret = DB->filesubs('boo'); + is( scalar @ret, 3, '... should use argument to find subs' ); + @ret = grep { /^boo/ } @ret; + is( scalar @ret, 3, '... should pick up subs in proper file with argument'); } # test DB::files() { - my $dbf = () = DB::files(); - my $main = () = grep ( m!^_<!, keys %main:: ); - is( $dbf, $main, 'DB::files() should pick up filenames from %main::' ); + my $dbf = () = DB::files(); + my $main = () = grep ( m!^_<!, keys %main:: ); + is( $dbf, $main, 'DB::files() should pick up filenames from %main::' ); } # test DB::lines() { - local @DB::dbline = ( 'foo' ); - is( DB->lines->[0], 'foo', 'DB::lines() should return ref to @DB::dbline' ); + local @DB::dbline = ( 'foo' ); + is( DB->lines->[0], 'foo', 'DB::lines() should return ref to @DB::dbline' ); } # test DB::loadfile() SKIP: { - local (*DB::dbline, $DB::filename); - ok( ! defined DB->loadfile('notafile'), - 'DB::loadfile() should not find unloaded file' ); - my $file = (grep { m|^_<.+\.pm| } keys %main:: )[0]; - skip('cannot find loaded file', 3) unless $file; - $file =~ s/^_<..//; + local (*DB::dbline, $DB::filename); + ok( ! defined DB->loadfile('notafile'), + 'DB::loadfile() should not find unloaded file' ); + my $file = (grep { m|^_<.+\.pm| } keys %main:: )[0]; + skip('cannot find loaded file', 3) unless $file; + $file =~ s/^_<..//; - my $db = DB->loadfile($file); - like( $db, qr!$file\z!, '... should find loaded file from partial name'); + my $db = DB->loadfile($file); + like( $db, qr!$file\z!, '... should find loaded file from partial name'); - is( *DB::dbline, *{ "_<$db" } , - '... should set *DB::dbline to associated glob'); - is( $DB::filename, $db, '... should set $DB::filename to file name' ); + is( *DB::dbline, *{ "_<$db" } , + '... should set *DB::dbline to associated glob'); + is( $DB::filename, $db, '... should set $DB::filename to file name' ); - # test clients + # test clients } # test DB::lineevents() { - use vars qw( *baz ); - - local $DB::filename = 'baz'; - local *baz = *{ "main::_<baz" }; - - @baz = map { dualvar(1, $_) } qw( one two three four five ); - %baz = ( - 1 => "foo\0bar", - 3 => "boo\0far", - 4 => "fazbaz", - ); - my %ret = DB->lineevents(); - is( scalar keys %ret, 3, 'DB::lineevents() should pick up defined lines' ); - - # array access in DB::lineevents() starts at element 1, not 0 - is( join(' ', @{ $ret{1} }), 'two foo bar', '... should stash data in hash'); + use vars qw( *baz ); + + local $DB::filename = 'baz'; + local *baz = *{ "main::_<baz" }; + + @baz = map { dualvar(1, $_) } qw( one two three four five ); + %baz = ( + 1 => "foo\0bar", + 3 => "boo\0far", + 4 => "fazbaz", + ); + my %ret = DB->lineevents(); + is( scalar keys %ret, 3, 'DB::lineevents() should pick up defined lines' ); + + # array access in DB::lineevents() starts at element 1, not 0 + is( join(' ', @{ $ret{1} }), 'two foo bar', '... should stash data in hash'); } # test DB::set_break() { - local ($DB::lineno, *DB::dbline, $DB::package); - - %DB::dbline = ( - 1 => "\0", - 2 => undef, - 3 => "123\0\0\0abc", - 4 => "\0abc", - ); - - *DB::dbline = [ $dualfalse, $dualtrue, $dualfalse, $dualfalse, $dualtrue ]; - - local %DB::sub = ( - 'main::foo' => 'foo:1-4', - ); - - DB->set_break(1, 'foo'); - is( $DB::dbline{1}, "foo\0", 'DB::set_break() should set break condition' ); - - $DB::lineno = 1; - DB->set_break(undef, 'bar'); - is( $DB::dbline{1}, "bar\0", - '... should use $DB::lineno without specified line' ); - - DB->set_break(4); - is( $DB::dbline{4}, "1\0abc", '... should use default condition if needed'); - - local %DB::sub = ( - 'main::foo' => 'foo:1-4', - ); - DB->set_break('foo', 'baz'); - is( $DB::dbline{4}, "baz\0abc", - '... should use _find_subline() to resolve subname' ); - - my $db = FakeDB->new(); - DB::set_break($db, 2); - like( $db->{output}, qr/2 not break/, '... should respect @DB::dbline' ); - - DB::set_break($db, 'nonfoo'); - like( $db->{output}, qr/not found/, '... should warn on unfound sub' ); + local ($DB::lineno, *DB::dbline, $DB::package); + + %DB::dbline = ( + 1 => "\0", + 2 => undef, + 3 => "123\0\0\0abc", + 4 => "\0abc", + ); + + *DB::dbline = [ $dualfalse, $dualtrue, $dualfalse, $dualfalse, $dualtrue ]; + + local %DB::sub = ( + 'main::foo' => 'foo:1-4', + ); + + DB->set_break(1, 'foo'); + is( $DB::dbline{1}, "foo\0", 'DB::set_break() should set break condition' ); + + $DB::lineno = 1; + DB->set_break(undef, 'bar'); + is( $DB::dbline{1}, "bar\0", + '... should use $DB::lineno without specified line' ); + + DB->set_break(4); + is( $DB::dbline{4}, "1\0abc", '... should use default condition if needed'); + + local %DB::sub = ( + 'main::foo' => 'foo:1-4', + ); + DB->set_break('foo', 'baz'); + is( $DB::dbline{4}, "baz\0abc", + '... should use _find_subline() to resolve subname' ); + + my $db = FakeDB->new(); + DB::set_break($db, 2); + like( $db->{output}, qr/2 not break/, '... should respect @DB::dbline' ); + + DB::set_break($db, 'nonfoo'); + like( $db->{output}, qr/not found/, '... should warn on unfound sub' ); } # test DB::set_tbreak() { - local ($DB::lineno, *DB::dbline, $DB::package); - *DB::dbline = [ $dualfalse, $dualtrue, $dualfalse, $dualfalse, $dualtrue ]; + local ($DB::lineno, *DB::dbline, $DB::package); + *DB::dbline = [ $dualfalse, $dualtrue, $dualfalse, $dualfalse, $dualtrue ]; - DB->set_tbreak(1); - is( $DB::dbline{1}, ';9', 'DB::set_tbreak() should set tbreak condition' ); + DB->set_tbreak(1); + is( $DB::dbline{1}, ';9', 'DB::set_tbreak() should set tbreak condition' ); - local %DB::sub = ( - 'main::foo' => 'foo:1-4', - ); - DB->set_tbreak('foo', 'baz'); - is( $DB::dbline{4}, ';9', - '... should use _find_subline() to resolve subname' ); + local %DB::sub = ( + 'main::foo' => 'foo:1-4', + ); + DB->set_tbreak('foo', 'baz'); + is( $DB::dbline{4}, ';9', + '... should use _find_subline() to resolve subname' ); - my $db = FakeDB->new(); - DB::set_tbreak($db, 2); - like( $db->{output}, qr/2 not break/, '... should respect @DB::dbline' ); + my $db = FakeDB->new(); + DB::set_tbreak($db, 2); + like( $db->{output}, qr/2 not break/, '... should respect @DB::dbline' ); - DB::set_break($db, 'nonfoo'); - like( $db->{output}, qr/not found/, '... should warn on unfound sub' ); + DB::set_break($db, 'nonfoo'); + like( $db->{output}, qr/not found/, '... should warn on unfound sub' ); } # test DB::_find_subline() { - my @foo; - local *{ "::_<foo" } = \@foo; - - local $DB::package; - local %DB::sub = ( - 'TEST::foo' => 'foo:10-15', - 'main::foo' => 'foo:11-12', - 'bar::bar' => 'foo:10-16', - ); - - $foo[11] = $dualtrue; - - is( DB::_find_subline('TEST::foo'), 11, - 'DB::_find_subline() should find fully qualified sub' ); - is( DB::_find_subline("TEST'foo"), 11, '... should handle old package sep'); - is( DB::_find_subline('foo'), 11, - '... should resolve unqualified package name to main::' ); - - $DB::package = 'bar'; - is( DB::_find_subline('bar'), 11, - '... should resolve unqualified name with $DB::package, if defined' ); - - $foo[11] = $dualfalse; - - is( DB::_find_subline('TEST::foo'), 15, - '... should increment past lines with no events' ); - - ok( ! defined DB::_find_subline('sirnotappearinginthisfilm'), - '... should not find nonexistant sub' ); + my @foo; + local *{ "::_<foo" } = \@foo; + + local $DB::package; + local %DB::sub = ( + 'TEST::foo' => 'foo:10-15', + 'main::foo' => 'foo:11-12', + 'bar::bar' => 'foo:10-16', + ); + + $foo[11] = $dualtrue; + + is( DB::_find_subline('TEST::foo'), 11, + 'DB::_find_subline() should find fully qualified sub' ); + is( DB::_find_subline("TEST'foo"), 11, '... should handle old package sep'); + is( DB::_find_subline('foo'), 11, + '... should resolve unqualified package name to main::' ); + + $DB::package = 'bar'; + is( DB::_find_subline('bar'), 11, + '... should resolve unqualified name with $DB::package, if defined' ); + + $foo[11] = $dualfalse; + + is( DB::_find_subline('TEST::foo'), 15, + '... should increment past lines with no events' ); + + ok( ! defined DB::_find_subline('sirnotappearinginthisfilm'), + '... should not find nonexistant sub' ); } # test DB::clr_breaks() { - local *DB::dbline; - my %lines = ( - 1 => "\0", - 2 => undef, - 3 => "123\0\0\0abc", - 4 => "\0\0\0abc", - ); - - %DB::dbline = %lines; - DB->clr_breaks(1 .. 4); - is( scalar keys %DB::dbline, 3, 'DB::clr_breaks() should clear breaks' ); - ok( ! exists($DB::dbline{1}), '... should delete empty actions' ); - is( $DB::dbline{3}, "\0\0\0abc", '... should remove break, leaving action'); - is( $DB::dbline{4}, "\0\0\0abc", '... should not remove set actions' ); - - local *{ "::_<foo" } = [ 0, 0, 0, 1 ]; - - local $DB::package; - local %DB::sub = ( - 'main::foo' => 'foo:1-3', - ); - - %DB::dbline = %lines; - DB->clr_breaks('foo'); - - is( $DB::dbline{3}, "\0\0\0abc", - '... should find lines via _find_subline()' ); - - my $db = FakeDB->new(); - DB::clr_breaks($db, 'abadsubname'); - is( $db->{output}, "Subroutine not found.\n", - '... should output warning if sub cannot be found'); - - @DB::dbline = (1 .. 4); - %DB::dbline = (%lines, 5 => "\0" ); - - DB::clr_breaks(); - - is( scalar keys %DB::dbline, 4, - 'Relying on @DB::dbline in DB::clr_breaks() should clear breaks' ); - ok( ! exists($DB::dbline{1}), '... should delete empty actions' ); - is( $DB::dbline{3}, "\0\0\0abc", '... should remove break, leaving action'); - is( $DB::dbline{4}, "\0\0\0abc", '... should not remove set actions' ); - ok( exists($DB::dbline{5}), - '... should only go to last index of @DB::dbline' ); + local *DB::dbline; + my %lines = ( + 1 => "\0", + 2 => undef, + 3 => "123\0\0\0abc", + 4 => "\0\0\0abc", + ); + + %DB::dbline = %lines; + DB->clr_breaks(1 .. 4); + is( scalar keys %DB::dbline, 3, 'DB::clr_breaks() should clear breaks' ); + ok( ! exists($DB::dbline{1}), '... should delete empty actions' ); + is( $DB::dbline{3}, "\0\0\0abc", '... should remove break, leaving action'); + is( $DB::dbline{4}, "\0\0\0abc", '... should not remove set actions' ); + + local *{ "::_<foo" } = [ 0, 0, 0, 1 ]; + + local $DB::package; + local %DB::sub = ( + 'main::foo' => 'foo:1-3', + ); + + %DB::dbline = %lines; + DB->clr_breaks('foo'); + + is( $DB::dbline{3}, "\0\0\0abc", + '... should find lines via _find_subline()' ); + + my $db = FakeDB->new(); + DB::clr_breaks($db, 'abadsubname'); + is( $db->{output}, "Subroutine not found.\n", + '... should output warning if sub cannot be found'); + + @DB::dbline = (1 .. 4); + %DB::dbline = (%lines, 5 => "\0" ); + + DB::clr_breaks(); + + is( scalar keys %DB::dbline, 4, + 'Relying on @DB::dbline in DB::clr_breaks() should clear breaks' ); + ok( ! exists($DB::dbline{1}), '... should delete empty actions' ); + is( $DB::dbline{3}, "\0\0\0abc", '... should remove break, leaving action'); + is( $DB::dbline{4}, "\0\0\0abc", '... should not remove set actions' ); + ok( exists($DB::dbline{5}), + '... should only go to last index of @DB::dbline' ); } # test DB::set_action() { - local *DB::dbline; + local *DB::dbline; - %DB::dbline = ( - 2 => "\0abc", - ); + %DB::dbline = ( + 2 => "\0abc", + ); - *DB::dbline = [ $dualfalse, $dualfalse, $dualtrue, $dualtrue ]; + *DB::dbline = [ $dualfalse, $dualfalse, $dualtrue, $dualtrue ]; - DB->set_action(2, 'def'); - is( $DB::dbline{2}, "\0def", - 'DB::set_action() should replace existing action' ); - DB->set_action(3, ''); - is( $DB::dbline{3}, "\0", '... should set new action' ); + DB->set_action(2, 'def'); + is( $DB::dbline{2}, "\0def", + 'DB::set_action() should replace existing action' ); + DB->set_action(3, ''); + is( $DB::dbline{3}, "\0", '... should set new action' ); - my $db = FakeDB->new(); - DB::set_action($db, 'abadsubname'); - is( $db->{output}, "Subroutine not found.\n", - '... should output warning if sub cannot be found'); + my $db = FakeDB->new(); + DB::set_action($db, 'abadsubname'); + is( $db->{output}, "Subroutine not found.\n", + '... should output warning if sub cannot be found'); - DB::set_action($db, 1); - like( $db->{output}, qr/1 not action/, - '... should warn if line cannot be actionivated' ); + DB::set_action($db, 1); + like( $db->{output}, qr/1 not action/, + '... should warn if line cannot be actionivated' ); } # test DB::clr_actions() { - local *DB::dbline; - my %lines = ( - 1 => "\0", - 2 => undef, - 3 => "123\0abc", - 4 => "abc\0", - ); - - %DB::dbline = %lines; - *DB::dbline = [ ($dualtrue) x 4 ]; - - DB->clr_actions(1 .. 4); - - is( scalar keys %DB::dbline, 2, 'DB::clr_actions() should clear actions' ); - ok( ! exists($DB::dbline{1}), '... should delete empty actions' ); - is( $DB::dbline{3}, "123", '... should remove action, leaving break'); - is( $DB::dbline{4}, "abc\0", '... should not remove set breaks' ); - - local *{ "::_<foo" } = [ 0, 0, 0, 1 ]; - - local $DB::package; - local %DB::sub = ( - 'main::foo' => 'foo:1-3', - ); - - %DB::dbline = %lines; - DB->clr_actions('foo'); - - is( $DB::dbline{3}, "123", '... should find lines via _find_subline()' ); - - my $db = FakeDB->new(); - DB::clr_actions($db, 'abadsubname'); - is( $db->{output}, "Subroutine not found.\n", - '... should output warning if sub cannot be found'); - - @DB::dbline = (1 .. 4); - %DB::dbline = (%lines, 5 => "\0" ); - - DB::clr_actions(); - - is( scalar keys %DB::dbline, 4, - 'Relying on @DB::dbline in DB::clr_actions() should clear actions' ); - ok( ! exists($DB::dbline{1}), '... should delete empty actions' ); - is( $DB::dbline{3}, "123", '... should remove action, leaving break'); - is( $DB::dbline{4}, "abc\0", '... should not remove set breaks' ); - ok( exists($DB::dbline{5}), - '... should only go to last index of @DB::dbline' ); + local *DB::dbline; + my %lines = ( + 1 => "\0", + 2 => undef, + 3 => "123\0abc", + 4 => "abc\0", + ); + + %DB::dbline = %lines; + *DB::dbline = [ ($dualtrue) x 4 ]; + + DB->clr_actions(1 .. 4); + + is( scalar keys %DB::dbline, 2, 'DB::clr_actions() should clear actions' ); + ok( ! exists($DB::dbline{1}), '... should delete empty actions' ); + is( $DB::dbline{3}, "123", '... should remove action, leaving break'); + is( $DB::dbline{4}, "abc\0", '... should not remove set breaks' ); + + local *{ "::_<foo" } = [ 0, 0, 0, 1 ]; + + local $DB::package; + local %DB::sub = ( + 'main::foo' => 'foo:1-3', + ); + + %DB::dbline = %lines; + DB->clr_actions('foo'); + + is( $DB::dbline{3}, "123", '... should find lines via _find_subline()' ); + + my $db = FakeDB->new(); + DB::clr_actions($db, 'abadsubname'); + is( $db->{output}, "Subroutine not found.\n", + '... should output warning if sub cannot be found'); + + @DB::dbline = (1 .. 4); + %DB::dbline = (%lines, 5 => "\0" ); + + DB::clr_actions(); + + is( scalar keys %DB::dbline, 4, + 'Relying on @DB::dbline in DB::clr_actions() should clear actions' ); + ok( ! exists($DB::dbline{1}), '... should delete empty actions' ); + is( $DB::dbline{3}, "123", '... should remove action, leaving break'); + is( $DB::dbline{4}, "abc\0", '... should not remove set breaks' ); + ok( exists($DB::dbline{5}), + '... should only go to last index of @DB::dbline' ); } # test DB::prestop() ok( ! defined DB::prestop('test'), - 'DB::prestop() should return undef for undef value' ); + 'DB::prestop() should return undef for undef value' ); DB::prestop('test', 897); is( DB::prestop('test'), 897, '... should return value when set' ); # test DB::poststop(), not exactly parallel ok( ! defined DB::poststop('tset'), - 'DB::prestop() should return undef for undef value' ); + 'DB::prestop() should return undef for undef value' ); DB::poststop('tset', 987); is( DB::poststop('tset'), 987, '... should return value when set' ); # test DB::evalcode() ok( ! defined DB::evalcode('foo'), - 'DB::evalcode() should return undef for undef value' ); + 'DB::evalcode() should return undef for undef value' ); DB::evalcode('foo', 'bar'); is( DB::evalcode('foo'), 'bar', '... should return value when set' ); @@ -484,11 +484,11 @@ DB::register( FakeDB->new() ) for ( 1 .. 2); DB::_outputall(1, 2, 3); is( $FakeDB::output, '123123123', - 'DB::_outputall() should call output(@_) on all clients' ); + 'DB::_outputall() should call output(@_) on all clients' ); # test virtual methods for my $method (qw( cprestop cpoststop awaken init stop idle cleanup output )) { - ok( defined &{ "DB::$method" }, "DB::$method() should be defined" ); + ok( defined &{ "DB::$method" }, "DB::$method() should be defined" ); } # DB::skippkg() uses lexical @@ -499,19 +499,19 @@ package FakeDB; use vars qw( $output ); sub new { - bless({}, $_[0]); + bless({}, $_[0]); } sub set_tbreak { - my ($self, $val) = @_; - $self->{tbreak} = $val; + my ($self, $val) = @_; + $self->{tbreak} = $val; } sub output { - my $self = shift; - if (ref $self) { - $self->{output} = join('', @_); - } else { - $output .= join('', @_); - } + my $self = shift; + if (ref $self) { + $self->{output} = join('', @_); + } else { + $output .= join('', @_); + } } |