8 use Test::More tests => 106;
10 # must happen at compile time for DB:: package variable localizations to work
18 local $DB::sub = sub {
19 $callflag += shift || 1;
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');
31 ok( !defined($DB::ret), '... should respect void context' );
32 $DB::sub = '::DESTROY';
33 ok( !defined($DB::ret), '... should return undef for DESTROY()' );
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' );
43 # change packages to mess with caller()
45 ::ok( ! defined DB::DB(), 'DB::DB() should skip skippable packages' );
48 is( $DB::filename, $0, '... should set $DB::filename' );
49 is( $DB::lineno, __LINE__ - 4, '... should set $DB::lineno' );
57 # assigning a number to $! seems to produce an error message, when read
58 local ($@, $,, $/, $\, $^W, $!) = (1 .. 5);
60 is( "$@$!$,$/$\$^W", "1\n0", 'DB::save() should reset punctuation vars' );
67 ok( $DB::signal, 'DB::catch() should set $DB::signal' );
68 # add clients and test to see if they are awakened
71 # test DB::_clientname()
72 is( DB::_clientname('foo=A(1)'), 'foo','DB::_clientname should return refname');
73 is( DB::_clientname('bar'), '','DB::_clientname should not return non refname');
75 # test DB::next() and DB::step()
79 is( $DB::single, 2, 'DB->next() should set $DB::single to 2' );
81 is( $DB::single, 1, 'DB->step() should set $DB::single to 1' );
88 local $DB::single = 1;
89 my $fdb = FakeDB->new();
91 is( $fdb->{tbreak}, 2, 'DB::cont() should set tbreak in object' );
92 is( $DB::single, 0, '... should set $DB::single to 0' );
99 local $DB::single = 1;
101 is( $DB::single, 0, 'DB::ret() should set $DB::single to 0' );
104 # test DB::backtrace()
106 local (@DB::args, $DB::signal);
108 my $line = __LINE__ + 1;
109 my @ret = eval { DB->backtrace() };
110 like( $ret[0], qr/file.+$0/, 'DB::backtrace() should report current file');
111 like( $ret[0], qr/line $line/, '... should report calling line number' );
112 like( $ret[0], qr/eval {...}/, '... should catch eval BLOCK' );
114 @ret = eval "one(2)";
115 is( scalar @ret, 1, '... should report from provided stack frame number' );
116 like( $ret[0], qr/\@ = &eval \'one.+?2\)\'/, #'
117 '... should find eval STRING construct');
118 $ret[0] = check_context(1);
119 like( $ret[0], qr/\$ = &main::check_context/,
120 '... should respect context of calling construct');
125 is( scalar @ret, 1, '... should end loop if $DB::signal is true' );
127 # does not check 'require' or @DB::args mangling
131 return (eval "one($_[0])")[-1];
133 sub one { DB->backtrace(@_) }
135 sub three { two(@_) }
137 # test DB::trace_toggle
139 local $DB::trace = 0;
141 ok( $DB::trace, 'DB::trace_toggle() should toggle $DB::trace' );
143 ok( !$DB::trace, '... should toggle $DB::trace (back)' );
150 is( $subs, 0, 'DB::subs() should return keys of %DB::subs' );
151 %DB::sub = ( foo => 'foo:23-45' , bar => 'ba:r:7-890' );
153 is( $subs, 2, '... same song, different key' );
154 my @subs = DB->subs( 'foo', 'boo', 'bar' );
155 is( scalar @subs, 2, '... should report only for requested subs' );
156 my @expected = ( [ 'foo', 23, 45 ], [ 'ba:r', 7, 890 ] );
157 ok( eq_array( \@subs, \@expected ), '... find file, start, end for subs' );
160 # test DB::filesubs()
162 local ($DB::filename, %DB::sub);
163 $DB::filename = 'baz';
164 %DB::sub = map { $_ => $_ } qw( bazbar bazboo boobar booboo boobaz );
165 my @ret = DB->filesubs();
166 is( scalar @ret, 2, 'DB::filesubs() should use $DB::filename with no args');
167 @ret = grep { /^baz/ } @ret;
168 is( scalar @ret, 2, '... should pick up subs in proper file' );
169 @ret = DB->filesubs('boo');
170 is( scalar @ret, 3, '... should use argument to find subs' );
171 @ret = grep { /^boo/ } @ret;
172 is( scalar @ret, 3, '... should pick up subs in proper file with argument');
177 my $dbf = () = DB::files();
178 my $main = () = grep ( m!^_<!, keys %main:: );
179 is( $dbf, $main, 'DB::files() should pick up filenames from %main::' );
184 local @DB::dbline = ( 'foo' );
185 is( DB->lines->[0], 'foo', 'DB::lines() should return ref to @DB::dbline' );
188 # test DB::loadfile()
190 local (*DB::dbline, $DB::filename);
191 ok( ! defined DB->loadfile('notafile'),
192 'DB::loadfile() should not find unloaded file' );
193 my $file = (grep { m|^_<.+\.pm| } keys %main:: )[0];
194 skip('cannot find loaded file', 3) unless $file;
197 my $db = DB->loadfile($file);
198 like( $db, qr!$file\z!, '... should find loaded file from partial name');
199 is( *DB::dbline, *{ "_<$db" } ,
200 '... should set *DB::dbline to associated glob');
201 is( $DB::filename, $db, '... should set $DB::filename to file name' );
206 # test DB::lineevents()
208 local $DB::filename = 'baz';
209 local *baz = *{ "main::_<baz" };
216 my %ret = DB->lineevents();
217 is( scalar keys %ret, 3, 'DB::lineevents() should pick up defined lines' );
219 # array access in DB::lineevents() starts at element 1, not 0
220 is( join(' ', @{ $ret{1} }), '2 foo bar', '... should stash data in hash');
223 # test DB::set_break()
225 local ($DB::lineno, *DB::dbline, $DB::package);
234 *DB::dbline = [ 0, 1, 0, 0, 1 ];
237 'main::foo' => 'foo:1-4',
240 DB->set_break(1, 'foo');
241 is( $DB::dbline{1}, "foo\0", 'DB::set_break() should set break condition' );
244 DB->set_break(undef, 'bar');
245 is( $DB::dbline{1}, "bar\0",
246 '... should use $DB::lineno without specified line' );
249 is( $DB::dbline{4}, "1\0abc", '... should use default condition if needed');
252 'main::foo' => 'foo:1-4',
254 DB->set_break('foo', 'baz');
255 is( $DB::dbline{4}, "baz\0abc",
256 '... should use _find_subline() to resolve subname' );
258 my $db = FakeDB->new();
259 DB::set_break($db, 2);
260 like( $db->{output}, qr/2 not break/, '... should respect @DB::dbline' );
262 DB::set_break($db, 'nonfoo');
263 like( $db->{output}, qr/not found/, '... should warn on unfound sub' );
266 # test DB::set_tbreak()
268 local ($DB::lineno, *DB::dbline, $DB::package);
269 *DB::dbline = [ 0, 1, 0, 0, 1 ];
272 is( $DB::dbline{1}, ';9', 'DB::set_tbreak() should set tbreak condition' );
275 'main::foo' => 'foo:1-4',
277 DB->set_tbreak('foo', 'baz');
278 is( $DB::dbline{4}, ';9',
279 '... should use _find_subline() to resolve subname' );
281 my $db = FakeDB->new();
282 DB::set_tbreak($db, 2);
283 like( $db->{output}, qr/2 not break/, '... should respect @DB::dbline' );
285 DB::set_break($db, 'nonfoo');
286 like( $db->{output}, qr/not found/, '... should warn on unfound sub' );
289 # test DB::_find_subline()
292 local *{ "::_<foo" } = \@foo;
296 'TEST::foo' => 'foo:10-15',
297 'main::foo' => 'foo:11-12',
298 'bar::bar' => 'foo:10-16',
303 is( DB::_find_subline('TEST::foo'), 11,
304 'DB::_find_subline() should find fully qualified sub' );
305 is( DB::_find_subline("TEST'foo"), 11, '... should handle old package sep');
306 is( DB::_find_subline('foo'), 11,
307 '... should resolve unqualified package name to main::' );
309 $DB::package = 'bar';
310 is( DB::_find_subline('bar'), 11,
311 '... should resolve unqualified name with $DB::package, if defined' );
315 is( DB::_find_subline('TEST::foo'), 15,
316 '... should increment past lines with no events' );
318 ok( ! defined DB::_find_subline('sirnotappearinginthisfilm'),
319 '... should not find nonexistant sub' );
322 # test DB::clr_breaks()
332 %DB::dbline = %lines;
333 DB->clr_breaks(1 .. 4);
334 is( scalar keys %DB::dbline, 3, 'DB::clr_breaks() should clear breaks' );
335 ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
336 is( $DB::dbline{3}, "\0\0\0abc", '... should remove break, leaving action');
337 is( $DB::dbline{4}, "\0\0\0abc", '... should not remove set actions' );
339 local *{ "::_<foo" } = [ 0, 0, 0, 1 ];
343 'main::foo' => 'foo:1-3',
346 %DB::dbline = %lines;
347 DB->clr_breaks('foo');
349 is( $DB::dbline{3}, "\0\0\0abc",
350 '... should find lines via _find_subline()' );
352 my $db = FakeDB->new();
353 DB::clr_breaks($db, 'abadsubname');
354 is( $db->{output}, "Subroutine not found.\n",
355 '... should output warning if sub cannot be found');
357 @DB::dbline = (1 .. 4);
358 %DB::dbline = (%lines, 5 => "\0" );
362 is( scalar keys %DB::dbline, 4,
363 'Relying on @DB::dbline in DB::clr_breaks() should clear breaks' );
364 ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
365 is( $DB::dbline{3}, "\0\0\0abc", '... should remove break, leaving action');
366 is( $DB::dbline{4}, "\0\0\0abc", '... should not remove set actions' );
367 ok( exists($DB::dbline{5}),
368 '... should only go to last index of @DB::dbline' );
371 # test DB::set_action()
379 *DB::dbline = [ 0, 0, 1, 1 ];
381 DB->set_action(2, 'def');
382 is( $DB::dbline{2}, "\0def",
383 'DB::set_action() should replace existing action' );
384 DB->set_action(3, '');
385 is( $DB::dbline{3}, "\0", '... should set new action' );
387 my $db = FakeDB->new();
388 DB::set_action($db, 'abadsubname');
389 is( $db->{output}, "Subroutine not found.\n",
390 '... should output warning if sub cannot be found');
392 DB::set_action($db, 1);
393 like( $db->{output}, qr/1 not action/,
394 '... should warn if line cannot be actionivated' );
397 # test DB::clr_actions()
407 %DB::dbline = %lines;
408 *DB::dbline = [ 1, 1, 1, 1 ];
410 DB->clr_actions(1 .. 4);
412 is( scalar keys %DB::dbline, 2, 'DB::clr_actions() should clear actions' );
413 ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
414 is( $DB::dbline{3}, "123", '... should remove action, leaving break');
415 is( $DB::dbline{4}, "abc\0", '... should not remove set breaks' );
417 local *{ "::_<foo" } = [ 0, 0, 0, 1 ];
421 'main::foo' => 'foo:1-3',
424 %DB::dbline = %lines;
425 DB->clr_actions('foo');
427 is( $DB::dbline{3}, "123", '... should find lines via _find_subline()' );
429 my $db = FakeDB->new();
430 DB::clr_actions($db, 'abadsubname');
431 is( $db->{output}, "Subroutine not found.\n",
432 '... should output warning if sub cannot be found');
434 @DB::dbline = (1 .. 4);
435 %DB::dbline = (%lines, 5 => "\0" );
439 is( scalar keys %DB::dbline, 4,
440 'Relying on @DB::dbline in DB::clr_actions() should clear actions' );
441 ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
442 is( $DB::dbline{3}, "123", '... should remove action, leaving break');
443 is( $DB::dbline{4}, "abc\0", '... should not remove set breaks' );
444 ok( exists($DB::dbline{5}),
445 '... should only go to last index of @DB::dbline' );
449 ok( ! defined DB::prestop('test'),
450 'DB::prestop() should return undef for undef value' );
451 DB::prestop('test', 897);
452 is( DB::prestop('test'), 897, '... should return value when set' );
454 # test DB::poststop(), not exactly parallel
455 ok( ! defined DB::poststop('tset'),
456 'DB::prestop() should return undef for undef value' );
457 DB::poststop('tset', 987);
458 is( DB::poststop('tset'), 987, '... should return value when set' );
460 # test DB::evalcode()
461 ok( ! defined DB::evalcode('foo'),
462 'DB::evalcode() should return undef for undef value' );
464 DB::evalcode('foo', 'bar');
465 is( DB::evalcode('foo'), 'bar', '... should return value when set' );
467 # test DB::_outputall(), must create fake clients first
468 ok( DB::register( FakeDB->new() ), 'DB::register() should work' );
469 DB::register( FakeDB->new() ) for ( 1 .. 2);
471 DB::_outputall(1, 2, 3);
472 is( $FakeDB::output, '123123123',
473 'DB::_outputall() should call output(@_) on all clients' );
475 # test virtual methods
476 for my $method (qw( cprestop cpoststop awaken init stop idle cleanup output )) {
477 ok( defined &{ "DB::$method" }, "DB::$method() should be defined" );
480 # DB::skippkg() uses lexical
481 # DB::ready() uses lexical
485 use vars qw( $output );
492 my ($self, $val) = @_;
493 $self->{tbreak} = $val;
499 $self->{output} = join('', @_);
501 $output .= join('', @_);