[p5sagit/p5-mst-13.2.git] / lib / DB.t

#!./perl

BEGIN {
	chdir 't' if -d 't';
	@INC = '../lib';
}

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'), '','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\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
}

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()
{
	local $DB::filename = 'baz';
	local *baz = *{ "main::_<baz" };
	@baz = ( 1 .. 5 );
	%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} }), '2 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 = [ 0, 1, 0, 0, 1 ];

	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 = [ 0, 1, 0, 0, 1 ];

	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] = 1;

	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] = 0;

	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 = [ 0, 0, 1, 1 ];

	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 = [ 1, 1, 1, 1 ];

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