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