source: trunk/essentials/dev-lang/perl/lib/DB.t@ 3314

Last change on this file since 3314 was 3181, checked in by bird, 19 years ago

perl 5.8.8
File size: 16.3 KB
Line 
1#!./perl -Tw
2
3BEGIN {
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
14use strict qw( vars subs );
15
16# @DB::dbline values have both integer and string components (Benjamin Goldberg)
17use Scalar::Util qw( dualvar );
18my $dualfalse = dualvar(0, 'false');
19my $dualtrue = dualvar(1, 'true');
20
21use Test::More tests => 106;
22
23# must happen at compile time for DB:: package variable localizations to work
24BEGIN {
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()
87is( DB::_clientname('foo=A(1)'), 'foo',
88 'DB::_clientname should return refname');
89cmp_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
147sub check_context {
148 return (eval "one($_[0])")[-1];
149}
150sub one { DB->backtrace(@_) }
151sub two { one(@_) }
152sub 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()
206SKIP: {
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()
470ok( ! defined DB::prestop('test'),
471 'DB::prestop() should return undef for undef value' );
472DB::prestop('test', 897);
473is( DB::prestop('test'), 897, '... should return value when set' );
474
475# test DB::poststop(), not exactly parallel
476ok( ! defined DB::poststop('tset'),
477 'DB::prestop() should return undef for undef value' );
478DB::poststop('tset', 987);
479is( DB::poststop('tset'), 987, '... should return value when set' );
480
481# test DB::evalcode()
482ok( ! defined DB::evalcode('foo'),
483 'DB::evalcode() should return undef for undef value' );
484
485DB::evalcode('foo', 'bar');
486is( DB::evalcode('foo'), 'bar', '... should return value when set' );
487
488# test DB::_outputall(), must create fake clients first
489ok( DB::register( FakeDB->new() ), 'DB::register() should work' );
490DB::register( FakeDB->new() ) for ( 1 .. 2);
491
492DB::_outputall(1, 2, 3);
493is( $FakeDB::output, '123123123',
494 'DB::_outputall() should call output(@_) on all clients' );
495
496# test virtual methods
497for 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
504package FakeDB;
505
506use vars qw( $output );
507
508sub new {
509 bless({}, $_[0]);
510}
511
512sub set_tbreak {
513 my ($self, $val) = @_;
514 $self->{tbreak} = $val;
515}
516
517sub output {
518 my $self = shift;
519 if (ref $self) {
520 $self->{output} = join('', @_);
521 } else {
522 $output .= join('', @_);
523 }
524}
Note: See TracBrowser for help on using the repository browser.