[perl5.git] / lib / DB.t

#!./perl -Tw

BEGIN {
        chdir 't' if -d 't';
        @INC = '../lib';
	require Config;
	if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){
		print "1..0 # Skip -- Perl configured without List::Util module\n";
		exit 0;
	}
}

# symbolic references used later
use strict qw( vars subs );

# @DB::dbline values have both integer and string components (Benjamin Goldberg)
use Scalar::Util qw( dualvar );
my $dualfalse = dualvar(0, 'false');
my $dualtrue = dualvar(1, 'true');

use Test::More tests => 106;

# must happen at compile time for DB:: package variable localizations to work
BEGIN {
        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()' );
}

# 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' );

        # 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' );

        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' );
}

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

# test DB::_clientname()
is( DB::_clientname('foo=A(1)'), 'foo',
    'DB::_clientname should return refname');
is( DB::_clientname('bar'), undef,
        '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' );
}

# test DB::cont()
{
        # 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' );
}

# test DB::ret()
{
        # cannot test @stack

        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\E/, 'DB::backtrace() should report current file');
        like( $ret[0], qr/line $line/, '... should report calling line number' );
        like( $ret[0], qr/eval\Q {...}/, '... 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];
}
sub one { DB->backtrace(@_) }
sub two { one(@_) }
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)' );
}

# 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' );
}

# 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');
}

# test DB::files()
{
        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' );
}

# 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/^_<..//;

        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' );

        # 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');
}

# 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' );
}

# test DB::set_tbreak()
{
        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' );

        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' );

        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' );
}

# 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' );
}

# test DB::set_action()
{
        local *DB::dbline;

        %DB::dbline = (
                2 => "\0abc",
        );

        *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' );

        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' );
}

# 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' );
}

# test DB::prestop()
ok( ! defined DB::prestop('test'),
        '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::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('foo', 'bar');
is( DB::evalcode('foo'), 'bar', '... should return value when set' );

# test DB::_outputall(), must create fake clients first
ok( DB::register( FakeDB->new() ), 'DB::register() should work' );
DB::register( FakeDB->new() ) for ( 1 .. 2);

DB::_outputall(1, 2, 3);
is( $FakeDB::output, '123123123', 
        '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" );
}

# DB::skippkg() uses lexical
# DB::ready() uses lexical

package FakeDB;

use vars qw( $output );

sub new {
        bless({}, $_[0]);
}

sub set_tbreak {
        my ($self, $val) = @_;
        $self->{tbreak} = $val;
}

sub output {
        my $self = shift;
        if (ref $self) {
                $self->{output} = join('', @_);
        } else {
                $output .= join('', @_);
        }
}
Commit	Line	Data
4940c443	1	#!./perl -Tw
c95f170b	2
c95f170b	3	BEGIN {
acc79e62 JH	4	chdir 't' if -d 't';
acc79e62 JH	5	@INC = '../lib';
78cd8b71	6	require Config;
98641f60	7	if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){
78cd8b71 NC	8	print "1..0 # Skip -- Perl configured without List::Util module\n";
	9	exit 0;
	10	}
c95f170b	11	}
c95f170b	12
4eba29c1	13	# symbolic references used later
	14	use strict qw( vars subs );
	15
	16	# @DB::dbline values have both integer and string components (Benjamin Goldberg)
	17	use Scalar::Util qw( dualvar );
	18	my $dualfalse = dualvar(0, 'false');
	19	my $dualtrue = dualvar(1, 'true');
	20
