lib/DB.t

   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 cmp_ok( DB::_clientname('bar'), 'eq', '',
  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 }