Commit | Line | Data |
c95f170b |
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 | { |
eca89c5a |
57 | no warnings 'uninitialized'; |
58 | |
c95f170b |
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() }; |
eca89c5a |
112 | like( $ret[0], qr/file.+\Q$0\Q/, 'DB::backtrace() should report current file'); |
c95f170b |
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 | } |