13 delete $ENV{PERLDB_OPTS};
16 if (! -c "/dev/null") {
17 print "1..0 # Skip: no /dev/null\n";
21 my $dev_tty = '/dev/tty';
22 $dev_tty = 'TT:' if ($^O eq 'VMS');
24 print "1..0 # Skip: no $dev_tty\n";
28 print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n";
31 $ENV{PERL_RL} = 'Perl'; # Suppress system Term::ReadLine::Gnu
36 my $rc_filename = '.perldb';
39 open my $rc_fh, '>', $rc_filename
44 # overly permissive perms gives "Must not source insecure rcfile"
45 # and hangs at the DB(1> prompt
46 chmod 0644, $rc_filename;
53 open my $in, '<', $filename
54 or die "Cannot open '$filename' for slurping - $!";
64 my $out_fn = 'db.out';
68 return _slurp($out_fn);
72 # Test for Proxy constants
77 &parse_options("NonStop=0 ReadLine=0 TTY=db.out");
89 my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
90 is($output, "", "proxy constant subroutines");
93 # [perl #66110] Call a subroutine inside a regex
95 local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
96 my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
97 like($output, qr/\bAll tests successful\.$/, "[perl #66110]");
99 # [ perl #116769] Frame=2
101 local $ENV{PERLDB_OPTS} = "frame=2 nonstop";
102 my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' );
103 is( $?, 0, '[perl #116769] frame=2 does not crash debugger, exit == 0' );
104 is( $output, "success\n" , '[perl #116769] code is run' );
106 # [ perl #116771] autotrace
108 local $ENV{PERLDB_OPTS} = "autotrace nonstop";
109 my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' );
110 is( $?, 0, '[perl #116771] autotrace does not crash debugger, exit == 0' );
111 is( $output, "success\n" , '[perl #116771] code is run' );
113 # [ perl #41461] Frame=2 noTTY
115 local $ENV{PERLDB_OPTS} = "frame=2 noTTY nonstop";
117 my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' );
118 is( $?, 0, '[perl #41461] frame=2 noTTY does not crash debugger, exit == 0' );
119 is( $output, "success\n" , '[perl #41461] code is run' );
127 my $self = bless {}, $class;
138 $self->{_cmds} = shift;
141 return $self->{_cmds};
148 $self->{_prog} = shift;
151 return $self->{_prog};
158 $self->{_output} = shift;
161 return $self->{_output};
170 $self->{_include_t} = shift;
173 return $self->{_include_t};
182 $self->{_stderr_val} = shift;
185 return $self->{_stderr_val};
194 $self->{field} = shift;
197 return $self->{field};
206 $self->{_switches} = shift;
209 return $self->{_switches};
218 $self->{_contents} = shift;
221 return $self->{_contents};
226 my ($self, $args) = @_;
228 my $cmds = $args->{cmds};
230 if (ref($cmds) ne 'ARRAY') {
231 die "cmds must be an array of commands.";
236 my $prog = $args->{prog};
238 if (ref($prog) ne '' or !defined($prog)) {
239 die "prog should be a path to a program file.";
244 $self->_include_t($args->{include_t} ? 1 : 0);
246 $self->_stderr_val(exists($args->{stderr}) ? $args->{stderr} : 1);
248 if (exists($args->{switches}))
250 $self->_switches($args->{switches});
260 my ($self, $str) = @_;
262 $str =~ s/(["\@\$\\])/\\$1/g;
272 my $rc = qq{&parse_options("NonStop=0 TTY=db.out");\n};
277 q#push (@DB::typeahead,#,
278 (map { $self->_quote($_) . "," } @{$self->_cmds()}),
284 # I guess two objects like that cannot be used at the same time.
292 ($self->_switches ? (@{$self->_switches()}) : ('-d')),
293 ($self->_include_t ? ('-I', '../lib/perl5db/t') : ())
295 (defined($self->_stderr_val())
296 ? (stderr => $self->_stderr_val())
299 progfile => $self->_prog()
302 $self->_output($output);
304 $self->_contents(::_out_contents());
311 return shift->_output();
315 my ($self, $re, $msg) = @_;
317 local $::Level = $::Level + 1;
318 ::like($self->_output(), $re, $msg);
322 my ($self, $re, $msg) = @_;
324 local $::Level = $::Level + 1;
325 ::unlike($self->_output(), $re, $msg);
329 my ($self, $re, $msg) = @_;
331 local $::Level = $::Level + 1;
332 ::like($self->_contents(), $re, $msg);
335 sub contents_unlike {
336 my ($self, $re, $msg) = @_;
338 local $::Level = $::Level + 1;
339 ::unlike($self->_contents(), $re, $msg);
345 local $ENV{PERLDB_OPTS} = "ReadLine=0";
346 my $target = '../lib/perl5db/t/eval-line-bug';
347 my $wrapper = DebugWrap->new(
357 "p \@{'main::_<$target'}",
363 $wrapper->contents_like(
365 'The ${main::_<filename} variable in the debugger was not destroyed',
369 sub _calc_generic_wrapper
373 my $extra_opts = delete($args->{extra_opts});
375 local $ENV{PERLDB_OPTS} = "ReadLine=0" . $extra_opts;
376 return DebugWrap->new(
378 cmds => delete($args->{cmds}),
379 prog => delete($args->{prog}),
385 sub _calc_new_var_wrapper
388 return _calc_generic_wrapper(
395 'x "new_var = <$new_var>\\n"',
403 sub _calc_threads_wrapper
407 return _calc_new_var_wrapper(
409 switches => [ '-dt', ],
417 _calc_new_var_wrapper({ prog => '../lib/perl5db/t/eval-line-bug'})
420 "no strict 'vars' in evaluated lines.",
425 _calc_new_var_wrapper(
427 prog => '../lib/perl5db/t/lvalue-bug',
432 'lvalue subs work in the debugger',
437 _calc_new_var_wrapper(
439 prog => '../lib/perl5db/t/symbol-table-bug',
440 extra_opts => "NonStop=1",
444 qr/Undefined symbols 0/,
445 'there are no undefined values in the symbol table',
451 if ( $Config{usethreads} ) {
452 skip('This perl has threads, skipping non-threaded debugger tests');
455 my $error = 'This Perl not built to support threads';
456 _calc_threads_wrapper(
458 prog => '../lib/perl5db/t/eval-line-bug',
462 'Perl debugger correctly complains that it was not built with threads',
469 if ( $Config{usethreads} ) {
470 _calc_threads_wrapper(
472 prog => '../lib/perl5db/t/symbol-table-bug',
475 qr/Undefined symbols 0/,
476 'there are no undefined values in the symbol table when running with thread support',
480 skip("This perl is not threaded, skipping threaded debugger tests");
486 local $ENV{PERLDB_OPTS};
487 my $wrapper = DebugWrap->new(
494 prog => '../lib/perl5db/t/rt-61222',
498 $wrapper->contents_unlike(qr/INCORRECT/, "[perl #61222]");
501 sub _calc_trace_wrapper
505 return _calc_generic_wrapper(
518 # [perl 104168] level option for tracing
520 my $wrapper = _calc_trace_wrapper({ prog => '../lib/perl5db/t/rt-104168' });
521 $wrapper->contents_like(qr/level 2/, "[perl #104168] - level 2 appears");
522 $wrapper->contents_unlike(qr/baz/, "[perl #104168] - no 'baz'");
527 my $wrapper = _calc_trace_wrapper(
529 prog => '../lib/perl5db/t/taint',
530 extra_opts => ' NonStop=1',
531 switches => [ '-d', '-T', ],
535 my $output = $wrapper->get_output();
536 chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
537 is($output, '[$^X][done]', "taint");
540 # Testing that we can set a line in the middle of the file.
542 my $wrapper = DebugWrap->new(
546 'b ../lib/perl5db/t/MyModule.pm:12',
548 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
553 prog => '../lib/perl5db/t/filename-line-breakpoint'
557 $wrapper->output_like(qr/
565 "Can set breakpoint in a line in the middle of the file.");
568 # Testing that we can set a breakpoint
570 my $wrapper = DebugWrap->new(
572 prog => '../lib/perl5db/t/breakpoint-bug',
577 q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/,
584 $wrapper->output_like(
586 "Can set breakpoint in a line."
590 # Testing that we can disable a breakpoint at a numeric line.
592 my $wrapper = DebugWrap->new(
594 prog => '../lib/perl5db/t/disable-breakpoints-1',
601 q/print "X={$x}\n";/,
608 $wrapper->output_like(qr/X=\{SecondVal\}/ms,
609 "Can set breakpoint in a line.");
612 # Testing that we can re-enable a breakpoint at a numeric line.
614 my $wrapper = DebugWrap->new(
616 prog => '../lib/perl5db/t/disable-breakpoints-2',
625 q/print "X={$x}\n";/,
632 $wrapper->output_like(
634 X=\{SecondValOneHundred\}
636 "Can set breakpoint in a line."
641 # Disable and enable for breakpoints on outer files.
643 my $wrapper = DebugWrap->new(
648 'b ../lib/perl5db/t/EnableModule.pm:14',
649 'disable ../lib/perl5db/t/EnableModule.pm:14',
651 'enable ../lib/perl5db/t/EnableModule.pm:14',
653 q/print "X={$x}\n";/,
657 prog => '../lib/perl5db/t/disable-breakpoints-3',
662 $wrapper->output_like(qr/
663 X=\{SecondValTwoHundred\}
665 "Can set breakpoint in a line.");
668 # Testing that the prompt with the information appears.
670 my $wrapper = DebugWrap->new(
673 prog => '../lib/perl5db/t/disable-breakpoints-1',
677 $wrapper->contents_like(qr/
678 ^main::\([^\)]*\bdisable-breakpoints-1:2\):\n
679 2:\s+my\ \$x\ =\ "One";\n
681 "Prompt should display the first line of code.");
684 # Testing that R (restart) and "B *" work.
686 my $wrapper = DebugWrap->new(
696 q/print "X={$x};dummy={$dummy}\n";/,
699 prog => '../lib/perl5db/t/disable-breakpoints-1',
703 $wrapper->output_like(qr/
704 X=\{FirstVal\};dummy=\{1\}
706 "Restart and delete all breakpoints work properly.");
710 my $wrapper = DebugWrap->new(
715 q/print "X={$x}\n";/,
719 prog => '../lib/perl5db/t/disable-breakpoints-1',
723 $wrapper->output_like(qr/
726 "'c line_num' is working properly.");
730 my $wrapper = DebugWrap->new(
738 q/print "Exp={$exp}\n";/,
741 prog => '../lib/perl5db/t/break-on-dot',
745 $wrapper->output_like(qr/
748 "'b .' is working correctly.");
751 # Testing that the prompt with the information appears inside a subroutine call.
752 # See https://rt.perl.org/rt3/Ticket/Display.html?id=104820
754 my $wrapper = DebugWrap->new(
761 prog => '../lib/perl5db/t/with-subroutine',
765 $wrapper->contents_like(
767 ^main::back\([^\)\n]*\bwith-subroutine:15\):[\ \t]*\n
768 ^15:\s*print\ "hello\ back\\n";
770 "Prompt should display the line of code inside a subroutine.");
773 # Checking that the p command works.
775 my $wrapper = DebugWrap->new(
779 'p "<<<" . (4*6) . ">>>"',
782 prog => '../lib/perl5db/t/with-subroutine',
786 $wrapper->contents_like(
793 my $wrapper = DebugWrap->new(
800 prog => '../lib/perl5db/t/with-subroutine',
804 $wrapper->contents_like(
805 # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
806 qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/ms,
811 # Tests for x with @_
813 my $wrapper = DebugWrap->new(
822 prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc',
826 $wrapper->contents_like(
827 # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
828 qr/Arg1.*?Capsula.*GreekHumor.*Socrates/ms,
829 q/x command test with '@_'./,
833 # Tests for mutating @_
835 my $wrapper = DebugWrap->new(
842 'print "\n\n\n(((" . join(",", @_) . ")))\n\n\n"',
845 prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc',
849 $wrapper->output_like(
850 qr/^\(\(\(Capsula,GreekHumor,Socrates\)\)\)$/ms,
855 # Tests for x with AutoTrace=1.
857 my $wrapper = DebugWrap->new(
868 prog => '../lib/perl5db/t/with-subroutine',
872 $wrapper->contents_like(
873 # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
874 qr/^0\s+SCALAR\([^\)]+\)\n\s+-> 'hello world'\n/ms,
875 "x after AutoTrace=1 command is working."
879 # Tests for "T" (stack trace).
881 my $prog_fn = '../lib/perl5db/t/rt-104168';
882 my $wrapper = DebugWrap->new(
893 my $re_text = join('',
896 "%s = %s\\(\\) called from file " .
897 "'" . quotemeta($prog_fn) . "' line %s\\n",
898 (map { quotemeta($_) } @$_)
902 ['.', 'main::baz', 14,],
903 ['.', 'main::bar', 9,],
904 ['.', 'main::foo', 6],
907 printf "c=[%s]\n", $wrapper->_contents();
908 $wrapper->contents_like(
909 # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
917 my $wrapper = DebugWrap->new(
924 q/print "X={$x};dummy={$dummy}\n";/,
927 prog => '../lib/perl5db/t/disable-breakpoints-1'
931 $wrapper->output_like(qr/
932 X=\{SecondVal\};dummy=\{1\}
934 'test for s - single step',
939 my $wrapper = DebugWrap->new(
947 q/print "Exp={$exp}\n";/,
950 prog => '../lib/perl5db/t/break-on-dot'
954 $wrapper->output_like(qr/
957 "'b .' is working correctly.");
961 my $prog_fn = '../lib/perl5db/t/rt-104168';
962 my $wrapper = DebugWrap->new(
973 $wrapper->contents_like(
975 ^main::foo\([^\)\n]*\brt-104168:9\):[\ \t]*\n
978 'Test for the s command.',
983 my $wrapper = DebugWrap->new(
987 's uncalled_subroutine()',
992 prog => '../lib/perl5db/t/uncalled-subroutine'}
995 $wrapper->output_like(
997 'uncalled_subroutine was called after s EXPR()',
1002 my $wrapper = DebugWrap->new(
1006 'n uncalled_subroutine()',
1010 prog => '../lib/perl5db/t/uncalled-subroutine',
1014 $wrapper->output_like(
1016 'uncalled_subroutine was called after n EXPR()',
1021 my $wrapper = DebugWrap->new(
1033 prog => '../lib/perl5db/t/fact',
1037 $wrapper->output_like(
1039 'b subroutine works fine',
1043 # Test for n with lvalue subs
1047 'n', 'print "<$x>\n"',
1048 'n', 'print "<$x>\n"',
1051 prog => '../lib/perl5db/t/lsub-n',
1054 'n steps over lvalue subs',
1057 # Test for 'M' (module list).
1059 my $wrapper = DebugWrap->new(
1066 prog => '../lib/perl5db/t/load-modules'
1070 $wrapper->contents_like(
1071 qr[Scalar/Util\.pm],
1072 'M (module list) works fine',
1077 my $wrapper = DebugWrap->new(
1085 'print "Var=$var\n";',
1088 prog => '../lib/perl5db/t/test-r-statement',
1092 $wrapper->output_like(
1100 'r statement is working properly.',
1105 my $wrapper = DebugWrap->new(
1112 prog => '../lib/perl5db/t/test-l-statement-1',
1116 $wrapper->contents_like(
1118 ^1==>\s+\$x\ =\ 1;\n
1119 2:\s+print\ "1\\n";\n
1122 5:\s+print\ "2\\n";\n
1124 'l statement is working properly (test No. 1).',
1129 my $wrapper = DebugWrap->new(
1141 prog => '../lib/perl5db/t/test-l-statement-1',
1145 my $first_l_out = qr/
1147 2:\s+print\ "1\\n";\n
1150 5:\s+print\ "2\\n";\n
1153 8:\s+print\ "3\\n";\n
1158 my $second_l_out = qr/
1159 11:\s+print\ "4\\n";\n
1162 14:\s+print\ "5\\n";\n
1165 17:\s+print\ "6\\n";\n
1168 20:\s+print\ "7\\n";\n
1170 $wrapper->contents_like(
1173 [^\n]*?DB<\d+>\ \#\ After\ l\ 1\n
1175 [^\n]*?DB<\d+>\ l\s*\n
1177 [^\n]*?DB<\d+>\ \#\ After\ l\ 2\n
1179 [^\n]*?DB<\d+>\ -\s*\n
1181 [^\n]*?DB<\d+>\ \#\ After\ -\n
1183 'l followed by l and then followed by -',
1188 my $wrapper = DebugWrap->new(
1195 prog => '../lib/perl5db/t/test-l-statement-2',
1199 my $first_l_out = qr/
1201 7:\s+my\ \$n\ =\ shift;\n
1202 8:\s+if\ \(\$n\ >\ 1\)\ \{\n
1203 9:\s+return\ \$n\ \*\ fact\(\$n\ -\ 1\);
1206 $wrapper->contents_like(
1211 'l subroutine_name',
1216 my $wrapper = DebugWrap->new(
1222 # Repeat several times to avoid @typeahead problems.
1229 prog => '../lib/perl5db/t/test-l-statement-2',
1234 ^main::fact\([^\n]*?:7\):\n
1235 ^7:\s+my\ \$n\ =\ shift;\n
1238 $wrapper->contents_like(
1241 auto\(-\d+\)\s+DB<\d+>\s+\.\n
1244 'Test the "." command',
1248 # Testing that the f command works.
1250 my $wrapper = DebugWrap->new(
1254 'f ../lib/perl5db/t/MyModule.pm',
1257 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
1262 prog => '../lib/perl5db/t/filename-line-breakpoint'
1266 $wrapper->output_like(qr/
1274 "f command is working.",
1278 # We broke the /pattern/ command because apparently the CORE::eval-s inside
1279 # lib/perl5db.pl cannot handle lexical variable properly. So we now fix this
1284 # 1. Go over the rest of the "eval"s in lib/perl5db.t and see if they cause
1287 my $wrapper = DebugWrap->new(
1294 prog => '../lib/perl5db/t/eval-line-bug',
1298 $wrapper->contents_like(
1299 qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1300 "/pat/ command is working and found a match.",
1305 my $wrapper = DebugWrap->new(
1314 prog => '../lib/perl5db/t/eval-line-bug',
1318 $wrapper->contents_like(
1319 qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1320 "?pat? command is working and found a match.",
1324 # Test the L command.
1326 my $wrapper = DebugWrap->new(
1335 prog => '../lib/perl5db/t/eval-line-bug',
1339 $wrapper->contents_like(
1341 ^\S*?eval-line-bug:\n
1342 \s*6:\s*my\ \$i\ =\ 5;\n
1343 \s*break\ if\ \(1\)\n
1344 \s*13:\s*\$i\ \+=\ \$q;\n
1345 \s*break\ if\ \(\(\$q\ ==\ 5\)\)\n
1347 "L command is listing breakpoints",
1351 # Test the L command for watch expressions.
1353 my $wrapper = DebugWrap->new(
1361 prog => '../lib/perl5db/t/eval-line-bug',
1365 $wrapper->contents_like(
1367 ^Watch-expressions:\n
1370 "L command is listing watch expressions",
1375 my $wrapper = DebugWrap->new(
1385 prog => '../lib/perl5db/t/eval-line-bug',
1389 $wrapper->contents_like(
1391 ^Watch-expressions:\n
1395 "L command is not listing deleted watch expressions",
1399 # Test the L command.
1401 my $wrapper = DebugWrap->new(
1410 prog => '../lib/perl5db/t/eval-line-bug',
1414 $wrapper->contents_like(
1416 ^\S*?eval-line-bug:\n
1417 \s*6:\s*my\ \$i\ =\ 5;\n
1418 \s*break\ if\ \(1\)\n
1419 \s*13:\s*\$i\ \+=\ \$q;\n
1420 \s*action:\s+print\ \$i\n
1422 "L command is listing actions and breakpoints",
1427 my $wrapper = DebugWrap->new(
1434 prog => '../lib/perl5db/t/rt-104168',
1438 $wrapper->contents_like(
1449 my $wrapper = DebugWrap->new(
1456 prog => '../lib/perl5db/t/rt-104168',
1460 $wrapper->contents_like(
1466 "S command with regex",
1471 my $wrapper = DebugWrap->new(
1478 prog => '../lib/perl5db/t/rt-104168',
1482 $wrapper->contents_unlike(
1486 "S command with negative regex",
1489 $wrapper->contents_like(
1493 "S command with negative regex - what it still matches",
1497 # Test the 'a' command.
1499 my $wrapper = DebugWrap->new(
1503 'a 13 print "\nVar<Q>=$q\n"',
1507 prog => '../lib/perl5db/t/eval-line-bug',
1511 my $nl = $^O eq 'VMS' ? "" : "\\\n";
1512 $wrapper->output_like(qr#
1517 "a command is working",
1521 # Test the 'a' command with no line number.
1523 my $wrapper = DebugWrap->new(
1528 q/a print "Hello " . (3 * 4) . "\n";/,
1532 prog => '../lib/perl5db/t/test-a-statement-1',
1536 $wrapper->output_like(qr#
1537 (?:^Hello\ 12\n.*?){4}
1539 "a command with no line number is working",
1543 # Test the 'A' command
1545 my $wrapper = DebugWrap->new(
1549 'a 13 print "\nVar<Q>=$q\n"',
1554 prog => '../lib/perl5db/t/eval-line-bug',
1558 $wrapper->output_like(
1559 qr#\A\z#msx, # The empty string.
1560 "A command (for removing actions) is working",
1564 # Test the 'A *' command
1566 my $wrapper = DebugWrap->new(
1570 'a 6 print "\nFail!\n"',
1571 'a 13 print "\nVar<Q>=$q\n"',
1576 prog => '../lib/perl5db/t/eval-line-bug',
1580 $wrapper->output_like(
1581 qr#\A\z#msx, # The empty string.
1582 "'A *' command (for removing all actions) is working",
1587 my $wrapper = DebugWrap->new(
1594 'print "\nIDX=<$idx>\n"',
1597 prog => '../lib/perl5db/t/test-w-statement-1',
1602 $wrapper->contents_like(qr#
1604 \s+old\ value:\s+'1'\n
1605 \s+new\ value:\s+'2'\n
1607 'w command - watchpoint changed',
1609 $wrapper->output_like(qr#
1612 "w command - correct output from IDX",
1617 my $wrapper = DebugWrap->new(
1625 'print "\nIDX=<$idx>\n"',
1628 prog => '../lib/perl5db/t/test-w-statement-1',
1632 $wrapper->contents_unlike(qr#
1635 'W command - watchpoint was deleted',
1638 $wrapper->output_like(qr#
1641 "W command - stopped at end.",
1645 # Test the W * command.
1647 my $wrapper = DebugWrap->new(
1656 'print "\nIDX=<$idx>\n"',
1659 prog => '../lib/perl5db/t/test-w-statement-1',
1663 $wrapper->contents_unlike(qr#
1666 '"W *" command - watchpoint was deleted',
1669 $wrapper->output_like(qr#
1672 '"W *" command - stopped at end.',
1676 # Test the 'o' command (without further arguments).
1678 my $wrapper = DebugWrap->new(
1685 prog => '../lib/perl5db/t/test-w-statement-1',
1689 $wrapper->contents_like(qr#
1690 ^\s*warnLevel\ =\ '1'\n
1692 q#"o" command (without arguments) displays warnLevel#,
1695 $wrapper->contents_like(qr#
1696 ^\s*signalLevel\ =\ '1'\n
1698 q#"o" command (without arguments) displays signalLevel#,
1701 $wrapper->contents_like(qr#
1702 ^\s*dieLevel\ =\ '1'\n
1704 q#"o" command (without arguments) displays dieLevel#,
1707 $wrapper->contents_like(qr#
1708 ^\s*hashDepth\ =\ 'N/A'\n
1710 q#"o" command (without arguments) displays hashDepth#,
1714 # Test the 'o' query command.
1716 my $wrapper = DebugWrap->new(
1720 'o hashDepth? signalLevel?',
1723 prog => '../lib/perl5db/t/test-w-statement-1',
1727 $wrapper->contents_unlike(qr#warnLevel#,
1728 q#"o" query command does not display warnLevel#,
1731 $wrapper->contents_like(qr#
1732 ^\s*signalLevel\ =\ '1'\n
1734 q#"o" query command displays signalLevel#,
1737 $wrapper->contents_unlike(qr#dieLevel#,
1738 q#"o" query command does not display dieLevel#,
1741 $wrapper->contents_like(qr#
1742 ^\s*hashDepth\ =\ 'N/A'\n
1744 q#"o" query command displays hashDepth#,
1748 # Test the 'o' set command.
1750 my $wrapper = DebugWrap->new(
1758 prog => '../lib/perl5db/t/test-w-statement-1',
1762 $wrapper->contents_like(qr/
1763 ^\s*(signalLevel\ =\ '0'\n)
1767 q#o set command works#,
1770 $wrapper->contents_like(qr#
1771 ^\s*hashDepth\ =\ 'N/A'\n
1773 q#o set command - hashDepth#,
1777 # Test the '<' and "< ?" commands.
1779 my $wrapper = DebugWrap->new(
1783 q/< print "\nX=<$x>\n"/,
1789 prog => '../lib/perl5db/t/disable-breakpoints-1',
1793 $wrapper->contents_like(qr/
1794 ^pre-perl\ commands:\n
1795 \s*<\ --\ print\ "\\nX=<\$x>\\n"\n
1797 q#Test < and < ? commands - contents.#,
1800 $wrapper->output_like(qr#
1803 q#Test < and < ? commands - output.#,
1807 # Test the '< *' command.
1809 my $wrapper = DebugWrap->new(
1813 q/< print "\nX=<$x>\n"/,
1819 prog => '../lib/perl5db/t/disable-breakpoints-1',
1823 $wrapper->output_unlike(qr/FirstVal/,
1824 q#Test the '< *' command.#,
1828 # Test the '>' and "> ?" commands.
1830 my $wrapper = DebugWrap->new(
1835 q/> print "\nFOO=<$::foo>\n"/,
1841 prog => '../lib/perl5db/t/disable-breakpoints-1',
1845 $wrapper->contents_like(qr/
1846 ^post-perl\ commands:\n
1847 \s*>\ --\ print\ "\\nFOO=<\$::foo>\\n"\n
1849 q#Test > and > ? commands - contents.#,
1852 $wrapper->output_like(qr#
1855 q#Test > and > ? commands - output.#,
1859 # Test the '> *' command.
1861 my $wrapper = DebugWrap->new(
1865 q/> print "\nFOO=<$::foo>\n"/,
1871 prog => '../lib/perl5db/t/disable-breakpoints-1',
1875 $wrapper->output_unlike(qr/FOO=/,
1876 q#Test the '> *' command.#,
1880 # Test the < and > commands together
1882 my $wrapper = DebugWrap->new(
1887 q/< $::lorem += 10;/,
1888 q/> print "\nLOREM=<$::lorem>\n"/,
1895 prog => '../lib/perl5db/t/disable-breakpoints-1',
1899 $wrapper->output_like(qr#
1902 q#Test < and > commands. #,
1906 # Test the { ? and { [command] commands.
1908 my $wrapper = DebugWrap->new(
1919 prog => '../lib/perl5db/t/disable-breakpoints-1',
1923 $wrapper->contents_like(qr#
1924 ^No\ pre-debugger\ actions\.\n
1926 ^pre-debugger\ commands:\n
1929 ^5==>b\s+\$x\ =\ "FirstVal";\n
1933 9:\s+\$x\ =\ "SecondVal";\n
1936 'Test the pre-prompt debugger commands',
1940 # Test the { * command.
1942 my $wrapper = DebugWrap->new(
1950 q/print (("One" x 5), "\n");/,
1953 prog => '../lib/perl5db/t/disable-breakpoints-1',
1957 $wrapper->contents_like(qr#
1958 ^All\ \{\ actions\ cleared\.\n
1960 'Test the { * command',
1963 $wrapper->output_like(qr/OneOneOneOneOne/,
1964 '{ * test - output is OK.',
1968 # Test the ! command.
1970 my $wrapper = DebugWrap->new(
1978 prog => '../lib/perl5db/t/disable-breakpoints-1',
1982 $wrapper->contents_like(qr#
1983 (^3:\s+my\ \$dummy\ =\ 0;\n
1985 5:\s+\$x\ =\ "FirstVal";)\n
1990 'Test the ! command (along with l 3-5)',
1994 # Test the ! -number command.
1996 my $wrapper = DebugWrap->new(
2005 prog => '../lib/perl5db/t/disable-breakpoints-1',
2009 $wrapper->contents_like(qr#
2010 (^3:\s+my\ \$dummy\ =\ 0;\n
2012 5:\s+\$x\ =\ "FirstVal";)\n
2014 ^2==\>\s+my\ \$x\ =\ "One";\n
2019 'Test the ! -n command (along with l)',
2023 # Test the 'source' command.
2025 my $wrapper = DebugWrap->new(
2029 'source ../lib/perl5db/t/source-cmd-test.perldb',
2030 # If we have a 'q' here, then the typeahead will override the
2031 # input, and so it won't be reached - solution:
2032 # put a q inside the .perldb commands.
2033 # ( This may be a bug or a misfeature. )
2035 prog => '../lib/perl5db/t/disable-breakpoints-1',
2039 $wrapper->contents_like(qr#
2040 ^3:\s+my\ \$dummy\ =\ 0;\n
2042 5:\s+\$x\ =\ "FirstVal";\n
2046 9:\s+\$x\ =\ "SecondVal";\n
2049 'Test the source command (along with l)',
2053 # Test the 'source' command being traversed from withing typeahead.
2055 my $wrapper = DebugWrap->new(
2059 'source ../lib/perl5db/t/source-cmd-test-no-q.perldb',
2062 prog => '../lib/perl5db/t/disable-breakpoints-1',
2066 $wrapper->contents_like(qr#
2067 ^3:\s+my\ \$dummy\ =\ 0;\n
2069 5:\s+\$x\ =\ "FirstVal";\n
2073 9:\s+\$x\ =\ "SecondVal";\n
2076 'Test the source command inside a typeahead',
2080 # Test the 'H -number' command.
2082 my $wrapper = DebugWrap->new(
2095 prog => '../lib/perl5db/t/disable-breakpoints-1',
2099 $wrapper->contents_like(qr#
2101 \d+:\s+x\ \(20\+4\)\n
2104 \d+:\s+x\ "Hello\ World"\n
2108 'Test the H -num command',
2112 # Add a test for H (without arguments)
2114 my $wrapper = DebugWrap->new(
2127 prog => '../lib/perl5db/t/disable-breakpoints-1',
2131 $wrapper->contents_like(qr#
2132 ^\d+:\s+x\ \(20\+4\)\n
2135 \d+:\s+x\ "Hello\ World"\n
2139 'Test the H command (without a number.)',
2144 my $wrapper = DebugWrap->new(
2153 prog => '../lib/perl5db/t/test-l-statement-1',
2157 $wrapper->contents_like(
2159 ^1==>\s+\$x\ =\ 1;\n
2160 2:\s+print\ "1\\n";\n
2163 5:\s+print\ "2\\n";\n
2165 'Test the = (command alias) command.',
2169 # Test the m statement.
2171 my $wrapper = DebugWrap->new(
2178 prog => '../lib/perl5db/t/disable-breakpoints-1',
2182 $wrapper->contents_like(qr#
2183 ^via\ UNIVERSAL:\ DOES$
2185 "Test m for main - 1",
2188 $wrapper->contents_like(qr#
2189 ^via\ UNIVERSAL:\ can$
2191 "Test m for main - 2",
2195 # Test the m statement.
2197 my $wrapper = DebugWrap->new(
2206 prog => '../lib/perl5db/t/test-m-statement-1',
2210 $wrapper->contents_like(qr#^greet$#ms,
2211 "Test m for obj - 1",
2214 $wrapper->contents_like(qr#^via UNIVERSAL: can$#ms,
2215 "Test m for obj - 1",
2219 # Test the M command.
2221 my $wrapper = DebugWrap->new(
2228 prog => '../lib/perl5db/t/test-m-statement-1',
2232 $wrapper->contents_like(qr#
2233 ^'strict\.pm'\ =>\ '\d+\.\d+\ from
2240 # Test the recallCommand option.
2242 my $wrapper = DebugWrap->new(
2246 'o recallCommand=%',
2252 prog => '../lib/perl5db/t/disable-breakpoints-1',
2256 $wrapper->contents_like(qr#
2257 (^3:\s+my\ \$dummy\ =\ 0;\n
2259 5:\s+\$x\ =\ "FirstVal";)\n
2261 ^2==\>\s+my\ \$x\ =\ "One";\n
2266 'Test the o recallCommand option',
2270 # Test the dieLevel option
2272 my $wrapper = DebugWrap->new(
2280 prog => '../lib/perl5db/t/test-dieLevel-option-1',
2284 $wrapper->output_like(qr#
2285 ^This\ program\ dies\.\ at\ \S+\ line\ 18\N*\.\n
2287 ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
2288 \s+main::bar\(\)\ called\ at\ \S+\ line\ 7\n
2289 \s+main::foo\(\)\ called\ at\ \S+\ line\ 21\n
2291 'Test the o dieLevel option',
2295 # Test the warnLevel option
2297 my $wrapper = DebugWrap->new(
2305 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2309 $wrapper->contents_like(qr#
2310 ^This\ is\ not\ a\ warning\.\ at\ \S+\ line\ 18\N*\.\n
2312 ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
2313 \s+main::bar\(\)\ called\ at\ \S+\ line\ 25\n
2314 \s+main::myfunc\(\)\ called\ at\ \S+\ line\ 28\n
2316 'Test the o warnLevel option',
2320 # Test the t command
2322 my $wrapper = DebugWrap->new(
2330 prog => '../lib/perl5db/t/disable-breakpoints-1',
2334 $wrapper->contents_like(qr/
2335 ^main::\([^:]+:15\):\n
2336 15:\s+\$dummy\+\+;\n
2337 main::\([^:]+:17\):\n
2338 17:\s+\$x\ =\ "FourthVal";\n
2340 'Test the t command (without a number.)',
2344 # Test the o AutoTrace command
2346 my $wrapper = DebugWrap->new(
2354 prog => '../lib/perl5db/t/disable-breakpoints-1',
2358 $wrapper->contents_like(qr/
2359 ^main::\([^:]+:15\):\n
2360 15:\s+\$dummy\+\+;\n
2361 main::\([^:]+:17\):\n
2362 17:\s+\$x\ =\ "FourthVal";\n
2364 'Test the o AutoTrace command',
2368 # Test the t command with function calls
2370 my $wrapper = DebugWrap->new(
2381 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2385 $wrapper->contents_like(qr/
2386 ^main::\([^:]+:28\):\n
2388 auto\(-\d+\)\s+DB<1>\s+t\n
2390 auto\(-\d+\)\s+DB<1>\s+b\ 18\n
2391 auto\(-\d+\)\s+DB<2>\s+c\n
2392 main::myfunc\([^:]+:25\):\n
2395 'Test the t command with function calls.',
2399 # Test the o AutoTrace command with function calls
2401 my $wrapper = DebugWrap->new(
2412 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2416 $wrapper->contents_like(qr/
2417 ^main::\([^:]+:28\):\n
2419 auto\(-\d+\)\s+DB<1>\s+o\ AutoTrace\n
2420 \s+AutoTrace\s+=\s+'1'\n
2421 auto\(-\d+\)\s+DB<2>\s+b\ 18\n
2422 auto\(-\d+\)\s+DB<3>\s+c\n
2423 main::myfunc\([^:]+:25\):\n
2426 'Test the o AutoTrace command with function calls.',
2430 # Test the final message.
2432 my $wrapper = DebugWrap->new(
2439 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2443 $wrapper->contents_like(qr/
2444 ^Debugged\ program\ terminated\.
2446 'Test the final "Debugged program terminated" message.',
2450 # Test the o inhibit_exit=0 command
2452 my $wrapper = DebugWrap->new(
2463 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2467 $wrapper->contents_unlike(qr/
2468 ^Debugged\ program\ terminated\.
2470 'Test the o inhibit_exit=0 command.',
2474 # Test the o PrintRet=1 option
2476 my $wrapper = DebugWrap->new(
2489 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2493 $wrapper->contents_like(
2494 qr/scalar context return from main::return_scalar: 20024/,
2495 "Test o PrintRet=1",
2499 # Test the o PrintRet=0 option
2501 my $wrapper = DebugWrap->new(
2514 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2518 $wrapper->contents_unlike(
2520 "Test o PrintRet=0",
2524 # Test the o PrintRet=1 option in list context
2526 my $wrapper = DebugWrap->new(
2539 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2543 $wrapper->contents_like(
2544 qr/list context return from main::return_list:\n0\s*'Foo'\n1\s*'Bar'\n2\s*'Baz'\n/,
2545 "Test o PrintRet=1 in list context",
2549 # Test the o PrintRet=0 option in list context
2551 my $wrapper = DebugWrap->new(
2564 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2568 $wrapper->contents_unlike(
2570 "Test o PrintRet=0 in list context",
2574 # Test the o PrintRet=1 option in void context
2576 my $wrapper = DebugWrap->new(
2589 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2593 $wrapper->contents_like(
2594 qr/void context return from main::return_void/,
2595 "Test o PrintRet=1 in void context",
2599 # Test the o PrintRet=1 option in void context
2601 my $wrapper = DebugWrap->new(
2614 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2618 $wrapper->contents_unlike(
2620 "Test o PrintRet=0 in void context",
2624 # Test the o frame option.
2626 my $wrapper = DebugWrap->new(
2630 # This is to avoid getting the "Debugger program terminated"
2631 # junk that interferes with the normal output.
2639 prog => '../lib/perl5db/t/test-frame-option-1',
2643 $wrapper->contents_like(
2645 in\s*\.=main::my_other_func\(3,\ 1200\)\ from.*?
2646 out\s*\.=main::my_other_func\(3,\ 1200\)\ from
2648 "Test o PrintRet=0 in void context",
2653 my $wrapper = DebugWrap->new(
2657 # This is to avoid getting the "Debugger program terminated"
2658 # junk that interferes with the normal output.
2663 prog => '../lib/perl5db/t/fact',
2667 $wrapper->contents_like(
2669 (?:^main::fact.*return\ \$n\ \*\ fact\(\$n\ -\ 1\);.*)
2675 # Test the w for lexical variables expression.
2677 my $wrapper = DebugWrap->new(
2681 # This is to avoid getting the "Debugger program terminated"
2682 # junk that interferes with the normal output.
2690 prog => '../lib/perl5db/t/break-on-dot',
2694 $wrapper->contents_like(
2696 \s+old\ value:\s+'1'\n
2697 \s+new\ value:\s+'2'\n
2699 "Test w for lexical values.",
2703 # perl 5 RT #121509 regression bug.
2704 # “perl debugger doesn't save starting dir to restart from”
2705 # Thanks to Linda Walsh for reporting it.
2707 use File::Temp qw/tempdir/;
2709 my $temp_dir = tempdir( CLEANUP => 1 );
2711 local $ENV{__PERLDB_TEMP_DIR} = $temp_dir;
2712 my $wrapper = DebugWrap->new(
2716 # This is to avoid getting the "Debugger program terminated"
2717 # junk that interferes with the normal output.
2737 prog => '../lib/perl5db/t/rt-121509-restart-after-chdir',
2741 $wrapper->output_like(
2749 "Test that the debugger chdirs to the initial directory after a restart.",
2752 # Test the perldoc command
2753 # We don't actually run the program, but we need to provide one to the wrapper.
2757 or skip "man errors aren't especially portable", 1;
2759 or skip "man command seems to be missing", 1;
2760 local $ENV{LANG} = "C";
2761 local $ENV{LC_MESSAGES} = "C";
2762 local $ENV{LC_ALL} = "C";
2763 my $wrapper = DebugWrap->new(
2767 'perldoc perlrules',
2770 prog => '../lib/perl5db/t/fact',
2774 $wrapper->output_like(
2775 qr/No (?:manual )?entry for perlrules/,
2776 'perldoc command works fine',
2780 # [perl #71678] debugger bug in evaluation of user actions ('a' command)
2781 # Still evaluated after the script finishes.
2783 my $wrapper = DebugWrap->new(
2787 q#a 9 print " \$arg = $arg\n"#,
2792 prog => '../lib/perl5db/t/test-a-statement-2',
2793 switches => [ '-dw', ],
2798 $wrapper->contents_unlike(qr/
2799 Use\ of\ uninitialized\ value\ \$arg\ in\ concatenation\ [\S ]+\ or\ string\ at
2801 'Test that the a command does not emit warnings on program exit.',
2806 # perl 5 RT #126735 regression bug.
2807 local $ENV{PERLDB_OPTS} = "NonStop=0 RemotePort=non-existent-host.tld:9001";
2808 my $output = runperl( stdin => "q\n", stderr => 1, switches => [ '-d' ], prog => '../lib/perl5db/t/fact' );
2811 qr/^Unable to connect to remote host:/ms,
2812 'Tried to connect.',
2817 'Can quit from the debugger after a wrong RemotePort',
2822 # perl 5 RT #120174 - 'p' command
2823 my $wrapper = DebugWrap->new(
2832 prog => '../lib/perl5db/t/rt-120174',
2836 $wrapper->contents_like(
2838 q/RT 120174: p command can be invoked without space after 'p'/,
2843 # perl 5 RT #120174 - 'x' command on array
2844 my $wrapper = DebugWrap->new(
2853 prog => '../lib/perl5db/t/rt-120174',
2857 $wrapper->contents_like(
2858 qr/0\s+1\n1\s+2\n2\s+3\n3\s+4/ms,
2859 q/RT 120174: x command can be invoked without space after 'x' before array/,
2864 # perl 5 RT #120174 - 'x' command on array ref
2865 my $wrapper = DebugWrap->new(
2874 prog => '../lib/perl5db/t/rt-120174',
2878 $wrapper->contents_like(
2879 qr/\s+0\s+1\n\s+1\s+2\n\s+2\s+3\n\s+3\s+4/ms,
2880 q/RT 120174: x command can be invoked without space after 'x' before array ref/,
2885 # perl 5 RT #120174 - 'x' command on hash ref
2886 my $wrapper = DebugWrap->new(
2895 prog => '../lib/perl5db/t/rt-120174',
2899 $wrapper->contents_like(
2900 qr/\s+'alpha'\s+=>\s+'beta'\n\s+'gamma'\s+=>\s+'delta'/ms,
2901 q/RT 120174: x command can be invoked without space after 'x' before hash ref/,
2906 1 while unlink ($rc_filename, $out_fn);