use warnings;
use Config;
+delete $ENV{PERLDB_OPTS};
+
BEGIN {
if (! -c "/dev/null") {
print "1..0 # Skip: no /dev/null\n";
print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n";
exit 0;
}
+ $ENV{PERL_RL} = 'Perl'; # Suppress system Term::ReadLine::Gnu
}
-plan(77);
+plan(127);
my $rc_filename = '.perldb';
return _slurp($out_fn);
}
-{
- my $target = '../lib/perl5db/t/eval-line-bug';
-
- rc(
- <<"EOF",
- &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
-
- sub afterinit {
- push(\@DB::typeahead,
- 'b 23',
- 'n',
- 'n',
- 'n',
- 'c', # line 23
- 'n',
- "p \\\@{'main::_<$target'}",
- 'q',
- );
- }
-EOF
- );
-
- {
- local $ENV{PERLDB_OPTS} = "ReadLine=0";
- runperl(switches => [ '-d' ], progfile => $target);
- }
-}
-
-like(_out_contents(), qr/sub factorial/,
- 'The ${main::_<filename} variable in the debugger was not destroyed'
-);
-
-{
- my $target = '../lib/perl5db/t/eval-line-bug';
-
- rc(
- <<"EOF",
- &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
-
- sub afterinit {
- push(\@DB::typeahead,
- 'b 23',
- 'c',
- '\$new_var = "Foo"',
- 'x "new_var = <\$new_var>\\n";',
- 'q',
- );
- }
-EOF
- );
-
- {
- local $ENV{PERLDB_OPTS} = "ReadLine=0";
- runperl(switches => [ '-d' ], progfile => $target);
- }
-}
-
-like(_out_contents(), qr/new_var = <Foo>/,
- "no strict 'vars' in evaluated lines.",
-);
-
-{
- local $ENV{PERLDB_OPTS} = "ReadLine=0";
- my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/lvalue-bug');
- like($output, qr/foo is defined/, 'lvalue subs work in the debugger');
-}
-
-{
- local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
- my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/symbol-table-bug');
- like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table');
-}
-
-SKIP: {
- if ( $Config{usethreads} ) {
- skip('This perl has threads, skipping non-threaded debugger tests');
- } else {
- my $error = 'This Perl not built to support threads';
- my $output = runperl( switches => [ '-dt' ], stderr => 1 );
- like($output, qr/$error/, 'Perl debugger correctly complains that it was not built with threads');
- }
-
-}
-SKIP: {
- if ( $Config{usethreads} ) {
- local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
- my $output = runperl(switches => [ '-dt' ], progfile => '../lib/perl5db/t/symbol-table-bug');
- like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table when running with thread support');
- } else {
- skip("This perl is not threaded, skipping threaded debugger tests");
- }
-}
-
-
-# Test [perl #61222]
-{
- local $ENV{PERLDB_OPTS};
- rc(
- <<'EOF',
- &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
-
- sub afterinit {
- push(@DB::typeahead,
- 'm Pie',
- 'q',
- );
- }
-EOF
- );
-
- my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-61222');
- unlike(_out_contents(), qr/INCORRECT/, "[perl #61222]");
-}
-
-
# Test for Proxy constants
{
rc(
<<'EOF',
-&parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out");
+&parse_options("NonStop=0 ReadLine=0 TTY=db.out");
sub afterinit {
push(@DB::typeahead,
{
local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
- like($output, "All tests successful.", "[perl #66110]");
+ like($output, qr/\bAll tests successful\.$/, "[perl #66110]");
}
-
-# [perl 104168] level option for tracing
+# [ perl #116769] Frame=2
{
- rc(<<'EOF');
-&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
-
-sub afterinit {
- push (@DB::typeahead,
- 't 2',
- 'c',
- 'q',
- );
-
+ local $ENV{PERLDB_OPTS} = "frame=2 nonstop";
+ my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' );
+ is( $?, 0, '[perl #116769] frame=2 does not crash debugger, exit == 0' );
+ is( $output, "success\n" , '[perl #116769] code is run' );
}
-EOF
-
- my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-104168');
- my $contents = _out_contents();
- like($contents, qr/level 2/, "[perl #104168]");
- unlike($contents, qr/baz/, "[perl #104168]");
+# [ perl #116771] autotrace
+{
+ local $ENV{PERLDB_OPTS} = "autotrace nonstop";
+ my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' );
+ is( $?, 0, '[perl #116771] autotrace does not crash debugger, exit == 0' );
+ is( $output, "success\n" , '[perl #116771] code is run' );
}
-
-# taint tests
-
+# [ perl #41461] Frame=2 noTTY
{
- local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
- my $output = runperl(switches => [ '-d', '-T' ], stderr => 1,
- progfile => '../lib/perl5db/t/taint');
- chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
- is($output, '[$^X][done]', "taint");
+ local $ENV{PERLDB_OPTS} = "frame=2 noTTY nonstop";
+ rc('');
+ my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' );
+ is( $?, 0, '[perl #41461] frame=2 noTTY does not crash debugger, exit == 0' );
+ is( $output, "success\n" , '[perl #41461] code is run' );
}
package DebugWrap;
return $self->{_include_t};
}
+sub _stderr_val
+{
+ my $self = shift;
+
+ if (@_)
+ {
+ $self->{_stderr_val} = shift;
+ }
+
+ return $self->{_stderr_val};
+}
+
+sub field
+{
+ my $self = shift;
+
+ if (@_)
+ {
+ $self->{field} = shift;
+ }
+
+ return $self->{field};
+}
+
+sub _switches
+{
+ my $self = shift;
+
+ if (@_)
+ {
+ $self->{_switches} = shift;
+ }
+
+ return $self->{_switches};
+}
+
sub _contents
{
my $self = shift;
$self->_include_t($args->{include_t} ? 1 : 0);
+ $self->_stderr_val(exists($args->{stderr}) ? $args->{stderr} : 1);
+
+ if (exists($args->{switches}))
+ {
+ $self->_switches($args->{switches});
+ }
+
$self->_run();
return;
sub _run {
my $self = shift;
- my $rc = qq{&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");\n};
+ my $rc = qq{&parse_options("NonStop=0 TTY=db.out");\n};
$rc .= join('',
map { "$_\n"}
::runperl(
switches =>
[
- '-d',
+ ($self->_switches ? (@{$self->_switches()}) : ('-d')),
($self->_include_t ? ('-I', '../lib/perl5db/t') : ())
],
- stderr => 1,
+ (defined($self->_stderr_val())
+ ? (stderr => $self->_stderr_val())
+ : ()
+ ),
progfile => $self->_prog()
);
return;
}
+sub get_output
+{
+ return shift->_output();
+}
+
sub output_like {
my ($self, $re, $msg) = @_;
package main;
+{
+ local $ENV{PERLDB_OPTS} = "ReadLine=0";
+ my $target = '../lib/perl5db/t/eval-line-bug';
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 23',
+ 'n',
+ 'n',
+ 'n',
+ 'c', # line 23
+ 'n',
+ "p \@{'main::_<$target'}",
+ 'q',
+ ],
+ prog => $target,
+ }
+ );
+ $wrapper->contents_like(
+ qr/sub factorial/,
+ 'The ${main::_<filename} variable in the debugger was not destroyed',
+ );
+}
+
+sub _calc_generic_wrapper
+{
+ my $args = shift;
+
+ my $extra_opts = delete($args->{extra_opts});
+ $extra_opts ||= '';
+ local $ENV{PERLDB_OPTS} = "ReadLine=0" . $extra_opts;
+ return DebugWrap->new(
+ {
+ cmds => delete($args->{cmds}),
+ prog => delete($args->{prog}),
+ %$args,
+ }
+ );
+}
+
+sub _calc_new_var_wrapper
+{
+ my ($args) = @_;
+ return _calc_generic_wrapper(
+ {
+ cmds =>
+ [
+ 'b 23',
+ 'c',
+ '$new_var = "Foo"',
+ 'x "new_var = <$new_var>\\n"',
+ 'q',
+ ],
+ %$args,
+ }
+ );
+}
+
+sub _calc_threads_wrapper
+{
+ my $args = shift;
+
+ return _calc_new_var_wrapper(
+ {
+ switches => [ '-dt', ],
+ stderr => 1,
+ %$args
+ }
+ );
+}
+
+{
+ _calc_new_var_wrapper({ prog => '../lib/perl5db/t/eval-line-bug'})
+ ->contents_like(
+ qr/new_var = <Foo>/,
+ "no strict 'vars' in evaluated lines.",
+ );
+}
+
+{
+ _calc_new_var_wrapper(
+ {
+ prog => '../lib/perl5db/t/lvalue-bug',
+ stderr => undef(),
+ },
+ )->output_like(
+ qr/foo is defined/,
+ 'lvalue subs work in the debugger',
+ );
+}
+
+{
+ _calc_new_var_wrapper(
+ {
+ prog => '../lib/perl5db/t/symbol-table-bug',
+ extra_opts => "NonStop=1",
+ stderr => undef(),
+ }
+ )->output_like(
+ qr/Undefined symbols 0/,
+ 'there are no undefined values in the symbol table',
+ );
+}
+
+SKIP:
+{
+ if ( $Config{usethreads} ) {
+ skip('This perl has threads, skipping non-threaded debugger tests');
+ }
+ else {
+ my $error = 'This Perl not built to support threads';
+ _calc_threads_wrapper(
+ {
+ prog => '../lib/perl5db/t/eval-line-bug',
+ }
+ )->output_like(
+ qr/\Q$error\E/,
+ 'Perl debugger correctly complains that it was not built with threads',
+ );
+ }
+}
+
+SKIP:
+{
+ if ( $Config{usethreads} ) {
+ _calc_threads_wrapper(
+ {
+ prog => '../lib/perl5db/t/symbol-table-bug',
+ }
+ )->output_like(
+ qr/Undefined symbols 0/,
+ 'there are no undefined values in the symbol table when running with thread support',
+ );
+ }
+ else {
+ skip("This perl is not threaded, skipping threaded debugger tests");
+ }
+}
+
+# Test [perl #61222]
+{
+ local $ENV{PERLDB_OPTS};
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'm Pie',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/rt-61222',
+ }
+ );
+
+ $wrapper->contents_unlike(qr/INCORRECT/, "[perl #61222]");
+}
+
+sub _calc_trace_wrapper
+{
+ my ($args) = @_;
+
+ return _calc_generic_wrapper(
+ {
+ cmds =>
+ [
+ 't 2',
+ 'c',
+ 'q',
+ ],
+ %$args,
+ }
+ );
+}
+
+# [perl 104168] level option for tracing
+{
+ my $wrapper = _calc_trace_wrapper({ prog => '../lib/perl5db/t/rt-104168' });
+ $wrapper->contents_like(qr/level 2/, "[perl #104168] - level 2 appears");
+ $wrapper->contents_unlike(qr/baz/, "[perl #104168] - no 'baz'");
+}
+
+# taint tests
+{
+ my $wrapper = _calc_trace_wrapper(
+ {
+ prog => '../lib/perl5db/t/taint',
+ extra_opts => ' NonStop=1',
+ switches => [ '-d', '-T', ],
+ }
+ );
+
+ my $output = $wrapper->get_output();
+ chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
+ is($output, '[$^X][done]', "taint");
+}
+
# Testing that we can set a line in the middle of the file.
{
my $wrapper = DebugWrap->new(
);
}
-# Tests for "T" (stack trace).
+# Tests for x with @_
{
- my $prog_fn = '../lib/perl5db/t/rt-104168';
my $wrapper = DebugWrap->new(
{
- prog => $prog_fn,
cmds =>
[
- 'c baz',
- 'T',
+ 'b 10',
+ 'c',
+ 'x @_',
'q',
],
+ prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc',
}
);
- my $re_text = join('',
- map {
- sprintf(
- "%s = %s\\(\\) called from file " .
- "'" . quotemeta($prog_fn) . "' line %s\\n",
- (map { quotemeta($_) } @$_)
- )
- }
- (
- ['.', 'main::baz', 14,],
- ['.', 'main::bar', 9,],
- ['.', 'main::foo', 6],
- )
- );
+
+ $wrapper->contents_like(
+ # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
+ qr/Arg1.*?Capsula.*GreekHumor.*Socrates/ms,
+ q/x command test with '@_'./,
+ );
+}
+
+# Tests for mutating @_
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 10',
+ 'c',
+ 'shift(@_)',
+ 'print "\n\n\n(((" . join(",", @_) . ")))\n\n\n"',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc',
+ }
+ );
+
+ $wrapper->output_like(
+ qr/^\(\(\(Capsula,GreekHumor,Socrates\)\)\)$/ms,
+ q/Mutating '@_'./,
+ );
+}
+
+# Tests for x with AutoTrace=1.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'n',
+ 'o AutoTrace=1',
+ # So it may fail.
+ q/x "failure"/,
+ q/x \$x/,
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/with-subroutine',
+ }
+ );
+
+ $wrapper->contents_like(
+ # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
+ qr/^0\s+SCALAR\([^\)]+\)\n\s+-> 'hello world'\n/ms,
+ "x after AutoTrace=1 command is working."
+ );
+}
+
+# Tests for "T" (stack trace).
+{
+ my $prog_fn = '../lib/perl5db/t/rt-104168';
+ my $wrapper = DebugWrap->new(
+ {
+ prog => $prog_fn,
+ cmds =>
+ [
+ 'c baz',
+ 'T',
+ 'q',
+ ],
+ }
+ );
+ my $re_text = join('',
+ map {
+ sprintf(
+ "%s = %s\\(\\) called from file " .
+ "'" . quotemeta($prog_fn) . "' line %s\\n",
+ (map { quotemeta($_) } @$_)
+ )
+ }
+ (
+ ['.', 'main::baz', 14,],
+ ['.', 'main::bar', 9,],
+ ['.', 'main::foo', 6],
+ )
+ );
$wrapper->contents_like(
# qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
qr/^$re_text/ms,
);
}
+# Test for n with lvalue subs
+DebugWrap->new({
+ cmds =>
+ [
+ 'n', 'print "<$x>\n"',
+ 'n', 'print "<$x>\n"',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/lsub-n',
+})->output_like(
+ qr/<1>\n<11>\n/,
+ 'n steps over lvalue subs',
+);
+
# Test for 'M' (module list).
{
my $wrapper = DebugWrap->new(
$wrapper->contents_like(
qr/
$line_out
+ auto\(-\d+\)\s+DB<\d+>\s+\.\n
$line_out
/msx,
'Test the "." command',
);
}
-# Test the a command.
+# Test the 'a' command.
{
my $wrapper = DebugWrap->new(
{
}
);
+ my $nl = $^O eq 'VMS' ? "" : "\\\n";
$wrapper->output_like(qr#
- \nVar<Q>=1\n
- \nVar<Q>=2\n
- \nVar<Q>=3\n
+ \nVar<Q>=1$nl
+ \nVar<Q>=2$nl
+ \nVar<Q>=3
#msx,
"a command is working",
);
}
+# Test the 'a' command with no line number.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'n',
+ q/a print "Hello " . (3 * 4) . "\n";/,
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-a-statement-1',
+ }
+ );
+
+ $wrapper->output_like(qr#
+ (?:^Hello\ 12\n.*?){4}
+ #msx,
+ "a command with no line number is working",
+ );
+}
+
# Test the 'A' command
{
my $wrapper = DebugWrap->new(
);
}
+# Test the ! command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'l 3-5',
+ '!',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ (^3:\s+my\ \$dummy\ =\ 0;\n
+ 4\s*\n
+ 5:\s+\$x\ =\ "FirstVal";)\n
+ .*?
+ ^l\ 3-5\n
+ \1
+ #msx,
+ 'Test the ! command (along with l 3-5)',
+ );
+}
+
+# Test the ! -number command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'l 3-5',
+ 'l 2',
+ '! -1',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ (^3:\s+my\ \$dummy\ =\ 0;\n
+ 4\s*\n
+ 5:\s+\$x\ =\ "FirstVal";)\n
+ .*?
+ ^2==\>\s+my\ \$x\ =\ "One";\n
+ .*?
+ ^l\ 3-5\n
+ \1
+ #msx,
+ 'Test the ! -n command (along with l)',
+ );
+}
+
+# Test the 'source' command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'source ../lib/perl5db/t/source-cmd-test.perldb',
+ # If we have a 'q' here, then the typeahead will override the
+ # input, and so it won't be reached - solution:
+ # put a q inside the .perldb commands.
+ # ( This may be a bug or a misfeature. )
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^3:\s+my\ \$dummy\ =\ 0;\n
+ 4\s*\n
+ 5:\s+\$x\ =\ "FirstVal";\n
+ 6\s*\n
+ 7:\s+\$dummy\+\+;\n
+ 8\s*\n
+ 9:\s+\$x\ =\ "SecondVal";\n
+ 10\s*\n
+ #msx,
+ 'Test the source command (along with l)',
+ );
+}
+
+# Test the 'source' command being traversed from withing typeahead.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'source ../lib/perl5db/t/source-cmd-test-no-q.perldb',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^3:\s+my\ \$dummy\ =\ 0;\n
+ 4\s*\n
+ 5:\s+\$x\ =\ "FirstVal";\n
+ 6\s*\n
+ 7:\s+\$dummy\+\+;\n
+ 8\s*\n
+ 9:\s+\$x\ =\ "SecondVal";\n
+ 10\s*\n
+ #msx,
+ 'Test the source command inside a typeahead',
+ );
+}
+
+# Test the 'H -number' command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'l 1-10',
+ 'l 5-10',
+ 'x "Hello World"',
+ 'l 1-5',
+ 'b 3',
+ 'x (20+4)',
+ 'H -7',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^\d+:\s+H\ -7\n
+ \d+:\s+x\ \(20\+4\)\n
+ \d+:\s+b\ 3\n
+ \d+:\s+l\ 1-5\n
+ \d+:\s+x\ "Hello\ World"\n
+ \d+:\s+l\ 5-10\n
+ \d+:\s+l\ 1-10\n
+ #msx,
+ 'Test the H -num command',
+ );
+}
+
+# Add a test for H (without arguments)
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'l 1-10',
+ 'l 5-10',
+ 'x "Hello World"',
+ 'l 1-5',
+ 'b 3',
+ 'x (20+4)',
+ 'H',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^\d+:\s+x\ \(20\+4\)\n
+ \d+:\s+b\ 3\n
+ \d+:\s+l\ 1-5\n
+ \d+:\s+x\ "Hello\ World"\n
+ \d+:\s+l\ 5-10\n
+ \d+:\s+l\ 1-10\n
+ #msx,
+ 'Test the H command (without a number.)',
+ );
+}
+
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ '= quit q',
+ '= foobar l',
+ 'foobar',
+ 'quit',
+ ],
+ prog => '../lib/perl5db/t/test-l-statement-1',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/
+ ^1==>\s+\$x\ =\ 1;\n
+ 2:\s+print\ "1\\n";\n
+ 3\s*\n
+ 4:\s+\$x\ =\ 2;\n
+ 5:\s+print\ "2\\n";\n
+ /msx,
+ 'Test the = (command alias) command.',
+ );
+}
+
+# Test the m statement.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'm main',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^via\ UNIVERSAL:\ DOES$
+ #msx,
+ "Test m for main - 1",
+ );
+
+ $wrapper->contents_like(qr#
+ ^via\ UNIVERSAL:\ can$
+ #msx,
+ "Test m for main - 2",
+ );
+}
+
+# Test the m statement.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 41',
+ 'c',
+ 'm $obj',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-m-statement-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#^greet$#ms,
+ "Test m for obj - 1",
+ );
+
+ $wrapper->contents_like(qr#^via UNIVERSAL: can$#ms,
+ "Test m for obj - 1",
+ );
+}
+
+# Test the M command.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'M',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-m-statement-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^'strict\.pm'\ =>\ '\d+\.\d+\ from
+ #msx,
+ "Test M",
+ );
+
+}
+
+# Test the recallCommand option.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o recallCommand=%',
+ 'l 3-5',
+ 'l 2',
+ '% -1',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ (^3:\s+my\ \$dummy\ =\ 0;\n
+ 4\s*\n
+ 5:\s+\$x\ =\ "FirstVal";)\n
+ .*?
+ ^2==\>\s+my\ \$x\ =\ "One";\n
+ .*?
+ ^l\ 3-5\n
+ \1
+ #msx,
+ 'Test the o recallCommand option',
+ );
+}
+
+# Test the dieLevel option
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ q/o dieLevel='1'/,
+ q/c/,
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-dieLevel-option-1',
+ }
+ );
+
+ $wrapper->output_like(qr#
+ ^This\ program\ dies\.\ at\ \S+\ line\ 18\N*\.\n
+ .*?
+ ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
+ \s+main::bar\(\)\ called\ at\ \S+\ line\ 7\n
+ \s+main::foo\(\)\ called\ at\ \S+\ line\ 21\n
+ #msx,
+ 'Test the o dieLevel option',
+ );
+}
+
+# Test the warnLevel option
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ q/o warnLevel='1'/,
+ q/c/,
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-warnLevel-option-1',
+ }
+ );
+
+ $wrapper->contents_like(qr#
+ ^This\ is\ not\ a\ warning\.\ at\ \S+\ line\ 18\N*\.\n
+ .*?
+ ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
+ \s+main::bar\(\)\ called\ at\ \S+\ line\ 25\n
+ \s+main::myfunc\(\)\ called\ at\ \S+\ line\ 28\n
+ #msx,
+ 'Test the o warnLevel option',
+ );
+}
+
+# Test the t command
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 't',
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr/
+ ^main::\([^:]+:15\):\n
+ 15:\s+\$dummy\+\+;\n
+ main::\([^:]+:17\):\n
+ 17:\s+\$x\ =\ "FourthVal";\n
+ /msx,
+ 'Test the t command (without a number.)',
+ );
+}
+
+# Test the o AutoTrace command
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o AutoTrace',
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/disable-breakpoints-1',
+ }
+ );
+
+ $wrapper->contents_like(qr/
+ ^main::\([^:]+:15\):\n
+ 15:\s+\$dummy\+\+;\n
+ main::\([^:]+:17\):\n
+ 17:\s+\$x\ =\ "FourthVal";\n
+ /msx,
+ 'Test the o AutoTrace command',
+ );
+}
+
+# Test the t command with function calls
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 't',
+ 'b 18',
+ 'c',
+ 'x ["foo"]',
+ 'x ["bar"]',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-warnLevel-option-1',
+ }
+ );
+
+ $wrapper->contents_like(qr/
+ ^main::\([^:]+:28\):\n
+ 28:\s+myfunc\(\);\n
+ auto\(-\d+\)\s+DB<1>\s+t\n
+ Trace\ =\ on\n
+ auto\(-\d+\)\s+DB<1>\s+b\ 18\n
+ auto\(-\d+\)\s+DB<2>\s+c\n
+ main::myfunc\([^:]+:25\):\n
+ 25:\s+bar\(\);\n
+ /msx,
+ 'Test the t command with function calls.',
+ );
+}
+
+# Test the o AutoTrace command with function calls
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o AutoTrace',
+ 'b 18',
+ 'c',
+ 'x ["foo"]',
+ 'x ["bar"]',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-warnLevel-option-1',
+ }
+ );
+
+ $wrapper->contents_like(qr/
+ ^main::\([^:]+:28\):\n
+ 28:\s+myfunc\(\);\n
+ auto\(-\d+\)\s+DB<1>\s+o\ AutoTrace\n
+ \s+AutoTrace\s+=\s+'1'\n
+ auto\(-\d+\)\s+DB<2>\s+b\ 18\n
+ auto\(-\d+\)\s+DB<3>\s+c\n
+ main::myfunc\([^:]+:25\):\n
+ 25:\s+bar\(\);\n
+ /msx,
+ 'Test the o AutoTrace command with function calls.',
+ );
+}
+
+# Test the final message.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-warnLevel-option-1',
+ }
+ );
+
+ $wrapper->contents_like(qr/
+ ^Debugged\ program\ terminated\.
+ /msx,
+ 'Test the final "Debugged program terminated" message.',
+ );
+}
+
+# Test the o inhibit_exit=0 command
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o inhibit_exit=0',
+ 'n',
+ 'n',
+ 'n',
+ 'n',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-warnLevel-option-1',
+ }
+ );
+
+ $wrapper->contents_unlike(qr/
+ ^Debugged\ program\ terminated\.
+ /msx,
+ 'Test the o inhibit_exit=0 command.',
+ );
+}
+
+# Test the o PrintRet=1 option
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o PrintRet=1',
+ 'b 29',
+ 'c',
+ q/$x = 's';/,
+ 'b 10',
+ 'c',
+ 'r',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-PrintRet-option-1',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/scalar context return from main::return_scalar: 20024/,
+ "Test o PrintRet=1",
+ );
+}
+
+# Test the o PrintRet=0 option
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o PrintRet=0',
+ 'b 29',
+ 'c',
+ q/$x = 's';/,
+ 'b 10',
+ 'c',
+ 'r',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-PrintRet-option-1',
+ }
+ );
+
+ $wrapper->contents_unlike(
+ qr/scalar context/,
+ "Test o PrintRet=0",
+ );
+}
+
+# Test the o PrintRet=1 option in list context
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o PrintRet=1',
+ 'b 29',
+ 'c',
+ q/$x = 'l';/,
+ 'b 17',
+ 'c',
+ 'r',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-PrintRet-option-1',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/list context return from main::return_list:\n0\s*'Foo'\n1\s*'Bar'\n2\s*'Baz'\n/,
+ "Test o PrintRet=1 in list context",
+ );
+}
+
+# Test the o PrintRet=0 option in list context
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o PrintRet=0',
+ 'b 29',
+ 'c',
+ q/$x = 'l';/,
+ 'b 17',
+ 'c',
+ 'r',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-PrintRet-option-1',
+ }
+ );
+
+ $wrapper->contents_unlike(
+ qr/list context/,
+ "Test o PrintRet=0 in list context",
+ );
+}
+
+# Test the o PrintRet=1 option in void context
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o PrintRet=1',
+ 'b 29',
+ 'c',
+ q/$x = 'v';/,
+ 'b 24',
+ 'c',
+ 'r',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-PrintRet-option-1',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/void context return from main::return_void/,
+ "Test o PrintRet=1 in void context",
+ );
+}
+
+# Test the o PrintRet=1 option in void context
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'o PrintRet=0',
+ 'b 29',
+ 'c',
+ q/$x = 'v';/,
+ 'b 24',
+ 'c',
+ 'r',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-PrintRet-option-1',
+ }
+ );
+
+ $wrapper->contents_unlike(
+ qr/void context/,
+ "Test o PrintRet=0 in void context",
+ );
+}
+
+# Test the o frame option.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ # This is to avoid getting the "Debugger program terminated"
+ # junk that interferes with the normal output.
+ 'o inhibit_exit=0',
+ 'b 10',
+ 'c',
+ 'o frame=255',
+ 'c',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-frame-option-1',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/
+ in\s*\.=main::my_other_func\(3,\ 1200\)\ from.*?
+ out\s*\.=main::my_other_func\(3,\ 1200\)\ from
+ /msx,
+ "Test o PrintRet=0 in void context",
+ );
+}
+
+{ # test t expr
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ # This is to avoid getting the "Debugger program terminated"
+ # junk that interferes with the normal output.
+ 'o inhibit_exit=0',
+ 't fact(3)',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/fact',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/
+ (?:^main::fact.*return\ \$n\ \*\ fact\(\$n\ -\ 1\);.*)
+ /msx,
+ "Test t expr",
+ );
+}
+
+# Test the w for lexical variables expression.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ # This is to avoid getting the "Debugger program terminated"
+ # junk that interferes with the normal output.
+ 'w $exp',
+ 'n',
+ 'n',
+ 'n',
+ 'n',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/break-on-dot',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/
+\s+old\ value:\s+'1'\n
+\s+new\ value:\s+'2'\n
+ /msx,
+ "Test w for lexical values.",
+ );
+}
+
+# perl 5 RT #121509 regression bug.
+# “perl debugger doesn't save starting dir to restart from”
+# Thanks to Linda Walsh for reporting it.
+{
+ use File::Temp qw/tempdir/;
+
+ my $temp_dir = tempdir( CLEANUP => 1 );
+
+ local $ENV{__PERLDB_TEMP_DIR} = $temp_dir;
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ # This is to avoid getting the "Debugger program terminated"
+ # junk that interferes with the normal output.
+ 'b _after_chdir',
+ 'c',
+ 'R',
+ 'b _finale',
+ 'c',
+ 'n',
+ 'n',
+ 'n',
+ 'n',
+ 'n',
+ 'n',
+ 'n',
+ 'n',
+ 'n',
+ 'n',
+ 'n',
+ 'n',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/rt-121509-restart-after-chdir',
+ }
+ );
+
+ $wrapper->output_like(
+ qr/
+In\ _finale\ No\ 1
+ .*?
+In\ _finale\ No\ 2
+ .*?
+In\ _finale\ No\ 3
+ /msx,
+ "Test that the debugger chdirs to the initial directory after a restart.",
+ );
+}
+# Test the perldoc command
+# We don't actually run the program, but we need to provide one to the wrapper.
+SKIP:
+{
+ $^O eq "linux"
+ or skip "man errors aren't especially portable", 1;
+ -x '/usr/bin/man'
+ or skip "man command seems to be missing", 1;
+ local $ENV{LANG} = "C";
+ local $ENV{LC_MESSAGES} = "C";
+ local $ENV{LC_ALL} = "C";
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'perldoc perlrules',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/fact',
+ }
+ );
+
+ $wrapper->output_like(
+ qr/No (?:manual )?entry for perlrules/,
+ 'perldoc command works fine',
+ );
+}
+
+# [perl #71678] debugger bug in evaluation of user actions ('a' command)
+# Still evaluated after the script finishes.
+{
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ q#a 9 print " \$arg = $arg\n"#,
+ 'c 9',
+ 's',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/test-a-statement-2',
+ switches => [ '-dw', ],
+ stderr => 1,
+ }
+ );
+
+ $wrapper->contents_unlike(qr/
+ Use\ of\ uninitialized\ value\ \$arg\ in\ concatenation\ [\S ]+\ or\ string\ at
+ /msx,
+ 'Test that the a command does not emit warnings on program exit.',
+ );
+}
+
+{
+ # perl 5 RT #126735 regression bug.
+ local $ENV{PERLDB_OPTS} = "NonStop=0 RemotePort=non-existent-host.tld:9001";
+ my $output = runperl( stdin => "q\n", stderr => 1, switches => [ '-d' ], prog => '../lib/perl5db/t/fact' );
+ like(
+ $output,
+ qr/^Unable to connect to remote host:/ms,
+ 'Tried to connect.',
+ );
+ unlike(
+ $output,
+ qr/syntax error/,
+ 'Can quit from the debugger after a wrong RemotePort',
+ );
+}
+
+{
+ # perl 5 RT #120174 - 'p' command
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 2',
+ 'c',
+ 'p@abc',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/rt-120174',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/1234/,
+ q/RT 120174: p command can be invoked without space after 'p'/,
+ );
+}
+
+{
+ # perl 5 RT #120174 - 'x' command on array
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 2',
+ 'c',
+ 'x@abc',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/rt-120174',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/0\s+1\n1\s+2\n2\s+3\n3\s+4/ms,
+ q/RT 120174: x command can be invoked without space after 'x' before array/,
+ );
+}
+
+{
+ # perl 5 RT #120174 - 'x' command on array ref
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 2',
+ 'c',
+ 'x\@abc',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/rt-120174',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/\s+0\s+1\n\s+1\s+2\n\s+2\s+3\n\s+3\s+4/ms,
+ q/RT 120174: x command can be invoked without space after 'x' before array ref/,
+ );
+}
+
+{
+ # perl 5 RT #120174 - 'x' command on hash ref
+ my $wrapper = DebugWrap->new(
+ {
+ cmds =>
+ [
+ 'b 4',
+ 'c',
+ 'x\%xyz',
+ 'q',
+ ],
+ prog => '../lib/perl5db/t/rt-120174',
+ }
+ );
+
+ $wrapper->contents_like(
+ qr/\s+'alpha'\s+=>\s+'beta'\n\s+'gamma'\s+=>\s+'delta'/ms,
+ q/RT 120174: x command can be invoked without space after 'x' before hash ref/,
+ );
+}
+
END {
1 while unlink ($rc_filename, $out_fn);
}
https://perl5.git.perl.org / perl5.git / blobdiff