Test skeleton for debugger commands

Message-ID: <87fzj8k0cz.fsf@franz.ak.mind.de>
With minor adjustments

p4raw-id: //depot/perl@21065

diff --git a/MANIFEST b/MANIFEST
index e55b15b..541d451 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1467,6 +1467,8 @@ lib/open.t                        See if the open pragma works
 lib/overload.pm                        Module for overloading perl operators
 lib/overload.t                 See if operator overloading works
 lib/perl5db.pl                 Perl debugging routines
+lib/perl5db/de0.t              Testing debugger commands
+lib/perl5db/dumpvar.t          Testing the dumper used by the debugger
 lib/PerlIO.pm                  PerlIO support module
 lib/PerlIO/via/QuotedPrint.pm  PerlIO::via::QuotedPrint
 lib/PerlIO/via/t/QuotedPrint.t PerlIO::via::QuotedPrint

diff --git a/lib/perl5db/de0.t b/lib/perl5db/de0.t
new file mode 100644 (file)
index 0000000..b5a416f
--- /dev/null
+++ b/lib/perl5db/de0.t
@@ -0,0 +1,72 @@
+#!./perl -- -*- mode: cperl; cperl-indent-level: 4 -*-
+
+BEGIN {
+    if ($^O eq 'VMS') {
+       print "1..0 # skip on VMS\n";
+       exit 0;
+    }
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    $ENV{PERL5LIB} = '../lib';    # so children will see it too
+}
+
+use strict;
+
+$|=1;
+undef $/;
+my @prgs = split "########\n", <DATA>;
+close DATA;
+print "1..", scalar @prgs, "\n";
+require "dumpvar.pl";
+
+our $tmpfile = "perl5db0";
+1 while -f ++$tmpfile;
+END { if ($tmpfile) { 1 while unlink $tmpfile; } }
+
+my $i = 0;
+$ENV{PERLDB_OPTS} = "TTY=0";
+my($ornament1,$ornament2);
+for (@prgs){
+    my($prog,$expected) = split(/\nEXPECT\n?/, $_);
+    open my $select, "| $^X -de0 2> $tmpfile" or die $!;
+    print $select $prog;
+    close $select;
+    my $got = do { open my($fh), $tmpfile or die; local $/; <$fh>; };
+    $got =~ s/^\s*Loading.*\nEditor.*\n\nEnter.*\n\nmain::\(-e:1\):\s0\n//;
+    unless (defined $ornament1) {
+        ($ornament1,$ornament2) = $got =~
+            /(.*?)0\s+'reserved example for calibrating the ornaments'\n(.*)/
+    }
+    $got =~ s/^\Q$ornament1\E//;
+    $got =~ s/\Q$ornament2\E\z//;
+    my $not = "";
+    my $why = "";
+    if ($got !~ /$expected/) {
+        $not = "not ";
+        $got = dumpvar::unctrl($got);
+        $why = " # prog[$prog]got[$got]expected[$expected]";
+    }
+    print $not, "ok ", ++$i, $why, "\n";
+}
+
+__END__
+x "reserved example for calibrating the ornaments"
+EXPECT
+0  'reserved example for calibrating the ornaments'
+########
+x "foo"
+EXPECT
+0  'foo'
+########
+x 1..3
+EXPECT
+0  1
+1  2
+2  3
+########
+x +{1..4}
+EXPECT
+0\s+HASH\(0x[\da-f]+\)
+\s+1 => 2
+\s+3 => 4
+########

diff --git a/lib/perl5db/dumpvar.t b/lib/perl5db/dumpvar.t
new file mode 100644 (file)
index 0000000..74fb1f9
--- /dev/null
+++ b/lib/perl5db/dumpvar.t
@@ -0,0 +1,61 @@
+#!./perl -- -*- mode: cperl; cperl-indent-level: 4 -*-
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+use strict;
+
+$|=1;
+undef $/;
+my @prgs = split "########\n", <DATA>;
+close DATA;
+print "1..", scalar @prgs, "\n";
+require "dumpvar.pl";
+
+my $i = 0;
+for (@prgs){
+    my($prog,$expected) = split(/\nEXPECT\n?/, $_);
+    open my $select, ">", \my $got or die;
+    select $select;
+    eval $prog;
+    my $not = "";
+    my $why = "";
+    if ($@) {
+        $not = "not ";
+        $why = " # prog[$prog]\$\@[$@]";
+    } elsif ($got ne $expected) {
+        $not = "not ";
+        $why = " # prog[$prog]got[$got]expected[$expected]";
+    }
+    close $select;
+    select STDOUT;
+    print $not, "ok ", ++$i, $why, "\n";
+}
+
+__END__
+"";
+EXPECT
+########
+dumpValue(1);
+EXPECT
+1
+########
+dumpValue("1\n2\n3");
+EXPECT
+'1
+2
+3'
+########
+dumpValue([1..3],1);
+EXPECT
+0  1
+1  2
+2  3
+########
+dumpValue({1..4},1);
+EXPECT
+1 => 2
+3 => 4
+########