X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e931e533f20d38794ea18686385de5f094d79e22..1a40b6f708f420ef8d46f93bd4f2c29113f28a55:/lib/perl5db.t diff --git a/lib/perl5db.t b/lib/perl5db.t index 9e40776..3d432ad 100644 --- a/lib/perl5db.t +++ b/lib/perl5db.t @@ -10,6 +10,8 @@ use strict; use warnings; use Config; +delete $ENV{PERLDB_OPTS}; + BEGIN { if (! -c "/dev/null") { print "1..0 # Skip: no /dev/null\n"; @@ -26,9 +28,10 @@ BEGIN { 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(79); +plan(127); my $rc_filename = '.perldb'; @@ -65,79 +68,13 @@ sub _out_contents return _slurp($out_fn); } -{ - 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 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, @@ -157,38 +94,29 @@ EOF { 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; @@ -268,6 +196,19 @@ sub field return $self->{field}; } + +sub _switches +{ + my $self = shift; + + if (@_) + { + $self->{_switches} = shift; + } + + return $self->{_switches}; +} + sub _contents { my $self = shift; @@ -304,6 +245,11 @@ sub _init $self->_stderr_val(exists($args->{stderr}) ? $args->{stderr} : 1); + if (exists($args->{switches})) + { + $self->_switches($args->{switches}); + } + $self->_run(); return; @@ -323,7 +269,7 @@ sub _quote 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"} @@ -343,7 +289,7 @@ sub _run { ::runperl( switches => [ - '-d', + ($self->_switches ? (@{$self->_switches()}) : ('-d')), ($self->_include_t ? ('-I', '../lib/perl5db/t') : ()) ], (defined($self->_stderr_val()) @@ -360,6 +306,11 @@ sub _run { return; } +sub get_output +{ + return shift->_output(); +} + sub output_like { my ($self, $re, $msg) = @_; @@ -415,7 +366,7 @@ package main; ); } -sub calc_new_var_wrapper +sub _calc_generic_wrapper { my $args = shift; @@ -424,6 +375,18 @@ sub calc_new_var_wrapper 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', @@ -432,14 +395,26 @@ sub calc_new_var_wrapper 'x "new_var = <$new_var>\\n"', 'q', ], - prog => delete($args->{prog}), %$args, } ); } +sub _calc_threads_wrapper { - calc_new_var_wrapper({ prog => '../lib/perl5db/t/eval-line-bug'}) + 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 = /, "no strict 'vars' in evaluated lines.", @@ -447,7 +422,7 @@ sub calc_new_var_wrapper } { - calc_new_var_wrapper( + _calc_new_var_wrapper( { prog => '../lib/perl5db/t/lvalue-bug', stderr => undef(), @@ -458,6 +433,110 @@ sub calc_new_var_wrapper ); } +{ + _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( @@ -729,6 +808,74 @@ sub calc_new_var_wrapper ); } +# Tests for x with @_ +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'b 10', + 'c', + 'x @_', + 'q', + ], + prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc', + } + ); + + $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'; @@ -892,6 +1039,20 @@ sub calc_new_var_wrapper ); } +# 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( @@ -1076,6 +1237,7 @@ sub calc_new_var_wrapper $wrapper->contents_like( qr/ $line_out + auto\(-\d+\)\s+DB<\d+>\s+\.\n $line_out /msx, 'Test the "." command', @@ -1331,7 +1493,7 @@ sub calc_new_var_wrapper ); } -# Test the a command. +# Test the 'a' command. { my $wrapper = DebugWrap->new( { @@ -1345,15 +1507,38 @@ sub calc_new_var_wrapper } ); + my $nl = $^O eq 'VMS' ? "" : "\\\n"; $wrapper->output_like(qr# - \nVar=1\n - \nVar=2\n - \nVar=3\n + \nVar=1$nl + \nVar=2$nl + \nVar=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( @@ -1834,6 +2019,888 @@ sub calc_new_var_wrapper ); } +# 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); }