[ PATCH ] mymalloc on HP-UX
[p5sagit/p5-mst-13.2.git] / lib / DB.t
CommitLineData
4940c443 1#!./perl -Tw
c95f170b 2
3BEGIN {
acc79e62 4 chdir 't' if -d 't';
5 @INC = '../lib';
c95f170b 6}
7
4eba29c1 8# symbolic references used later
9use strict qw( vars subs );
10
11# @DB::dbline values have both integer and string components (Benjamin Goldberg)
12use Scalar::Util qw( dualvar );
13my $dualfalse = dualvar(0, 'false');
14my $dualtrue = dualvar(1, 'true');
15
c95f170b 16use Test::More tests => 106;
17
18# must happen at compile time for DB:: package variable localizations to work
19BEGIN {
acc79e62 20 use_ok( 'DB' );
c95f170b 21}
22
23# test DB::sub()
24{
acc79e62 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()' );
c95f170b 42}
43
44# test DB::DB()
45{
acc79e62 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' );
c95f170b 50
acc79e62 51 # change packages to mess with caller()
52 package foo;
53 ::ok( ! defined DB::DB(), 'DB::DB() should skip skippable packages' );
c95f170b 54
acc79e62 55 package main;
56 is( $DB::filename, $0, '... should set $DB::filename' );
57 is( $DB::lineno, __LINE__ - 4, '... should set $DB::lineno' );
c95f170b 58
acc79e62 59 DB::DB();
60 # stops at line 94
c95f170b 61}
62
63# test DB::save()
64{
eca89c5a 65 no warnings 'uninitialized';
66
acc79e62 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' );
c95f170b 71}
72
73# test DB::catch()
74{
acc79e62 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
c95f170b 79}
80
81# test DB::_clientname()
4940c443 82is( DB::_clientname('foo=A(1)'), 'foo',
83 'DB::_clientname should return refname');
84cmp_ok( DB::_clientname('bar'), 'eq', '',
85 'DB::_clientname should not return non refname');
c95f170b 86
87# test DB::next() and DB::step()
88{
acc79e62 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' );
c95f170b 94}
95
96# test DB::cont()
97{
acc79e62 98 # cannot test @stack
c95f170b 99
acc79e62 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' );
c95f170b 105}
106
107# test DB::ret()
108{
acc79e62 109 # cannot test @stack
c95f170b 110
acc79e62 111 local $DB::single = 1;
112 DB::ret();
113 is( $DB::single, 0, 'DB::ret() should set $DB::single to 0' );
c95f170b 114}
115
116# test DB::backtrace()
117{
acc79e62 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
c95f170b 140}
141
142sub check_context {
acc79e62 143 return (eval "one($_[0])")[-1];
c95f170b 144}
145sub one { DB->backtrace(@_) }
146sub two { one(@_) }
147sub three { two(@_) }
148
149# test DB::trace_toggle
150{
acc79e62 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)' );
c95f170b 156}
157
158# test DB::subs()
159{
acc79e62 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' );
c95f170b 170}
171
172# test DB::filesubs()
173{
acc79e62 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');
c95f170b 185}
186
187# test DB::files()
188{
acc79e62 189 my $dbf = () = DB::files();
190 my $main = () = grep ( m!^_<!, keys %main:: );
191 is( $dbf, $main, 'DB::files() should pick up filenames from %main::' );
c95f170b 192}
193
194# test DB::lines()
195{
acc79e62 196 local @DB::dbline = ( 'foo' );
197 is( DB->lines->[0], 'foo', 'DB::lines() should return ref to @DB::dbline' );
c95f170b 198}
199
200# test DB::loadfile()
201SKIP: {
acc79e62 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/^_<..//;
c95f170b 208
acc79e62 209 my $db = DB->loadfile($file);
210 like( $db, qr!$file\z!, '... should find loaded file from partial name');
4eba29c1 211
acc79e62 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' );
c95f170b 215
acc79e62 216 # test clients
c95f170b 217}
218
219# test DB::lineevents()
220{
acc79e62 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');
c95f170b 237}
238
239# test DB::set_break()
240{
acc79e62 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' );
c95f170b 280}
281
282# test DB::set_tbreak()
283{
acc79e62 284 local ($DB::lineno, *DB::dbline, $DB::package);
285 *DB::dbline = [ $dualfalse, $dualtrue, $dualfalse, $dualfalse, $dualtrue ];
c95f170b 286
acc79e62 287 DB->set_tbreak(1);
288 is( $DB::dbline{1}, ';9', 'DB::set_tbreak() should set tbreak condition' );
c95f170b 289
acc79e62 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' );
c95f170b 296
acc79e62 297 my $db = FakeDB->new();
298 DB::set_tbreak($db, 2);
299 like( $db->{output}, qr/2 not break/, '... should respect @DB::dbline' );
c95f170b 300
acc79e62 301 DB::set_break($db, 'nonfoo');
302 like( $db->{output}, qr/not found/, '... should warn on unfound sub' );
c95f170b 303}
304
305# test DB::_find_subline()
306{
acc79e62 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' );
c95f170b 336}
337
338# test DB::clr_breaks()
339{
acc79e62 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' );
c95f170b 385}
386
387# test DB::set_action()
388{
acc79e62 389 local *DB::dbline;
c95f170b 390
acc79e62 391 %DB::dbline = (
392 2 => "\0abc",
393 );
c95f170b 394
acc79e62 395 *DB::dbline = [ $dualfalse, $dualfalse, $dualtrue, $dualtrue ];
c95f170b 396
acc79e62 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' );
c95f170b 402
acc79e62 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');
c95f170b 407
acc79e62 408 DB::set_action($db, 1);
409 like( $db->{output}, qr/1 not action/,
410 '... should warn if line cannot be actionivated' );
c95f170b 411}
412
413# test DB::clr_actions()
414{
acc79e62 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' );
c95f170b 462}
463
464# test DB::prestop()
465ok( ! defined DB::prestop('test'),
acc79e62 466 'DB::prestop() should return undef for undef value' );
c95f170b 467DB::prestop('test', 897);
468is( DB::prestop('test'), 897, '... should return value when set' );
469
470# test DB::poststop(), not exactly parallel
471ok( ! defined DB::poststop('tset'),
acc79e62 472 'DB::prestop() should return undef for undef value' );
c95f170b 473DB::poststop('tset', 987);
474is( DB::poststop('tset'), 987, '... should return value when set' );
475
476# test DB::evalcode()
477ok( ! defined DB::evalcode('foo'),
acc79e62 478 'DB::evalcode() should return undef for undef value' );
c95f170b 479
480DB::evalcode('foo', 'bar');
481is( DB::evalcode('foo'), 'bar', '... should return value when set' );
482
483# test DB::_outputall(), must create fake clients first
484ok( DB::register( FakeDB->new() ), 'DB::register() should work' );
485DB::register( FakeDB->new() ) for ( 1 .. 2);
486
487DB::_outputall(1, 2, 3);
488is( $FakeDB::output, '123123123',
acc79e62 489 'DB::_outputall() should call output(@_) on all clients' );
c95f170b 490
491# test virtual methods
492for my $method (qw( cprestop cpoststop awaken init stop idle cleanup output )) {
acc79e62 493 ok( defined &{ "DB::$method" }, "DB::$method() should be defined" );
c95f170b 494}
495
496# DB::skippkg() uses lexical
497# DB::ready() uses lexical
498
499package FakeDB;
500
501use vars qw( $output );
502
503sub new {
acc79e62 504 bless({}, $_[0]);
c95f170b 505}
506
507sub set_tbreak {
acc79e62 508 my ($self, $val) = @_;
509 $self->{tbreak} = $val;
c95f170b 510}
511
512sub output {
acc79e62 513 my $self = shift;
514 if (ref $self) {
515 $self->{output} = join('', @_);
516 } else {
517 $output .= join('', @_);
518 }
c95f170b 519}