1#!./perl -Tw 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require Config; 7 if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){ 8 print "1..0 # Skip -- Perl configured without List::Util module\n"; 9 exit 0; 10 } 11} 12 13# symbolic references used later 14use strict qw( vars subs ); 15 16# @DB::dbline values have both integer and string components (Benjamin Goldberg) 17use Scalar::Util qw( dualvar ); 18my $dualfalse = dualvar(0, 'false'); 19my $dualtrue = dualvar(1, 'true'); 20 21use Test::More; 22 23# must happen at compile time for DB:: package variable localizations to work 24BEGIN { 25 use_ok( 'DB' ); 26} 27 28# test DB::sub() 29{ 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()' ); 47} 48 49# test DB::DB() 50{ 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' ); 55 56 # change packages to mess with caller() 57 package foo; 58 ::ok( ! defined DB::DB(), 'DB::DB() should skip skippable packages' ); 59 60 package main; 61 is( $DB::filename, $0, '... should set $DB::filename' ); 62 is( $DB::lineno, __LINE__ - 4, '... should set $DB::lineno' ); 63 64 DB::DB(); 65 # stops at line 94 66} 67 68# test DB::save() 69{ 70 no warnings 'uninitialized'; 71 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' ); 76} 77 78# test DB::catch() 79{ 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 84} 85 86# test DB::_clientname() 87is( DB::_clientname('foo=A(1)'), 'foo', 88 'DB::_clientname should return refname'); 89is( DB::_clientname('bar'), undef, 90 'DB::_clientname should not return non refname'); 91 92# test DB::next() and DB::step() 93{ 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' ); 99} 100 101# test DB::cont() 102{ 103 # cannot test @stack 104 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' ); 110} 111 112# test DB::ret() 113{ 114 # cannot test @stack 115 116 local $DB::single = 1; 117 DB::ret(); 118 is( $DB::single, 0, 'DB::ret() should set $DB::single to 0' ); 119} 120 121# test DB::backtrace() 122{ 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' ); 129 like( $ret[0], qr/eval\Q {...}/, '... should catch eval BLOCK' ); 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 145} 146 147sub check_context { 148 return (eval "one($_[0])")[-1]; 149} 150sub one { DB->backtrace(@_) } 151sub two { one(@_) } 152sub three { two(@_) } 153 154# test DB::trace_toggle 155{ 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)' ); 161} 162 163# test DB::subs() 164{ 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 is_deeply( \@subs, \@expected, '... find file, start, end for subs' ); 175} 176 177# test DB::filesubs() 178{ 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'); 190} 191 192# test DB::files() 193{ 194 my $dbf = () = DB::files(); 195 my $main = () = grep ( m!^_<!, keys %main:: ); 196 is( $dbf, $main, 'DB::files() should pick up filenames from %main::' ); 197} 198 199# test DB::lines() 200{ 201 local @DB::dbline = ( 'foo' ); 202 is( DB->lines->[0], 'foo', 'DB::lines() should return ref to @DB::dbline' ); 203} 204 205# test DB::loadfile() 206SKIP: { 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/^_<..//; 213 214 my $db = DB->loadfile($file); 215 like( $db, qr!$file\z!, '... should find loaded file from partial name'); 216 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' ); 220 221 # test clients 222} 223 224# test DB::lineevents() 225{ 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'); 242} 243 244# test DB::set_break() 245{ 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' ); 285} 286 287# test DB::set_tbreak() 288{ 289 local ($DB::lineno, *DB::dbline, $DB::package); 290 *DB::dbline = [ $dualfalse, $dualtrue, $dualfalse, $dualfalse, $dualtrue ]; 291 292 DB->set_tbreak(1); 293 is( $DB::dbline{1}, ';9', 'DB::set_tbreak() should set tbreak condition' ); 294 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' ); 301 302 my $db = FakeDB->new(); 303 DB::set_tbreak($db, 2); 304 like( $db->{output}, qr/2 not break/, '... should respect @DB::dbline' ); 305 306 DB::set_break($db, 'nonfoo'); 307 like( $db->{output}, qr/not found/, '... should warn on unfound sub' ); 308} 309 310# test DB::_find_subline() 311{ 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 nonexistent sub' ); 341} 342 343# test DB::clr_breaks() 344{ 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' ); 390} 391 392# test DB::set_action() 393{ 394 local *DB::dbline; 395 396 %DB::dbline = ( 397 2 => "\0abc", 398 ); 399 400 *DB::dbline = [ $dualfalse, $dualfalse, $dualtrue, $dualtrue ]; 401 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' ); 407 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'); 412 413 DB::set_action($db, 1); 414 like( $db->{output}, qr/1 not action/, 415 '... should warn if line cannot be actionivated' ); 416} 417 418# test DB::clr_actions() 419{ 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' ); 467} 468 469# test DB::prestop() 470ok( ! defined DB::prestop('test'), 471 'DB::prestop() should return undef for undef value' ); 472DB::prestop('test', 897); 473is( DB::prestop('test'), 897, '... should return value when set' ); 474 475# test DB::poststop(), not exactly parallel 476ok( ! defined DB::poststop('tset'), 477 'DB::prestop() should return undef for undef value' ); 478DB::poststop('tset', 987); 479is( DB::poststop('tset'), 987, '... should return value when set' ); 480 481# test DB::evalcode() 482ok( ! defined DB::evalcode('foo'), 483 'DB::evalcode() should return undef for undef value' ); 484 485DB::evalcode('foo', 'bar'); 486is( DB::evalcode('foo'), 'bar', '... should return value when set' ); 487 488# test DB::_outputall(), must create fake clients first 489ok( DB::register( FakeDB->new() ), 'DB::register() should work' ); 490DB::register( FakeDB->new() ) for ( 1 .. 2); 491 492DB::_outputall(1, 2, 3); 493is( $FakeDB::output, '123123123', 494 'DB::_outputall() should call output(@_) on all clients' ); 495 496# test virtual methods 497for my $method (qw( cprestop cpoststop awaken init stop idle cleanup output )) { 498 ok( defined &{ "DB::$method" }, "DB::$method() should be defined" ); 499} 500 501done_testing(); 502 503# DB::skippkg() uses lexical 504# DB::ready() uses lexical 505 506package FakeDB; 507 508use vars qw( $output ); 509 510sub new { 511 bless({}, $_[0]); 512} 513 514sub set_tbreak { 515 my ($self, $val) = @_; 516 $self->{tbreak} = $val; 517} 518 519sub output { 520 my $self = shift; 521 if (ref $self) { 522 $self->{output} = join('', @_); 523 } else { 524 $output .= join('', @_); 525 } 526} 527