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