X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2bceee64ee91178a2f5b5d15f7b36bff19ff06fa..f240c685c914970dc8ffec926f02d6048831bc09:/lib/perl5db.t diff --git a/lib/perl5db.t b/lib/perl5db.t index c3a072c..98a3686 100644 --- a/lib/perl5db.t +++ b/lib/perl5db.t @@ -26,9 +26,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(89); +plan(121); my $rc_filename = '.perldb'; @@ -71,7 +72,7 @@ sub _out_contents 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, @@ -91,22 +92,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 #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 +# [ 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' ); +} +# [ perl #41461] Frame=2 noTTY +{ + 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; @@ -259,7 +267,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"} @@ -798,6 +806,74 @@ sub _calc_trace_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'; @@ -961,6 +1037,20 @@ sub _calc_trace_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( @@ -1145,6 +1235,7 @@ sub _calc_trace_wrapper $wrapper->contents_like( qr/ $line_out + auto\(-\d+\)\s+DB<\d+>\s+\.\n $line_out /msx, 'Test the "." command', @@ -1400,7 +1491,7 @@ sub _calc_trace_wrapper ); } -# Test the a command. +# Test the 'a' command. { my $wrapper = DebugWrap->new( { @@ -1414,15 +1505,38 @@ sub _calc_trace_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( @@ -2120,6 +2234,571 @@ sub _calc_trace_wrapper } +# 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.', + ); +} + END { 1 while unlink ($rc_filename, $out_fn); }