extra code in pp_concat, Take 2
[p5sagit/p5-mst-13.2.git] / 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 }