X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/5d5d9ea3ae69424edca11bf2237f2504fa313408..517cdf98ec4bbc70e52605afa85c59d776d8d26a:/lib/perl5db.t diff --git a/lib/perl5db.t b/lib/perl5db.t index ba5d585..a5d4df4 100644 --- a/lib/perl5db.t +++ b/lib/perl5db.t @@ -28,7 +28,7 @@ BEGIN { } } -plan(20); +plan(107); my $rc_filename = '.perldb'; @@ -65,397 +65,2534 @@ sub _out_contents return _slurp($out_fn); } -{ - my $target = '../lib/perl5db/t/eval-line-bug'; +# Test for Proxy constants +{ 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', + +&parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out"); + +sub afterinit { + push(@DB::typeahead, + 'm main->s1', + 'q', + ); +} + EOF ); - { - local $ENV{PERLDB_OPTS} = "ReadLine=0"; - runperl(switches => [ '-d' ], progfile => $target); - } + my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants'); + is($output, "", "proxy constant subroutines"); } -like(_out_contents(), qr/sub factorial/, - 'The ${main::_ [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110'); + like($output, "All tests successful.", "[perl #66110]"); +} { - my $target = '../lib/perl5db/t/eval-line-bug'; + rc(<<'EOF'); +&parse_options("NonStop=0 TTY=db.out LineInfo=db.out"); - 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 +sub afterinit { + push (@DB::typeahead, + 't 2', + 'c', + 'q', ); - { - local $ENV{PERLDB_OPTS} = "ReadLine=0"; - runperl(switches => [ '-d' ], progfile => $target); - } +} +EOF } -like(_out_contents(), qr/new_var = /, - "no strict 'vars' in evaluated lines.", -); +package DebugWrap; -{ - 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'); -} +sub new { + my $class = shift; -{ - 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'); + my $self = bless {}, $class; + + $self->_init(@_); + + return $self; } -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'); +sub _cmds { + my $self = shift; + + if (@_) { + $self->{_cmds} = shift; } + return $self->{_cmds}; } -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"); + +sub _prog { + my $self = shift; + + if (@_) { + $self->{_prog} = shift; } + + return $self->{_prog}; } +sub _output { + my $self = shift; -# Test [perl #61222] + if (@_) { + $self->{_output} = shift; + } + + return $self->{_output}; +} + +sub _include_t { - rc( - <<'EOF', - &parse_options("NonStop=0 TTY=db.out LineInfo=db.out"); + my $self = shift; - sub afterinit { - push(@DB::typeahead, - 'm Pie', - 'q', - ); - } -EOF - ); + if (@_) + { + $self->{_include_t} = shift; + } - my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-61222'); - unlike(_out_contents(), qr/INCORRECT/, "[perl #61222]"); + return $self->{_include_t}; } +sub _stderr_val +{ + my $self = shift; + + if (@_) + { + $self->{_stderr_val} = shift; + } + return $self->{_stderr_val}; +} -# Test for Proxy constants +sub field { - rc( - <<'EOF', + my $self = shift; -&parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out"); + if (@_) + { + $self->{field} = shift; + } -sub afterinit { - push(@DB::typeahead, - 'm main->s1', - 'q', - ); + return $self->{field}; } -EOF - ); +sub _switches +{ + my $self = shift; - my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants'); - is($output, "", "proxy constant subroutines"); + if (@_) + { + $self->{_switches} = shift; + } + + return $self->{_switches}; } -# Testing that we can set a line in the middle of the file. +sub _contents { - rc(<<'EOF'); -&parse_options("NonStop=0 TTY=db.out LineInfo=db.out"); + my $self = shift; -sub afterinit { - push (@DB::typeahead, - 'b ../lib/perl5db/t/MyModule.pm:12', - 'c', - q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/, - 'c', - 'q', - ); + if (@_) + { + $self->{_contents} = shift; + } + return $self->{_contents}; } -EOF - my $output = runperl(switches => [ '-d', '-I', '../lib/perl5db/t', ], stderr => 1, progfile => '../lib/perl5db/t/filename-line-breakpoint'); +sub _init +{ + my ($self, $args) = @_; - like($output, qr/ - ^Var=Bar$ - .* - ^In\ MyModule\.$ - .* - ^In\ Main\ File\.$ - .* - /msx, - "Can set breakpoint in a line in the middle of the file."); -} + my $cmds = $args->{cmds}; + if (ref($cmds) ne 'ARRAY') { + die "cmds must be an array of commands."; + } -# [perl #66110] Call a subroutine inside a regex -{ - 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]"); -} + $self->_cmds($cmds); -# [perl 104168] level option for tracing -{ - rc(<<'EOF'); -&parse_options("NonStop=0 TTY=db.out LineInfo=db.out"); + my $prog = $args->{prog}; -sub afterinit { - push (@DB::typeahead, - 't 2', - 'c', - 'q', - ); + if (ref($prog) ne '' or !defined($prog)) { + die "prog should be a path to a program file."; + } -} -EOF + $self->_prog($prog); + + $self->_include_t($args->{include_t} ? 1 : 0); - my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-104168'); - my $contents; + $self->_stderr_val(exists($args->{stderr}) ? $args->{stderr} : 1); + + if (exists($args->{switches})) { - local $/; - open I, "<", 'db.out' or die $!; - $contents = ; - close(I); + $self->_switches($args->{switches}); } - like($contents, qr/level 2/, "[perl #104168]"); - unlike($contents, qr/baz/, "[perl #104168]"); -} -# taint tests + $self->_run(); -{ - 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"); + return; } -# Testing that we can set a breakpoint +sub _quote { - rc(<<'EOF'); -&parse_options("NonStop=0 TTY=db.out LineInfo=db.out"); + my ($self, $str) = @_; -sub afterinit { - push (@DB::typeahead, - 'b 6', - 'c', - q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/, - 'c', - 'q', - ); + $str =~ s/(["\@\$\\])/\\$1/g; + $str =~ s/\n/\\n/g; + $str =~ s/\r/\\r/g; + return qq{"$str"}; } -EOF - my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/breakpoint-bug'); +sub _run { + my $self = shift; - like($output, qr/ - X=\{Two\} - /msx, - "Can set breakpoint in a line."); -} + my $rc = qq{&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");\n}; + $rc .= join('', + map { "$_\n"} + (q#sub afterinit {#, + q#push (@DB::typeahead,#, + (map { $self->_quote($_) . "," } @{$self->_cmds()}), + q#);#, + q#}#, + ) + ); -# Testing that we can disable a breakpoint at a numeric line. -{ - rc(<<'EOF'); -&parse_options("NonStop=0 TTY=db.out LineInfo=db.out"); + # I guess two objects like that cannot be used at the same time. + # Oh well. + ::rc($rc); + + my $output = + ::runperl( + switches => + [ + ($self->_switches ? (@{$self->_switches()}) : ('-d')), + ($self->_include_t ? ('-I', '../lib/perl5db/t') : ()) + ], + (defined($self->_stderr_val()) + ? (stderr => $self->_stderr_val()) + : () + ), + progfile => $self->_prog() + ); -sub afterinit { - push (@DB::typeahead, - 'b 7', - 'b 11', - 'disable 7', - 'c', - q/print "X={$x}\n";/, - 'c', - 'q', - ); + $self->_output($output); -} -EOF + $self->_contents(::_out_contents()); - my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-1'); + - like($output, qr/ - X=\{SecondVal\} - /msx, - "Can set breakpoint in a line."); + return; } -# Testing that we can re-enable a breakpoint at a numeric line. +sub get_output { - rc(<<'EOF'); -&parse_options("NonStop=0 TTY=db.out LineInfo=db.out"); + return shift->_output(); +} -sub afterinit { - push (@DB::typeahead, - 'b 8', - 'b 24', - 'disable 24', - 'c', - 'enable 24', - 'c', - q/print "X={$x}\n";/, - 'c', - 'q', - ); +sub output_like { + my ($self, $re, $msg) = @_; + local $::Level = $::Level + 1; + ::like($self->_output(), $re, $msg); } -EOF - my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-2'); - like($output, qr/ - X=\{SecondValOneHundred\} - /msx, - "Can set breakpoint in a line."); -} -# clean up. +sub output_unlike { + my ($self, $re, $msg) = @_; -# Disable and enable for breakpoints on outer files. -{ - rc(<<'EOF'); -&parse_options("NonStop=0 TTY=db.out LineInfo=db.out"); + local $::Level = $::Level + 1; + ::unlike($self->_output(), $re, $msg); +} -sub afterinit { - push (@DB::typeahead, - 'b 10', - 'b ../lib/perl5db/t/EnableModule.pm:14', - 'disable ../lib/perl5db/t/EnableModule.pm:14', - 'c', - 'enable ../lib/perl5db/t/EnableModule.pm:14', - 'c', - q/print "X={$x}\n";/, - 'c', - 'q', - ); +sub contents_like { + my ($self, $re, $msg) = @_; + local $::Level = $::Level + 1; + ::like($self->_contents(), $re, $msg); } -EOF - my $output = runperl(switches => [ '-d', '-I', '../lib/perl5db/t', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-3'); + - like($output, qr/ - X=\{SecondValTwoHundred\} - /msx, - "Can set breakpoint in a line."); +sub contents_unlike { + my ($self, $re, $msg) = @_; + + local $::Level = $::Level + 1; + ::unlike($self->_contents(), $re, $msg); } -# Testing that the prompt with the information appears. -{ - rc(<<'EOF'); -&parse_options("NonStop=0 TTY=db.out LineInfo=db.out"); +package main; -sub afterinit { - push (@DB::typeahead, - 'q', +{ + 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::_ [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-1'); +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, + } + ); +} - like(_out_contents(), qr/ - ^main::\([^\)]*\bdisable-breakpoints-1:2\):\n - 2:\s+my\ \$x\ =\ "One";\n - /msx, - "Prompt should display the first line of code."); +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, + } + ); } -# Testing that R (restart) and "B *" work. +sub _calc_threads_wrapper { - rc(<<'EOF'); -&parse_options("NonStop=0 TTY=db.out LineInfo=db.out"); + my $args = shift; -sub afterinit { - push (@DB::typeahead, - 'b 13', - 'c', - 'B *', - 'b 9', - 'R', - 'c', - q/print "X={$x};dummy={$dummy}\n";/, - 'q', + return _calc_new_var_wrapper( + { + switches => [ '-dt', ], + stderr => 1, + %$args + } ); - } -EOF - my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-1'); - like($output, qr/ - X=\{FirstVal\};dummy=\{1\} - /msx, - "Restart and delete all breakpoints work properly."); +{ + _calc_new_var_wrapper({ prog => '../lib/perl5db/t/eval-line-bug'}) + ->contents_like( + qr/new_var = /, + "no strict 'vars' in evaluated lines.", + ); } { - rc(<<'EOF'); -&parse_options("NonStop=0 TTY=db.out LineInfo=db.out"); + _calc_new_var_wrapper( + { + prog => '../lib/perl5db/t/lvalue-bug', + stderr => undef(), + }, + )->output_like( + qr/foo is defined/, + 'lvalue subs work in the debugger', + ); +} -sub afterinit { - push (@DB::typeahead, - 'c 15', - q/print "X={$x}\n";/, - 'c', - 'q', +{ + _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( + { + cmds => + [ + 'b ../lib/perl5db/t/MyModule.pm:12', + 'c', + q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/, + 'c', + 'q', + ], + include_t => 1, + prog => '../lib/perl5db/t/filename-line-breakpoint' + } + ); + + $wrapper->output_like(qr/ + ^Var=Bar$ + .* + ^In\ MyModule\.$ + .* + ^In\ Main\ File\.$ + .* + /msx, + "Can set breakpoint in a line in the middle of the file."); +} + +# Testing that we can set a breakpoint +{ + my $wrapper = DebugWrap->new( + { + prog => '../lib/perl5db/t/breakpoint-bug', + cmds => + [ + 'b 6', + 'c', + q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/, + 'c', + 'q', + ], + }, + ); + + $wrapper->output_like( + qr/X=\{Two\}/msx, + "Can set breakpoint in a line." + ); +} + +# Testing that we can disable a breakpoint at a numeric line. +{ + my $wrapper = DebugWrap->new( + { + prog => '../lib/perl5db/t/disable-breakpoints-1', + cmds => + [ + 'b 7', + 'b 11', + 'disable 7', + 'c', + q/print "X={$x}\n";/, + 'c', + 'q', + ], + } + ); + + $wrapper->output_like(qr/X=\{SecondVal\}/ms, + "Can set breakpoint in a line."); +} + +# Testing that we can re-enable a breakpoint at a numeric line. +{ + my $wrapper = DebugWrap->new( + { + prog => '../lib/perl5db/t/disable-breakpoints-2', + cmds => + [ + 'b 8', + 'b 24', + 'disable 24', + 'c', + 'enable 24', + 'c', + q/print "X={$x}\n";/, + 'c', + 'q', + ], + }, + ); + + $wrapper->output_like( + qr/ + X=\{SecondValOneHundred\} + /msx, + "Can set breakpoint in a line." + ); +} +# clean up. + +# Disable and enable for breakpoints on outer files. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'b 10', + 'b ../lib/perl5db/t/EnableModule.pm:14', + 'disable ../lib/perl5db/t/EnableModule.pm:14', + 'c', + 'enable ../lib/perl5db/t/EnableModule.pm:14', + 'c', + q/print "X={$x}\n";/, + 'c', + 'q', + ], + prog => '../lib/perl5db/t/disable-breakpoints-3', + include_t => 1, + } + ); + + $wrapper->output_like(qr/ + X=\{SecondValTwoHundred\} + /msx, + "Can set breakpoint in a line."); +} + +# Testing that the prompt with the information appears. +{ + my $wrapper = DebugWrap->new( + { + cmds => ['q'], + prog => '../lib/perl5db/t/disable-breakpoints-1', + } + ); + + $wrapper->contents_like(qr/ + ^main::\([^\)]*\bdisable-breakpoints-1:2\):\n + 2:\s+my\ \$x\ =\ "One";\n + /msx, + "Prompt should display the first line of code."); +} + +# Testing that R (restart) and "B *" work. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'b 13', + 'c', + 'B *', + 'b 9', + 'R', + 'c', + q/print "X={$x};dummy={$dummy}\n";/, + 'q', + ], + prog => '../lib/perl5db/t/disable-breakpoints-1', + } + ); + + $wrapper->output_like(qr/ + X=\{FirstVal\};dummy=\{1\} + /msx, + "Restart and delete all breakpoints work properly."); } -EOF - my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-1'); + - like($output, qr/ +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'c 15', + q/print "X={$x}\n";/, + 'c', + 'q', + ], + prog => '../lib/perl5db/t/disable-breakpoints-1', + } + ); + + $wrapper->output_like(qr/ X=\{ThirdVal\} /msx, "'c line_num' is working properly."); } +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'n', + 'n', + 'b . $exp > 200', + 'c', + q/print "Exp={$exp}\n";/, + 'q', + ], + prog => '../lib/perl5db/t/break-on-dot', + } + ); + + $wrapper->output_like(qr/ + Exp=\{256\} + /msx, + "'b .' is working correctly."); +} + +# Testing that the prompt with the information appears inside a subroutine call. +# See https://rt.perl.org/rt3/Ticket/Display.html?id=104820 +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'c back', + 'q', + ], + prog => '../lib/perl5db/t/with-subroutine', + } + ); + + $wrapper->contents_like( + qr/ + ^main::back\([^\)\n]*\bwith-subroutine:15\):[\ \t]*\n + ^15:\s*print\ "hello\ back\\n"; + /msx, + "Prompt should display the line of code inside a subroutine."); +} + +# Checking that the p command works. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'p "<<<" . (4*6) . ">>>"', + 'q', + ], + prog => '../lib/perl5db/t/with-subroutine', + } + ); + + $wrapper->contents_like( + qr/<<<24>>>/, + "p command works."); +} + +# Tests for x. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + q/x {500 => 600}/, + 'q', + ], + prog => '../lib/perl5db/t/with-subroutine', + } + ); + + $wrapper->contents_like( + # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/, + qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/ms, + "x command test." + ); +} + +# 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, + "T command test." + ); +} + +# Test for s. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'b 9', + 'c', + 's', + q/print "X={$x};dummy={$dummy}\n";/, + 'q', + ], + prog => '../lib/perl5db/t/disable-breakpoints-1' + } + ); + + $wrapper->output_like(qr/ + X=\{SecondVal\};dummy=\{1\} + /msx, + 'test for s - single step', + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'n', + 'n', + 'b . $exp > 200', + 'c', + q/print "Exp={$exp}\n";/, + 'q', + ], + prog => '../lib/perl5db/t/break-on-dot' + } + ); + + $wrapper->output_like(qr/ + Exp=\{256\} + /msx, + "'b .' is working correctly."); +} + +{ + my $prog_fn = '../lib/perl5db/t/rt-104168'; + my $wrapper = DebugWrap->new( + { + cmds => + [ + 's', + 'q', + ], + prog => $prog_fn, + } + ); + + $wrapper->contents_like( + qr/ + ^main::foo\([^\)\n]*\brt-104168:9\):[\ \t]*\n + ^9:\s*bar\(\); + /msx, + 'Test for the s command.', + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 's uncalled_subroutine()', + 'c', + 'q', + ], + + prog => '../lib/perl5db/t/uncalled-subroutine'} + ); + + $wrapper->output_like( + qr/<1,2,3,4,5>\n/, + 'uncalled_subroutine was called after s EXPR()', + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'n uncalled_subroutine()', + 'c', + 'q', + ], + prog => '../lib/perl5db/t/uncalled-subroutine', + } + ); + + $wrapper->output_like( + qr/<1,2,3,4,5>\n/, + 'uncalled_subroutine was called after n EXPR()', + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'b fact', + 'c', + 'c', + 'c', + 'n', + 'print "<$n>"', + 'q', + ], + prog => '../lib/perl5db/t/fact', + } + ); + + $wrapper->output_like( + qr/<3>/, + 'b subroutine works fine', + ); +} + +# Test for 'M' (module list). +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'M', + 'q', + ], + prog => '../lib/perl5db/t/load-modules' + } + ); + + $wrapper->contents_like( + qr[Scalar/Util\.pm], + 'M (module list) works fine', + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'b 14', + 'c', + '$flag = 1;', + 'r', + 'print "Var=$var\n";', + 'q', + ], + prog => '../lib/perl5db/t/test-r-statement', + } + ); + + $wrapper->output_like( + qr/ + ^Foo$ + .*? + ^Bar$ + .*? + ^Var=Test$ + /msx, + 'r statement is working properly.', + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'l', + 'q', + ], + 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, + 'l statement is working properly (test No. 1).', + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'l', + q/# After l 1/, + 'l', + q/# After l 2/, + '-', + q/# After -/, + 'q', + ], + prog => '../lib/perl5db/t/test-l-statement-1', + } + ); + + my $first_l_out = 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 + 6\s*\n + 7:\s+\$x\ =\ 3;\n + 8:\s+print\ "3\\n";\n + 9\s*\n + 10:\s+\$x\ =\ 4;\n + /msx; + + my $second_l_out = qr/ + 11:\s+print\ "4\\n";\n + 12\s*\n + 13:\s+\$x\ =\ 5;\n + 14:\s+print\ "5\\n";\n + 15\s*\n + 16:\s+\$x\ =\ 6;\n + 17:\s+print\ "6\\n";\n + 18\s*\n + 19:\s+\$x\ =\ 7;\n + 20:\s+print\ "7\\n";\n + /msx; + $wrapper->contents_like( + qr/ + ^$first_l_out + [^\n]*?DB<\d+>\ \#\ After\ l\ 1\n + [\ \t]*\n + [^\n]*?DB<\d+>\ l\s*\n + $second_l_out + [^\n]*?DB<\d+>\ \#\ After\ l\ 2\n + [\ \t]*\n + [^\n]*?DB<\d+>\ -\s*\n + $first_l_out + [^\n]*?DB<\d+>\ \#\ After\ -\n + /msx, + 'l followed by l and then followed by -', + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'l fact', + 'q', + ], + prog => '../lib/perl5db/t/test-l-statement-2', + } + ); + + my $first_l_out = qr/ + 6\s+sub\ fact\ \{\n + 7:\s+my\ \$n\ =\ shift;\n + 8:\s+if\ \(\$n\ >\ 1\)\ \{\n + 9:\s+return\ \$n\ \*\ fact\(\$n\ -\ 1\); + /msx; + + $wrapper->contents_like( + qr/ + DB<1>\s+l\ fact\n + $first_l_out + /msx, + 'l subroutine_name', + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'b fact', + 'c', + # Repeat several times to avoid @typeahead problems. + '.', + '.', + '.', + '.', + 'q', + ], + prog => '../lib/perl5db/t/test-l-statement-2', + } + ); + + my $line_out = qr / + ^main::fact\([^\n]*?:7\):\n + ^7:\s+my\ \$n\ =\ shift;\n + /msx; + + $wrapper->contents_like( + qr/ + $line_out + $line_out + /msx, + 'Test the "." command', + ); +} + +# Testing that the f command works. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'f ../lib/perl5db/t/MyModule.pm', + 'b 12', + 'c', + q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/, + 'c', + 'q', + ], + include_t => 1, + prog => '../lib/perl5db/t/filename-line-breakpoint' + } + ); + + $wrapper->output_like(qr/ + ^Var=Bar$ + .* + ^In\ MyModule\.$ + .* + ^In\ Main\ File\.$ + .* + /msx, + "f command is working.", + ); +} + +# We broke the /pattern/ command because apparently the CORE::eval-s inside +# lib/perl5db.pl cannot handle lexical variable properly. So we now fix this +# bug. +# +# TODO : +# +# 1. Go over the rest of the "eval"s in lib/perl5db.t and see if they cause +# problems. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + '/for/', + 'q', + ], + prog => '../lib/perl5db/t/eval-line-bug', + } + ); + + $wrapper->contents_like( + qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx, + "/pat/ command is working and found a match.", + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'b 22', + 'c', + '?for?', + 'q', + ], + prog => '../lib/perl5db/t/eval-line-bug', + } + ); + + $wrapper->contents_like( + qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx, + "?pat? command is working and found a match.", + ); +} + +# Test the L command. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'b 6', + 'b 13 ($q == 5)', + 'L', + 'q', + ], + prog => '../lib/perl5db/t/eval-line-bug', + } + ); + + $wrapper->contents_like( + qr# + ^\S*?eval-line-bug:\n + \s*6:\s*my\ \$i\ =\ 5;\n + \s*break\ if\ \(1\)\n + \s*13:\s*\$i\ \+=\ \$q;\n + \s*break\ if\ \(\(\$q\ ==\ 5\)\)\n + #msx, + "L command is listing breakpoints", + ); +} + +# Test the L command for watch expressions. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'w (5+6)', + 'L', + 'q', + ], + prog => '../lib/perl5db/t/eval-line-bug', + } + ); + + $wrapper->contents_like( + qr# + ^Watch-expressions:\n + \s*\(5\+6\)\n + #msx, + "L command is listing watch expressions", + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'w (5+6)', + 'w (11*23)', + 'W (5+6)', + 'L', + 'q', + ], + prog => '../lib/perl5db/t/eval-line-bug', + } + ); + + $wrapper->contents_like( + qr# + ^Watch-expressions:\n + \s*\(11\*23\)\n + ^auto\( + #msx, + "L command is not listing deleted watch expressions", + ); +} + +# Test the L command. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'b 6', + 'a 13 print $i', + 'L', + 'q', + ], + prog => '../lib/perl5db/t/eval-line-bug', + } + ); + + $wrapper->contents_like( + qr# + ^\S*?eval-line-bug:\n + \s*6:\s*my\ \$i\ =\ 5;\n + \s*break\ if\ \(1\)\n + \s*13:\s*\$i\ \+=\ \$q;\n + \s*action:\s+print\ \$i\n + #msx, + "L command is listing actions and breakpoints", + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'S', + 'q', + ], + prog => '../lib/perl5db/t/rt-104168', + } + ); + + $wrapper->contents_like( + qr# + ^main::bar\n + main::baz\n + main::foo\n + #msx, + "S command - 1", + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'S ^main::ba', + 'q', + ], + prog => '../lib/perl5db/t/rt-104168', + } + ); + + $wrapper->contents_like( + qr# + ^main::bar\n + main::baz\n + auto\( + #msx, + "S command with regex", + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'S !^main::ba', + 'q', + ], + prog => '../lib/perl5db/t/rt-104168', + } + ); + + $wrapper->contents_unlike( + qr# + ^main::ba + #msx, + "S command with negative regex", + ); + + $wrapper->contents_like( + qr# + ^main::foo\n + #msx, + "S command with negative regex - what it still matches", + ); +} + +# Test the 'a' command. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'a 13 print "\nVar=$q\n"', + 'c', + 'q', + ], + prog => '../lib/perl5db/t/eval-line-bug', + } + ); + + $wrapper->output_like(qr# + \nVar=1\n + \nVar=2\n + \nVar=3\n + #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( + { + cmds => + [ + 'a 13 print "\nVar=$q\n"', + 'A 13', + 'c', + 'q', + ], + prog => '../lib/perl5db/t/eval-line-bug', + } + ); + + $wrapper->output_like( + qr#\A\z#msx, # The empty string. + "A command (for removing actions) is working", + ); +} + +# Test the 'A *' command +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'a 6 print "\nFail!\n"', + 'a 13 print "\nVar=$q\n"', + 'A *', + 'c', + 'q', + ], + prog => '../lib/perl5db/t/eval-line-bug', + } + ); + + $wrapper->output_like( + qr#\A\z#msx, # The empty string. + "'A *' command (for removing all actions) is working", + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'n', + 'w $foo', + 'c', + 'print "\nIDX=<$idx>\n"', + 'q', + ], + prog => '../lib/perl5db/t/test-w-statement-1', + } + ); + + + $wrapper->contents_like(qr# + \$foo\ changed:\n + \s+old\ value:\s+'1'\n + \s+new\ value:\s+'2'\n + #msx, + 'w command - watchpoint changed', + ); + $wrapper->output_like(qr# + \nIDX=<20>\n + #msx, + "w command - correct output from IDX", + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'n', + 'w $foo', + 'W $foo', + 'c', + 'print "\nIDX=<$idx>\n"', + 'q', + ], + prog => '../lib/perl5db/t/test-w-statement-1', + } + ); + + $wrapper->contents_unlike(qr# + \$foo\ changed: + #msx, + 'W command - watchpoint was deleted', + ); + + $wrapper->output_like(qr# + \nIDX=<>\n + #msx, + "W command - stopped at end.", + ); +} + +# Test the W * command. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'n', + 'w $foo', + 'w ($foo*$foo)', + 'W *', + 'c', + 'print "\nIDX=<$idx>\n"', + 'q', + ], + prog => '../lib/perl5db/t/test-w-statement-1', + } + ); + + $wrapper->contents_unlike(qr# + \$foo\ changed: + #msx, + '"W *" command - watchpoint was deleted', + ); + + $wrapper->output_like(qr# + \nIDX=<>\n + #msx, + '"W *" command - stopped at end.', + ); +} + +# Test the 'o' command (without further arguments). +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'o', + 'q', + ], + prog => '../lib/perl5db/t/test-w-statement-1', + } + ); + + $wrapper->contents_like(qr# + ^\s*warnLevel\ =\ '1'\n + #msx, + q#"o" command (without arguments) displays warnLevel#, + ); + + $wrapper->contents_like(qr# + ^\s*signalLevel\ =\ '1'\n + #msx, + q#"o" command (without arguments) displays signalLevel#, + ); + + $wrapper->contents_like(qr# + ^\s*dieLevel\ =\ '1'\n + #msx, + q#"o" command (without arguments) displays dieLevel#, + ); + + $wrapper->contents_like(qr# + ^\s*hashDepth\ =\ 'N/A'\n + #msx, + q#"o" command (without arguments) displays hashDepth#, + ); +} + +# Test the 'o' query command. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'o hashDepth? signalLevel?', + 'q', + ], + prog => '../lib/perl5db/t/test-w-statement-1', + } + ); + + $wrapper->contents_unlike(qr#warnLevel#, + q#"o" query command does not display warnLevel#, + ); + + $wrapper->contents_like(qr# + ^\s*signalLevel\ =\ '1'\n + #msx, + q#"o" query command displays signalLevel#, + ); + + $wrapper->contents_unlike(qr#dieLevel#, + q#"o" query command does not display dieLevel#, + ); + + $wrapper->contents_like(qr# + ^\s*hashDepth\ =\ 'N/A'\n + #msx, + q#"o" query command displays hashDepth#, + ); +} + +# Test the 'o' set command. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'o signalLevel=0', + 'o', + 'q', + ], + prog => '../lib/perl5db/t/test-w-statement-1', + } + ); + + $wrapper->contents_like(qr/ + ^\s*(signalLevel\ =\ '0'\n) + .*? + ^\s*\1 + /msx, + q#o set command works#, + ); + + $wrapper->contents_like(qr# + ^\s*hashDepth\ =\ 'N/A'\n + #msx, + q#o set command - hashDepth#, + ); +} + +# Test the '<' and "< ?" commands. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + q/< print "\nX=<$x>\n"/, + q/b 7/, + q/< ?/, + 'c', + 'q', + ], + prog => '../lib/perl5db/t/disable-breakpoints-1', + } + ); + + $wrapper->contents_like(qr/ + ^pre-perl\ commands:\n + \s*<\ --\ print\ "\\nX=<\$x>\\n"\n + /msx, + q#Test < and < ? commands - contents.#, + ); + + $wrapper->output_like(qr# + ^X=\n + #msx, + q#Test < and < ? commands - output.#, + ); +} + +# Test the '< *' command. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + q/< print "\nX=<$x>\n"/, + q/b 7/, + q/< */, + 'c', + 'q', + ], + prog => '../lib/perl5db/t/disable-breakpoints-1', + } + ); + + $wrapper->output_unlike(qr/FirstVal/, + q#Test the '< *' command.#, + ); +} + +# Test the '>' and "> ?" commands. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + q/$::foo = 500;/, + q/> print "\nFOO=<$::foo>\n"/, + q/b 7/, + q/> ?/, + 'c', + 'q', + ], + prog => '../lib/perl5db/t/disable-breakpoints-1', + } + ); + + $wrapper->contents_like(qr/ + ^post-perl\ commands:\n + \s*>\ --\ print\ "\\nFOO=<\$::foo>\\n"\n + /msx, + q#Test > and > ? commands - contents.#, + ); + + $wrapper->output_like(qr# + ^FOO=<500>\n + #msx, + q#Test > and > ? commands - output.#, + ); +} + +# Test the '> *' command. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + q/> print "\nFOO=<$::foo>\n"/, + q/b 7/, + q/> */, + 'c', + 'q', + ], + prog => '../lib/perl5db/t/disable-breakpoints-1', + } + ); + + $wrapper->output_unlike(qr/FOO=/, + q#Test the '> *' command.#, + ); +} + +# Test the < and > commands together +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + q/$::lorem = 0;/, + q/< $::lorem += 10;/, + q/> print "\nLOREM=<$::lorem>\n"/, + q/b 7/, + q/b 5/, + 'c', + 'c', + 'q', + ], + prog => '../lib/perl5db/t/disable-breakpoints-1', + } + ); + + $wrapper->output_like(qr# + ^LOREM=<10>\n + #msx, + q#Test < and > commands. #, + ); +} + +# Test the { ? and { [command] commands. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + '{ ?', + '{ l', + '{ ?', + q/b 5/, + q/c/, + q/q/, + ], + prog => '../lib/perl5db/t/disable-breakpoints-1', + } + ); + + $wrapper->contents_like(qr# + ^No\ pre-debugger\ actions\.\n + .*? + ^pre-debugger\ commands:\n + \s+\{\ --\ l\n + .*? + ^5==>b\s+\$x\ =\ "FirstVal";\n + 6\s*\n + 7:\s+\$dummy\+\+;\n + 8\s*\n + 9:\s+\$x\ =\ "SecondVal";\n + + #msx, + 'Test the pre-prompt debugger commands', + ); +} + +# Test the { * command. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + '{ q', + '{ *', + q/b 5/, + q/c/, + q/print (("One" x 5), "\n");/, + q/q/, + ], + prog => '../lib/perl5db/t/disable-breakpoints-1', + } + ); + + $wrapper->contents_like(qr# + ^All\ \{\ actions\ cleared\.\n + #msx, + 'Test the { * command', + ); + + $wrapper->output_like(qr/OneOneOneOneOne/, + '{ * test - output is OK.', + ); +} + +# 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 + .*? + ^\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 + .*? + ^\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 + 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 + main::myfunc\([^:]+:25\):\n + 25:\s+bar\(\);\n + /msx, + 'Test the t 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", + ); +} + END { 1 while unlink ($rc_filename, $out_fn); }