c95f170b	21	use Test::More tests => 106;
	22
	23	# must happen at compile time for DB:: package variable localizations to work
	24	BEGIN {
acc79e62	25	use_ok( 'DB' );
c95f170b	26	}
	27
	28	# test DB::sub()
	29	{
acc79e62 JH	30	my $callflag = 0;
	31	local $DB::sub = sub {
	32	$callflag += shift \|\| 1;
	33	my @vals = (1, 4, 9);
	34	return @vals;
	35	};
	36	my $ret = DB::sub;
	37	is( $ret, 3, 'DB::sub() should handle scalar context' );
	38	is( $callflag, 1, '... should call $DB::sub contents' );
	39	$ret = join(' ', DB::sub(2));
	40	is( $ret, '1 4 9', '... should handle scalar context' );
	41	is( $callflag, 3, '... should pass along arguments to the sub' );
	42	ok( defined($DB::ret),'$DB::ret should be defined after successful return');
	43	DB::sub;
	44	ok( !defined($DB::ret), '... should respect void context' );
	45	$DB::sub = '::DESTROY';
	46	ok( !defined($DB::ret), '... should return undef for DESTROY()' );
c95f170b	47	}
	48
	49	# test DB::DB()
	50	{
acc79e62 JH	51	ok( ! defined DB::DB(),
	52	'DB::DB() should return undef if $DB::ready is false');
	53	is( DB::catch(), 1, 'DB::catch() should work' );
	54	is( DB->skippkg('foo'), 1, 'DB->skippkg() should push args' );
c95f170b	55
acc79e62 JH	56	# change packages to mess with caller()
	57	package foo;
	58	::ok( ! defined DB::DB(), 'DB::DB() should skip skippable packages' );
c95f170b	59
acc79e62 JH	60	package main;
	61	is( $DB::filename, $0, '... should set $DB::filename' );
	62	is( $DB::lineno, __LINE__ - 4, '... should set $DB::lineno' );
c95f170b	63
acc79e62 JH	64	DB::DB();
acc79e62 JH	65	# stops at line 94
c95f170b	66	}
	67
	68	# test DB::save()
	69	{
eca89c5a CB	70	no warnings 'uninitialized';
eca89c5a CB	71
acc79e62 JH	72	# assigning a number to $! seems to produce an error message, when read
	73	local ($@, $,, $/, $\, $^W, $!) = (1 .. 5);
	74	DB::save();
	75	is( "$@$!$,$/$\$^W", "1\n0", 'DB::save() should reset punctuation vars' );
c95f170b	76	}
	77
	78	# test DB::catch()
	79	{
acc79e62 JH	80	local $DB::signal;
	81	DB::catch();
	82	ok( $DB::signal, 'DB::catch() should set $DB::signal' );
	83	# add clients and test to see if they are awakened
c95f170b	84	}
	85
	86	# test DB::_clientname()
