lib/DB.t

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