Here's a bunch of tests for DB.pm. Some bits aren't easily testable, and
there's room for someone more knowledgeable or clever to come along to improve
them even more.
In the process of writing these tests, I patched one little thing in DB.pm, per
the comment.
With the patch, all pass.
-- c
--- lib/~DB.pm Fri Nov 23 14:04:53 2001
+++ lib/DB.pm Fri Nov 23 14:48:12 2001
@@ -406,8 +406,7 @@
$name = "main" . $name if substr($name,0,2) eq "::";
my($fname, $from, $to) = ($DB::sub{$name} =~ /^(.*):(\d+)-(\d+)$/);
if ($from) {
-# XXX this needs local()-ization of some sort
-*DB::dbline = "::_<$fname";
+local *DB::dbline = "::_<$fname";
++$from while $DB::dbline[$from] == 0 && $from < $to;
return $from;
}
--- ~MANIFEST Fri Nov 23 14:51:04 2001
+++ MANIFESTFri Nov 23 14:51:27 2001
@@ -888,6 +888,7 @@
lib/ctime.pl A ctime workalike
lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir)
lib/DB.pm Debugger API (draft)
+lib/DB.t See if DB works
lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm
lib/Devel/SelfStubber.tSee if Devel::SelfStubber works
lib/diagnostics.pm Print verbose diagnostics
--- /dev/null Thu Aug 30 03:54:37 2001
+++ lib/DB.tFri Nov 23 15:22:17 2001
@@ -0,0 +1,486 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Test::More tests => 106;
+
+# must happen at compile time for DB:: package variable localizations to work
+BEGIN {
+ use_ok( 'DB' );
+}
+
+# test DB::sub()
+{
+ my $callflag = 0;
+ local $DB::sub = sub {
+ $callflag += shift || 1;
+ my @vals = (1, 4, 9);
+ return @vals;
+ };
+ my $ret = DB::sub;
+ is( $ret, 3, 'DB::sub() should handle scalar context' );
+ is( $callflag, 1, '... should call $DB::sub contents' );
+ $ret = join(' ', DB::sub(2));
+ is( $ret, '1 4 9', '... should handle scalar context' );
+ is( $callflag, 3, '... should pass along arguments to the sub' );
+ ok( defined($DB::ret),'$DB::ret should be defined after successful return');
+ DB::sub;
+ ok( !defined($DB::ret), '... should respect void context' );
+ $DB::sub = '::DESTROY';
+ ok( !defined($DB::ret), '... should return undef for DESTROY()' );
+}
+
+# test DB::DB()
+{
+ is( DB::DB(), undef, 'DB::DB() should return undef if $DB::ready is false');
+ is( DB::catch(), 1, 'DB::catch() should work' );
+ is( DB->skippkg('foo'), 1, 'DB->skippkg() should push args' );
+
+ # change packages to mess with caller()
+ package foo;
+ ::is( DB::DB(), undef, 'DB::DB() should skip skippable packages' );
+
+ package main;
+ is( $DB::filename, $0, '... should set $DB::filename' );
+ is( $DB::lineno, __LINE__ - 4, '... should set $DB::lineno' );
+
+ DB::DB();
+ # stops at line 94
+}
+
+# test DB::save()
+{
+ # assigning a number to $! seems to produce an error message, when read
+ local ($@, $,, $/, $\, $^W, $!) = (1 .. 5);
+ DB::save();
+ is( "$@$!$,$/$\$^W", "1\n0", 'DB::save() should reset punctuation vars' );
+}
+
+# test DB::catch()
+{
+ local $DB::signal;
+ DB::catch();
+ ok( $DB::signal, 'DB::catch() should set $DB::signal' );
+ # add clients and test to see if they are awakened
+}
+
+# test DB::_clientname()
+is( DB::_clientname('foo=A(1)'), 'foo','DB::_clientname should return refname');
+is( DB::_clientname('bar'), '','DB::_clientname should not return non refname');
+
+# test DB::next() and DB::step()
+{
+ local $DB::single;
+ DB->next();
+ is( $DB::single, 2, 'DB->next() should set $DB::single to 2' );
+ DB->step();
+ is( $DB::single, 1, 'DB->step() should set $DB::single to 1' );
+}
+
+# test DB::cont()
+{
+ # cannot test @stack
+
+ local $DB::single = 1;
+ my $fdb = FakeDB->new();
+ DB::cont($fdb, 2);
+ is( $fdb->{tbreak}, 2, 'DB::cont() should set tbreak in object' );
+ is( $DB::single, 0, '... should set $DB::single to 0' );
+}
+
+# test DB::ret()
+{
+ # cannot test @stack
+
+ local $DB::single = 1;
+ DB::ret();
+ is( $DB::single, 0, 'DB::ret() should set $DB::single to 0' );
+}
+
+# test DB::backtrace()
+{
+ local (@DB::args, $DB::signal);
+
+ my $line = __LINE__ + 1;
+ my @ret = eval { DB->backtrace() };
+ like( $ret[0], qr/file.+$0/, 'DB::backtrace() should report current file');
+ like( $ret[0], qr/line $line/, '... should report calling line number' );
+ like( $ret[0], qr/eval {...}/, '... should catch eval BLOCK' );
+
+ @ret = eval "one(2)";
+ is( scalar @ret, 1, '... should report from provided stack frame number' );
+ like( $ret[0], qr/\@ = &eval \'one.+?2\)\'/, #'
+ '... should find eval STRING construct')
