lib/DB.t

   1 #!./perl -Tw
   2
   3 BEGIN {
   4         chdir 't' if -d 't';
   5         @INC = '../lib';
   6 }
   7
   8 # symbolic references used later
   9 use strict qw( vars subs );
  10
  11 # @DB::dbline values have both integer and string components (Benjamin Goldberg)
  12 use Scalar::Util qw( dualvar );
  13 my $dualfalse = dualvar(0, 'false');
  14 my $dualtrue = dualvar(1, 'true');
  15
  16 use Test::More tests => 106;
  17
  18 # must happen at compile time for DB:: package variable localizations to work
  19 BEGIN {
  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()
  82 is( DB::_clientname('foo=A(1)'), 'foo',
  83     'DB::_clientname should return refname');
  84 cmp_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
 142 sub check_context {
 143         return (eval "one($_[0])")[-1];
 144 }
 145 sub one { DB->backtrace(@_) }
 146 sub two { one(@_) }
 147 sub 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()
 201 SKIP: {
 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()
 465 ok( ! defined DB::prestop('test'),
 466         'DB::prestop() should return undef for undef value' );
 467 DB::prestop('test', 897);
 468 is( DB::prestop('test'), 897, '... should return value when set' );
 469
 470 # test DB::poststop(), not exactly parallel
 471 ok( ! defined DB::poststop('tset'),
 472         'DB::prestop() should return undef for undef value' );
 473 DB::poststop('tset', 987);
 474 is( DB::poststop('tset'), 987, '... should return value when set' );
 475
 476 # test DB::evalcode()
 477 ok( ! defined DB::evalcode('foo'),
 478         'DB::evalcode() should return undef for undef value' );
 479
 480 DB::evalcode('foo', 'bar');
 481 is( DB::evalcode('foo'), 'bar', '... should return value when set' );
 482
 483 # test DB::_outputall(), must create fake clients first
 484 ok( DB::register( FakeDB->new() ), 'DB::register() should work' );
 485 DB::register( FakeDB->new() ) for ( 1 .. 2);
 486
 487 DB::_outputall(1, 2, 3);
 488 is( $FakeDB::output, '123123123',
 489         'DB::_outputall() should call output(@_) on all clients' );
 490
 491 # test virtual methods
 492 for 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
 499 package FakeDB;
 500
 501 use vars qw( $output );
 502
 503 sub new {
 504         bless({}, $_[0]);
 505 }
 506
 507 sub set_tbreak {
 508         my ($self, $val) = @_;
 509         $self->{tbreak} = $val;
 510 }
 511
 512 sub output {
 513         my $self = shift;
 514         if (ref $self) {
 515                 $self->{output} = join('', @_);
 516         } else {
 517                 $output .= join('', @_);
 518         }
 519 }