| 1 | #!./perl -Tw |
| 2 | |
| 3 | BEGIN { |
| 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 |
| 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 | |
| 21 | use Test::More tests => 106; |
| 22 | |
| 23 | # must happen at compile time for DB:: package variable localizations to work |
| 24 | BEGIN { |
| 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() |
| 87 | is( DB::_clientname('foo=A(1)'), 'foo', |
| 88 | 'DB::_clientname should return refname'); |
| 89 | is( 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 {...}/, '... 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 | |
| 147 | sub check_context { |
| 148 | return (eval "one($_[0])")[-1]; |
| 149 | } |
| 150 | sub one { DB->backtrace(@_) } |
| 151 | sub two { one(@_) } |
| 152 | sub 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 | ok( eq_array( \@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() |
| 206 | SKIP: { |
| 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 nonexistant 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() |
| 470 | ok( ! defined DB::prestop('test'), |
| 471 | 'DB::prestop() should return undef for undef value' ); |
| 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'), |
| 477 | 'DB::prestop() should return undef for undef value' ); |
| 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'), |
| 483 | 'DB::evalcode() should return undef for undef value' ); |
| 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', |
| 494 | 'DB::_outputall() should call output(@_) on all clients' ); |
| 495 | |
| 496 | # test virtual methods |
| 497 | for my $method (qw( cprestop cpoststop awaken init stop idle cleanup output )) { |
| 498 | ok( defined &{ "DB::$method" }, "DB::$method() should be defined" ); |
| 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 { |
| 509 | bless({}, $_[0]); |
| 510 | } |
| 511 | |
| 512 | sub set_tbreak { |
| 513 | my ($self, $val) = @_; |
| 514 | $self->{tbreak} = $val; |
| 515 | } |
| 516 | |
| 517 | sub output { |
| 518 | my $self = shift; |
| 519 | if (ref $self) { |
| 520 | $self->{output} = join('', @_); |
| 521 | } else { |
| 522 | $output .= join('', @_); |
| 523 | } |
| 524 | } |