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