4940c443 MS	87	is( DB::_clientname('foo=A(1)'), 'foo',
4940c443 MS	88	'DB::_clientname should return refname');
881e6572	89	is( DB::_clientname('bar'), undef,
4940c443	90	'DB::_clientname should not return non refname');
c95f170b	91
	92	# test DB::next() and DB::step()
	93	{
acc79e62 JH	94	local $DB::single;
	95	DB->next();
	96	is( $DB::single, 2, 'DB->next() should set $DB::single to 2' );
	97	DB->step();
	98	is( $DB::single, 1, 'DB->step() should set $DB::single to 1' );
c95f170b	99	}
	100
	101	# test DB::cont()
	102	{
acc79e62	103	# cannot test @stack
c95f170b	104
acc79e62 JH	105	local $DB::single = 1;
	106	my $fdb = FakeDB->new();
	107	DB::cont($fdb, 2);
	108	is( $fdb->{tbreak}, 2, 'DB::cont() should set tbreak in object' );
	109	is( $DB::single, 0, '... should set $DB::single to 0' );
c95f170b	110	}
	111
	112	# test DB::ret()
	113	{
acc79e62	114	# cannot test @stack
c95f170b	115
acc79e62 JH	116	local $DB::single = 1;
	117	DB::ret();
	118	is( $DB::single, 0, 'DB::ret() should set $DB::single to 0' );
c95f170b	119	}
	120
	121	# test DB::backtrace()
	122	{
acc79e62 JH	123	local (@DB::args, $DB::signal);
	124
	125	my $line = __LINE__ + 1;
	126	my @ret = eval { DB->backtrace() };
	127	like( $ret[0], qr/file.+\Q$0\E/, 'DB::backtrace() should report current file');
	128	like( $ret[0], qr/line $line/, '... should report calling line number' );
7150f919	129	like( $ret[0], qr/eval\Q {...}/, '... should catch eval BLOCK' );
acc79e62 JH	130
	131	@ret = eval "one(2)";
	132	is( scalar @ret, 1, '... should report from provided stack frame number' );
	133	like( $ret[0], qr/\@ = &eval \'one.+?2\)\'/, #'
	134	'... should find eval STRING construct');
	135	$ret[0] = check_context(1);
	136	like( $ret[0], qr/\$ = &main::check_context/,
	137	'... should respect context of calling construct');
	138
	139	$DB::signal = 1;
	140	@DB::args = (1, 7);
	141	@ret = three(1);
	142	is( scalar @ret, 1, '... should end loop if $DB::signal is true' );
	143
	144	# does not check 'require' or @DB::args mangling
c95f170b	145	}
	146
	147	sub check_context {
acc79e62	148	return (eval "one($_[0])")[-1];
c95f170b	149	}
	150	sub one { DB->backtrace(@_) }
	151	sub two { one(@_) }
	152	sub three { two(@_) }
	153
	154	# test DB::trace_toggle
	155	{
acc79e62 JH	156	local $DB::trace = 0;
	157	DB->trace_toggle;
	158	ok( $DB::trace, 'DB::trace_toggle() should toggle $DB::trace' );
	159	DB->trace_toggle;
	160	ok( !$DB::trace, '... should toggle $DB::trace (back)' );
c95f170b	161	}
	162
	163	# test DB::subs()
	164	{
acc79e62 JH	165	local %DB::sub;
	166	my $subs = DB->subs;
	167	is( $subs, 0, 'DB::subs() should return keys of %DB::subs' );
	168	%DB::sub = ( foo => 'foo:23-45' , bar => 'ba:r:7-890' );
	169	$subs = DB->subs;
	170	is( $subs, 2, '... same song, different key' );
	171	my @subs = DB->subs( 'foo', 'boo', 'bar' );
	172	is( scalar @subs, 2, '... should report only for requested subs' );
	173	my @expected = ( [ 'foo', 23, 45 ], [ 'ba:r', 7, 890 ] );
	174	ok( eq_array( \@subs, \@expected ), '... find file, start, end for subs' );
c95f170b	175	}
	176
	177	# test DB::filesubs()
	178	{
acc79e62 JH	179	local ($DB::filename, %DB::sub);
	180	$DB::filename = 'baz';
	181	%DB::sub = map { $_ => $_ } qw( bazbar bazboo boobar booboo boobaz );
	182	my @ret = DB->filesubs();
	183	is( scalar @ret, 2, 'DB::filesubs() should use $DB::filename with no args');
	184	@ret = grep { /^baz/ } @ret;
	185	is( scalar @ret, 2, '... should pick up subs in proper file' );
	186	@ret = DB->filesubs('boo');
	187	is( scalar @ret, 3, '... should use argument to find subs' );
	188	@ret = grep { /^boo/ } @ret;
	189	is( scalar @ret, 3, '... should pick up subs in proper file with argument');
c95f170b	190	}
	191
	192	# test DB::files()
	193	{
acc79e62 JH	194	my $dbf = () = DB::files();
	195	my $main = () = grep ( m!^_<!, keys %main:: );
	196	is( $dbf, $main, 'DB::files() should pick up filenames from %main::' );
c95f170b	197	}
	198
	199	# test DB::lines()
	200	{
acc79e62 JH	201	local @DB::dbline = ( 'foo' );
acc79e62 JH	202	is( DB->lines->[0], 'foo', 'DB::lines() should return ref to @DB::dbline' );
c95f170b	203	}
	204
	205	# test DB::loadfile()
	206	SKIP: {
acc79e62 JH	207	local (*DB::dbline, $DB::filename);
	208	ok( ! defined DB->loadfile('notafile'),
	209	'DB::loadfile() should not find unloaded file' );
	210	my $file = (grep { m\|^_<.+\.pm\| } keys %main:: )[0];
	211	skip('cannot find loaded file', 3) unless $file;
	212	$file =~ s/^_<..//;
c95f170b	213
acc79e62 JH	214	my $db = DB->loadfile($file);
acc79e62 JH	215	like( $db, qr!$file\z!, '... should find loaded file from partial name');
4eba29c1	216
acc79e62 JH	217	is( DB::dbline, { "_<$db" } ,
	218	'... should set *DB::dbline to associated glob');
	219	is( $DB::filename, $db, '... should set $DB::filename to file name' );
c95f170b	220
acc79e62	221	# test clients
c95f170b	222	}
	223
	224	# test DB::lineevents()
	225	{
acc79e62 JH	226	use vars qw( *baz );
	227
	228	local $DB::filename = 'baz';
	229	local baz = { "main::_<baz" };
	230
	231	@baz = map { dualvar(1, $_) } qw( one two three four five );
	232	%baz = (
	233	1 => "foo\0bar",
	234	3 => "boo\0far",
	235	4 => "fazbaz",
	236	);
	237	my %ret = DB->lineevents();
	238	is( scalar keys %ret, 3, 'DB::lineevents() should pick up defined lines' );
	239
	240	# array access in DB::lineevents() starts at element 1, not 0
	241	is( join(' ', @{ $ret{1} }), 'two foo bar', '... should stash data in hash');
c95f170b	242	}
	243
	244	# test DB::set_break()
	245	{
acc79e62 JH	246	local ($DB::lineno, *DB::dbline, $DB::package);
	247
	248	%DB::dbline = (
	249	1 => "\0",
	250	2 => undef,
	251	3 => "123\0\0\0abc",
	252	4 => "\0abc",
	253	);
	254
	255	*DB::dbline = [ $dualfalse, $dualtrue, $dualfalse, $dualfalse, $dualtrue ];
	256
	257	local %DB::sub = (
	258	'main::foo' => 'foo:1-4',
	259	);
	260
	261	DB->set_break(1, 'foo');
	262	is( $DB::dbline{1}, "foo\0", 'DB::set_break() should set break condition' );
	263
	264	$DB::lineno = 1;
	265	DB->set_break(undef, 'bar');
	266	is( $DB::dbline{1}, "bar\0",
	267	'... should use $DB::lineno without specified line' );
	268
	269	DB->set_break(4);
	270	is( $DB::dbline{4}, "1\0abc", '... should use default condition if needed');
	271
	272	local %DB::sub = (
	273	'main::foo' => 'foo:1-4',
	274	);
	275	DB->set_break('foo', 'baz');
	276	is( $DB::dbline{4}, "baz\0abc",
	277	'... should use _find_subline() to resolve subname' );
	278
	279	my $db = FakeDB->new();
	280	DB::set_break($db, 2);
	281	like( $db->{output}, qr/2 not break/, '... should respect @DB::dbline' );
	282
	283	DB::set_break($db, 'nonfoo');
	284	like( $db->{output}, qr/not found/, '... should warn on unfound sub' );
c95f170b	285	}
	286
	287	# test DB::set_tbreak()
	288	{
acc79e62 JH	289	local ($DB::lineno, *DB::dbline, $DB::package);
acc79e62 JH	290	*DB::dbline = [ $dualfalse, $dualtrue, $dualfalse, $dualfalse, $dualtrue ];
c95f170b	291
acc79e62 JH	292	DB->set_tbreak(1);
acc79e62 JH	293	is( $DB::dbline{1}, ';9', 'DB::set_tbreak() should set tbreak condition' );
c95f170b	294
acc79e62 JH	295	local %DB::sub = (
	296	'main::foo' => 'foo:1-4',
	297	);
	298	DB->set_tbreak('foo', 'baz');
	299	is( $DB::dbline{4}, ';9',
	300	'... should use _find_subline() to resolve subname' );
c95f170b	301
acc79e62 JH	302	my $db = FakeDB->new();
	303	DB::set_tbreak($db, 2);
	304	like( $db->{output}, qr/2 not break/, '... should respect @DB::dbline' );
c95f170b	305
acc79e62 JH	306	DB::set_break($db, 'nonfoo');
acc79e62 JH	307	like( $db->{output}, qr/not found/, '... should warn on unfound sub' );
c95f170b	308	}
	309
	310	# test DB::_find_subline()
	311	{
acc79e62 JH	312	my @foo;
	313	local *{ "::_<foo" } = \@foo;
	314
	315	local $DB::package;
	316	local %DB::sub = (
	317	'TEST::foo' => 'foo:10-15',
	318	'main::foo' => 'foo:11-12',
	319	'bar::bar' => 'foo:10-16',
	320	);
	321
	322	$foo[11] = $dualtrue;
	323
	324	is( DB::_find_subline('TEST::foo'), 11,
	325	'DB::_find_subline() should find fully qualified sub' );
	326	is( DB::_find_subline("TEST'foo"), 11, '... should handle old package sep');
	327	is( DB::_find_subline('foo'), 11,
	328	'... should resolve unqualified package name to main::' );
	329
	330	$DB::package = 'bar';
	331	is( DB::_find_subline('bar'), 11,
	332	'... should resolve unqualified name with $DB::package, if defined' );
	333
	334	$foo[11] = $dualfalse;
	335
	336	is( DB::_find_subline('TEST::foo'), 15,
	337	'... should increment past lines with no events' );
	338
	339	ok( ! defined DB::_find_subline('sirnotappearinginthisfilm'),
	340	'... should not find nonexistant sub' );
c95f170b	341	}
	342
	343	# test DB::clr_breaks()
	344	{
acc79e62 JH	345	local *DB::dbline;
	346	my %lines = (
	347	1 => "\0",
	348	2 => undef,
	349	3 => "123\0\0\0abc",
	350	4 => "\0\0\0abc",
	351	);
	352
	353	%DB::dbline = %lines;
	354	DB->clr_breaks(1 .. 4);
	355	is( scalar keys %DB::dbline, 3, 'DB::clr_breaks() should clear breaks' );
	356	ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
	357	is( $DB::dbline{3}, "\0\0\0abc", '... should remove break, leaving action');
	358	is( $DB::dbline{4}, "\0\0\0abc", '... should not remove set actions' );
	359
	360	local *{ "::_<foo" } = [ 0, 0, 0, 1 ];
	361
	362	local $DB::package;
	363	local %DB::sub = (
	364	'main::foo' => 'foo:1-3',
	365	);
	366
	367	%DB::dbline = %lines;
	368	DB->clr_breaks('foo');
	369
	370	is( $DB::dbline{3}, "\0\0\0abc",
	371	'... should find lines via _find_subline()' );
	372
	373	my $db = FakeDB->new();
	374	DB::clr_breaks($db, 'abadsubname');
	375	is( $db->{output}, "Subroutine not found.\n",
	376	'... should output warning if sub cannot be found');
	377
	378	@DB::dbline = (1 .. 4);
	379	%DB::dbline = (%lines, 5 => "\0" );
	380
	381	DB::clr_breaks();
	382
	383	is( scalar keys %DB::dbline, 4,
	384	'Relying on @DB::dbline in DB::clr_breaks() should clear breaks' );
	385	ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
	386	is( $DB::dbline{3}, "\0\0\0abc", '... should remove break, leaving action');
	387	is( $DB::dbline{4}, "\0\0\0abc", '... should not remove set actions' );
	388	ok( exists($DB::dbline{5}),
	389	'... should only go to last index of @DB::dbline' );
c95f170b	390	}
	391
	392	# test DB::set_action()
	393	{
acc79e62	394	local *DB::dbline;
c95f170b	395
acc79e62 JH	396	%DB::dbline = (
	397	2 => "\0abc",
	398	);
c95f170b	399
acc79e62	400	*DB::dbline = [ $dualfalse, $dualfalse, $dualtrue, $dualtrue ];
c95f170b	401
acc79e62 JH	402	DB->set_action(2, 'def');
	403	is( $DB::dbline{2}, "\0def",
	404	'DB::set_action() should replace existing action' );
	405	DB->set_action(3, '');
	406	is( $DB::dbline{3}, "\0", '... should set new action' );
c95f170b	407
acc79e62 JH	408	my $db = FakeDB->new();
	409	DB::set_action($db, 'abadsubname');
	410	is( $db->{output}, "Subroutine not found.\n",
	411	'... should output warning if sub cannot be found');
c95f170b	412
acc79e62 JH	413	DB::set_action($db, 1);
	414	like( $db->{output}, qr/1 not action/,
	415	'... should warn if line cannot be actionivated' );
c95f170b	416	}
	417
	418	# test DB::clr_actions()
	419	{
acc79e62 JH	420	local *DB::dbline;
	421	my %lines = (
	422	1 => "\0",
	423	2 => undef,
	424	3 => "123\0abc",
	425	4 => "abc\0",
	426	);
	427
	428	%DB::dbline = %lines;
	429	*DB::dbline = [ ($dualtrue) x 4 ];
	430
	431	DB->clr_actions(1 .. 4);
	432
	433	is( scalar keys %DB::dbline, 2, 'DB::clr_actions() should clear actions' );
	434	ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
	435	is( $DB::dbline{3}, "123", '... should remove action, leaving break');
	436	is( $DB::dbline{4}, "abc\0", '... should not remove set breaks' );
	437
	438	local *{ "::_<foo" } = [ 0, 0, 0, 1 ];
	439
	440	local $DB::package;
	441	local %DB::sub = (
	442	'main::foo' => 'foo:1-3',
	443	);
	444
	445	%DB::dbline = %lines;
	446	DB->clr_actions('foo');
	447
	448	is( $DB::dbline{3}, "123", '... should find lines via _find_subline()' );
	449
	450	my $db = FakeDB->new();
	451	DB::clr_actions($db, 'abadsubname');
	452	is( $db->{output}, "Subroutine not found.\n",
	453	'... should output warning if sub cannot be found');
	454
	455	@DB::dbline = (1 .. 4);
	456	%DB::dbline = (%lines, 5 => "\0" );
	457
	458	DB::clr_actions();
	459
	460	is( scalar keys %DB::dbline, 4,
	461	'Relying on @DB::dbline in DB::clr_actions() should clear actions' );
	462	ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
	463	is( $DB::dbline{3}, "123", '... should remove action, leaving break');
	464	is( $DB::dbline{4}, "abc\0", '... should not remove set breaks' );
	465	ok( exists($DB::dbline{5}),
	466	'... should only go to last index of @DB::dbline' );
c95f170b	467	}
	468
	469	# test DB::prestop()
	470	ok( ! defined DB::prestop('test'),
acc79e62	471	'DB::prestop() should return undef for undef value' );
c95f170b	472	DB::prestop('test', 897);
	473	is( DB::prestop('test'), 897, '... should return value when set' );
	474
	475	# test DB::poststop(), not exactly parallel
	476	ok( ! defined DB::poststop('tset'),
acc79e62	477	'DB::prestop() should return undef for undef value' );
c95f170b	478	DB::poststop('tset', 987);
	479	is( DB::poststop('tset'), 987, '... should return value when set' );
	480
	481	# test DB::evalcode()
	482	ok( ! defined DB::evalcode('foo'),
acc79e62	483	'DB::evalcode() should return undef for undef value' );
c95f170b	484
	485	DB::evalcode('foo', 'bar');
	486	is( DB::evalcode('foo'), 'bar', '... should return value when set' );
	487
	488	# test DB::_outputall(), must create fake clients first
	489	ok( DB::register( FakeDB->new() ), 'DB::register() should work' );
	490	DB::register( FakeDB->new() ) for ( 1 .. 2);
	491
	492	DB::_outputall(1, 2, 3);
	493	is( $FakeDB::output, '123123123',
acc79e62	494	'DB::_outputall() should call output(@_) on all clients' );
c95f170b	495
	496	# test virtual methods
	497	for my $method (qw( cprestop cpoststop awaken init stop idle cleanup output )) {
acc79e62	498	ok( defined &{ "DB::$method" }, "DB::$method() should be defined" );
c95f170b	499	}
	500
	501	# DB::skippkg() uses lexical
	502	# DB::ready() uses lexical
	503
	504	package FakeDB;
	505
	506	use vars qw( $output );
	507
	508	sub new {
acc79e62	509	bless({}, $_[0]);
c95f170b	510	}
	511
	512	sub set_tbreak {
acc79e62 JH	513	my ($self, $val) = @_;
acc79e62 JH	514	$self->{tbreak} = $val;
c95f170b	515	}
	516
	517	sub output {
acc79e62 JH	518	my $self = shift;
	519	if (ref $self) {
	520	$self->{output} = join('', @_);
	521	} else {
	522	$output .= join('', @_);
	523	}
c95f170b	524	}