14 if (! -c "/dev/null") {
15 print "1..0 # Skip: no /dev/null\n";
19 my $dev_tty = '/dev/tty';
20 $dev_tty = 'TT:' if ($^O eq 'VMS');
22 print "1..0 # Skip: no $dev_tty\n";
26 print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n";
29 $ENV{PERL_RL} = 'Perl'; # Suppress system Term::ReadLine::Gnu
34 my $rc_filename = '.perldb';
37 open my $rc_fh, '>', $rc_filename
42 # overly permissive perms gives "Must not source insecure rcfile"
43 # and hangs at the DB(1> prompt
44 chmod 0644, $rc_filename;
51 open my $in, '<', $filename
52 or die "Cannot open '$filename' for slurping - $!";
62 my $out_fn = 'db.out';
66 return _slurp($out_fn);
70 # Test for Proxy constants
75 &parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out");
87 my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
88 is($output, "", "proxy constant subroutines");
91 # [perl #66110] Call a subroutine inside a regex
93 local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
94 my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
95 like($output, "All tests successful.", "[perl #66110]");
97 # [ perl #116769] Frame=2
99 local $ENV{PERLDB_OPTS} = "frame=2 nonstop";
100 my $output = runperl( switches => [ '-d' ], prog => 'print q{success}' );
101 is( $?, 0, '[perl #116769] frame=2 does not crash debugger, exit == 0' );
102 like( $output, 'success' , '[perl #116769] code is run' );
104 # [ perl #116771] autotrace
106 local $ENV{PERLDB_OPTS} = "autotrace nonstop";
107 my $output = runperl( switches => [ '-d' ], prog => 'print q{success}' );
108 is( $?, 0, '[perl #116771] autotrace does not crash debugger, exit == 0' );
109 like( $output, 'success' , '[perl #116771] code is run' );
111 # [ perl #41461] Frame=2 noTTY
113 local $ENV{PERLDB_OPTS} = "frame=2 noTTY nonstop";
115 my $output = runperl( switches => [ '-d' ], prog => 'print q{success}' );
116 is( $?, 0, '[perl #41461] frame=2 noTTY does not crash debugger, exit == 0' );
117 like( $output, 'success' , '[perl #41461] code is run' );
125 my $self = bless {}, $class;
136 $self->{_cmds} = shift;
139 return $self->{_cmds};
146 $self->{_prog} = shift;
149 return $self->{_prog};
156 $self->{_output} = shift;
159 return $self->{_output};
168 $self->{_include_t} = shift;
171 return $self->{_include_t};
180 $self->{_stderr_val} = shift;
183 return $self->{_stderr_val};
192 $self->{field} = shift;
195 return $self->{field};
204 $self->{_switches} = shift;
207 return $self->{_switches};
216 $self->{_contents} = shift;
219 return $self->{_contents};
224 my ($self, $args) = @_;
226 my $cmds = $args->{cmds};
228 if (ref($cmds) ne 'ARRAY') {
229 die "cmds must be an array of commands.";
234 my $prog = $args->{prog};
236 if (ref($prog) ne '' or !defined($prog)) {
237 die "prog should be a path to a program file.";
242 $self->_include_t($args->{include_t} ? 1 : 0);
244 $self->_stderr_val(exists($args->{stderr}) ? $args->{stderr} : 1);
246 if (exists($args->{switches}))
248 $self->_switches($args->{switches});
258 my ($self, $str) = @_;
260 $str =~ s/(["\@\$\\])/\\$1/g;
270 my $rc = qq{&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");\n};
275 q#push (@DB::typeahead,#,
276 (map { $self->_quote($_) . "," } @{$self->_cmds()}),
282 # I guess two objects like that cannot be used at the same time.
290 ($self->_switches ? (@{$self->_switches()}) : ('-d')),
291 ($self->_include_t ? ('-I', '../lib/perl5db/t') : ())
293 (defined($self->_stderr_val())
294 ? (stderr => $self->_stderr_val())
297 progfile => $self->_prog()
300 $self->_output($output);
302 $self->_contents(::_out_contents());
309 return shift->_output();
313 my ($self, $re, $msg) = @_;
315 local $::Level = $::Level + 1;
316 ::like($self->_output(), $re, $msg);
320 my ($self, $re, $msg) = @_;
322 local $::Level = $::Level + 1;
323 ::unlike($self->_output(), $re, $msg);
327 my ($self, $re, $msg) = @_;
329 local $::Level = $::Level + 1;
330 ::like($self->_contents(), $re, $msg);
333 sub contents_unlike {
334 my ($self, $re, $msg) = @_;
336 local $::Level = $::Level + 1;
337 ::unlike($self->_contents(), $re, $msg);
343 local $ENV{PERLDB_OPTS} = "ReadLine=0";
344 my $target = '../lib/perl5db/t/eval-line-bug';
345 my $wrapper = DebugWrap->new(
355 "p \@{'main::_<$target'}",
361 $wrapper->contents_like(
363 'The ${main::_<filename} variable in the debugger was not destroyed',
367 sub _calc_generic_wrapper
371 my $extra_opts = delete($args->{extra_opts});
373 local $ENV{PERLDB_OPTS} = "ReadLine=0" . $extra_opts;
374 return DebugWrap->new(
376 cmds => delete($args->{cmds}),
377 prog => delete($args->{prog}),
383 sub _calc_new_var_wrapper
386 return _calc_generic_wrapper(
393 'x "new_var = <$new_var>\\n"',
401 sub _calc_threads_wrapper
405 return _calc_new_var_wrapper(
407 switches => [ '-dt', ],
415 _calc_new_var_wrapper({ prog => '../lib/perl5db/t/eval-line-bug'})
418 "no strict 'vars' in evaluated lines.",
423 _calc_new_var_wrapper(
425 prog => '../lib/perl5db/t/lvalue-bug',
430 'lvalue subs work in the debugger',
435 _calc_new_var_wrapper(
437 prog => '../lib/perl5db/t/symbol-table-bug',
438 extra_opts => "NonStop=1",
442 qr/Undefined symbols 0/,
443 'there are no undefined values in the symbol table',
449 if ( $Config{usethreads} ) {
450 skip('This perl has threads, skipping non-threaded debugger tests');
453 my $error = 'This Perl not built to support threads';
454 _calc_threads_wrapper(
456 prog => '../lib/perl5db/t/eval-line-bug',
460 'Perl debugger correctly complains that it was not built with threads',
467 if ( $Config{usethreads} ) {
468 _calc_threads_wrapper(
470 prog => '../lib/perl5db/t/symbol-table-bug',
473 qr/Undefined symbols 0/,
474 'there are no undefined values in the symbol table when running with thread support',
478 skip("This perl is not threaded, skipping threaded debugger tests");
484 local $ENV{PERLDB_OPTS};
485 my $wrapper = DebugWrap->new(
492 prog => '../lib/perl5db/t/rt-61222',
496 $wrapper->contents_unlike(qr/INCORRECT/, "[perl #61222]");
499 sub _calc_trace_wrapper
503 return _calc_generic_wrapper(
516 # [perl 104168] level option for tracing
518 my $wrapper = _calc_trace_wrapper({ prog => '../lib/perl5db/t/rt-104168' });
519 $wrapper->contents_like(qr/level 2/, "[perl #104168] - level 2 appears");
520 $wrapper->contents_unlike(qr/baz/, "[perl #104168] - no 'baz'");
525 my $wrapper = _calc_trace_wrapper(
527 prog => '../lib/perl5db/t/taint',
528 extra_opts => ' NonStop=1',
529 switches => [ '-d', '-T', ],
533 my $output = $wrapper->get_output();
534 chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
535 is($output, '[$^X][done]', "taint");
538 # Testing that we can set a line in the middle of the file.
540 my $wrapper = DebugWrap->new(
544 'b ../lib/perl5db/t/MyModule.pm:12',
546 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
551 prog => '../lib/perl5db/t/filename-line-breakpoint'
555 $wrapper->output_like(qr/
563 "Can set breakpoint in a line in the middle of the file.");
566 # Testing that we can set a breakpoint
568 my $wrapper = DebugWrap->new(
570 prog => '../lib/perl5db/t/breakpoint-bug',
575 q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/,
582 $wrapper->output_like(
584 "Can set breakpoint in a line."
588 # Testing that we can disable a breakpoint at a numeric line.
590 my $wrapper = DebugWrap->new(
592 prog => '../lib/perl5db/t/disable-breakpoints-1',
599 q/print "X={$x}\n";/,
606 $wrapper->output_like(qr/X=\{SecondVal\}/ms,
607 "Can set breakpoint in a line.");
610 # Testing that we can re-enable a breakpoint at a numeric line.
612 my $wrapper = DebugWrap->new(
614 prog => '../lib/perl5db/t/disable-breakpoints-2',
623 q/print "X={$x}\n";/,
630 $wrapper->output_like(
632 X=\{SecondValOneHundred\}
634 "Can set breakpoint in a line."
639 # Disable and enable for breakpoints on outer files.
641 my $wrapper = DebugWrap->new(
646 'b ../lib/perl5db/t/EnableModule.pm:14',
647 'disable ../lib/perl5db/t/EnableModule.pm:14',
649 'enable ../lib/perl5db/t/EnableModule.pm:14',
651 q/print "X={$x}\n";/,
655 prog => '../lib/perl5db/t/disable-breakpoints-3',
660 $wrapper->output_like(qr/
661 X=\{SecondValTwoHundred\}
663 "Can set breakpoint in a line.");
666 # Testing that the prompt with the information appears.
668 my $wrapper = DebugWrap->new(
671 prog => '../lib/perl5db/t/disable-breakpoints-1',
675 $wrapper->contents_like(qr/
676 ^main::\([^\)]*\bdisable-breakpoints-1:2\):\n
677 2:\s+my\ \$x\ =\ "One";\n
679 "Prompt should display the first line of code.");
682 # Testing that R (restart) and "B *" work.
684 my $wrapper = DebugWrap->new(
694 q/print "X={$x};dummy={$dummy}\n";/,
697 prog => '../lib/perl5db/t/disable-breakpoints-1',
701 $wrapper->output_like(qr/
702 X=\{FirstVal\};dummy=\{1\}
704 "Restart and delete all breakpoints work properly.");
708 my $wrapper = DebugWrap->new(
713 q/print "X={$x}\n";/,
717 prog => '../lib/perl5db/t/disable-breakpoints-1',
721 $wrapper->output_like(qr/
724 "'c line_num' is working properly.");
728 my $wrapper = DebugWrap->new(
736 q/print "Exp={$exp}\n";/,
739 prog => '../lib/perl5db/t/break-on-dot',
743 $wrapper->output_like(qr/
746 "'b .' is working correctly.");
749 # Testing that the prompt with the information appears inside a subroutine call.
750 # See https://rt.perl.org/rt3/Ticket/Display.html?id=104820
752 my $wrapper = DebugWrap->new(
759 prog => '../lib/perl5db/t/with-subroutine',
763 $wrapper->contents_like(
765 ^main::back\([^\)\n]*\bwith-subroutine:15\):[\ \t]*\n
766 ^15:\s*print\ "hello\ back\\n";
768 "Prompt should display the line of code inside a subroutine.");
771 # Checking that the p command works.
773 my $wrapper = DebugWrap->new(
777 'p "<<<" . (4*6) . ">>>"',
780 prog => '../lib/perl5db/t/with-subroutine',
784 $wrapper->contents_like(
791 my $wrapper = DebugWrap->new(
798 prog => '../lib/perl5db/t/with-subroutine',
802 $wrapper->contents_like(
803 # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
804 qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/ms,
809 # Tests for x with @_
811 my $wrapper = DebugWrap->new(
820 prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc',
824 $wrapper->contents_like(
825 # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
826 qr/Arg1.*?Capsula.*GreekHumor.*Socrates/ms,
827 q/x command test with '@_'./,
831 # Tests for mutating @_
833 my $wrapper = DebugWrap->new(
840 'print "\n\n\n(((" . join(",", @_) . ")))\n\n\n"',
843 prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc',
847 $wrapper->output_like(
848 qr/^\(\(\(Capsula,GreekHumor,Socrates\)\)\)$/ms,
853 # Tests for x with AutoTrace=1.
855 my $wrapper = DebugWrap->new(
866 prog => '../lib/perl5db/t/with-subroutine',
870 $wrapper->contents_like(
871 # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
872 qr/^0\s+SCALAR\([^\)]+\)\n\s+-> 'hello world'\n/ms,
873 "x after AutoTrace=1 command is working."
877 # Tests for "T" (stack trace).
879 my $prog_fn = '../lib/perl5db/t/rt-104168';
880 my $wrapper = DebugWrap->new(
891 my $re_text = join('',
894 "%s = %s\\(\\) called from file " .
895 "'" . quotemeta($prog_fn) . "' line %s\\n",
896 (map { quotemeta($_) } @$_)
900 ['.', 'main::baz', 14,],
901 ['.', 'main::bar', 9,],
902 ['.', 'main::foo', 6],
905 $wrapper->contents_like(
906 # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
914 my $wrapper = DebugWrap->new(
921 q/print "X={$x};dummy={$dummy}\n";/,
924 prog => '../lib/perl5db/t/disable-breakpoints-1'
928 $wrapper->output_like(qr/
929 X=\{SecondVal\};dummy=\{1\}
931 'test for s - single step',
936 my $wrapper = DebugWrap->new(
944 q/print "Exp={$exp}\n";/,
947 prog => '../lib/perl5db/t/break-on-dot'
951 $wrapper->output_like(qr/
954 "'b .' is working correctly.");
958 my $prog_fn = '../lib/perl5db/t/rt-104168';
959 my $wrapper = DebugWrap->new(
970 $wrapper->contents_like(
972 ^main::foo\([^\)\n]*\brt-104168:9\):[\ \t]*\n
975 'Test for the s command.',
980 my $wrapper = DebugWrap->new(
984 's uncalled_subroutine()',
989 prog => '../lib/perl5db/t/uncalled-subroutine'}
992 $wrapper->output_like(
994 'uncalled_subroutine was called after s EXPR()',
999 my $wrapper = DebugWrap->new(
1003 'n uncalled_subroutine()',
1007 prog => '../lib/perl5db/t/uncalled-subroutine',
1011 $wrapper->output_like(
1013 'uncalled_subroutine was called after n EXPR()',
1018 my $wrapper = DebugWrap->new(
1030 prog => '../lib/perl5db/t/fact',
1034 $wrapper->output_like(
1036 'b subroutine works fine',
1040 # Test for n with lvalue subs
1044 'n', 'print "<$x>"',
1045 'n', 'print "<$x>"',
1048 prog => '../lib/perl5db/t/lsub-n',
1051 'n steps over lvalue subs',
1054 # Test for 'M' (module list).
1056 my $wrapper = DebugWrap->new(
1063 prog => '../lib/perl5db/t/load-modules'
1067 $wrapper->contents_like(
1068 qr[Scalar/Util\.pm],
1069 'M (module list) works fine',
1074 my $wrapper = DebugWrap->new(
1082 'print "Var=$var\n";',
1085 prog => '../lib/perl5db/t/test-r-statement',
1089 $wrapper->output_like(
1097 'r statement is working properly.',
1102 my $wrapper = DebugWrap->new(
1109 prog => '../lib/perl5db/t/test-l-statement-1',
1113 $wrapper->contents_like(
1115 ^1==>\s+\$x\ =\ 1;\n
1116 2:\s+print\ "1\\n";\n
1119 5:\s+print\ "2\\n";\n
1121 'l statement is working properly (test No. 1).',
1126 my $wrapper = DebugWrap->new(
1138 prog => '../lib/perl5db/t/test-l-statement-1',
1142 my $first_l_out = qr/
1144 2:\s+print\ "1\\n";\n
1147 5:\s+print\ "2\\n";\n
1150 8:\s+print\ "3\\n";\n
1155 my $second_l_out = qr/
1156 11:\s+print\ "4\\n";\n
1159 14:\s+print\ "5\\n";\n
1162 17:\s+print\ "6\\n";\n
1165 20:\s+print\ "7\\n";\n
1167 $wrapper->contents_like(
1170 [^\n]*?DB<\d+>\ \#\ After\ l\ 1\n
1172 [^\n]*?DB<\d+>\ l\s*\n
1174 [^\n]*?DB<\d+>\ \#\ After\ l\ 2\n
1176 [^\n]*?DB<\d+>\ -\s*\n
1178 [^\n]*?DB<\d+>\ \#\ After\ -\n
1180 'l followed by l and then followed by -',
1185 my $wrapper = DebugWrap->new(
1192 prog => '../lib/perl5db/t/test-l-statement-2',
1196 my $first_l_out = qr/
1198 7:\s+my\ \$n\ =\ shift;\n
1199 8:\s+if\ \(\$n\ >\ 1\)\ \{\n
1200 9:\s+return\ \$n\ \*\ fact\(\$n\ -\ 1\);
1203 $wrapper->contents_like(
1208 'l subroutine_name',
1213 my $wrapper = DebugWrap->new(
1219 # Repeat several times to avoid @typeahead problems.
1226 prog => '../lib/perl5db/t/test-l-statement-2',
1231 ^main::fact\([^\n]*?:7\):\n
1232 ^7:\s+my\ \$n\ =\ shift;\n
1235 $wrapper->contents_like(
1240 'Test the "." command',
1244 # Testing that the f command works.
1246 my $wrapper = DebugWrap->new(
1250 'f ../lib/perl5db/t/MyModule.pm',
1253 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
1258 prog => '../lib/perl5db/t/filename-line-breakpoint'
1262 $wrapper->output_like(qr/
1270 "f command is working.",
1274 # We broke the /pattern/ command because apparently the CORE::eval-s inside
1275 # lib/perl5db.pl cannot handle lexical variable properly. So we now fix this
1280 # 1. Go over the rest of the "eval"s in lib/perl5db.t and see if they cause
1283 my $wrapper = DebugWrap->new(
1290 prog => '../lib/perl5db/t/eval-line-bug',
1294 $wrapper->contents_like(
1295 qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1296 "/pat/ command is working and found a match.",
1301 my $wrapper = DebugWrap->new(
1310 prog => '../lib/perl5db/t/eval-line-bug',
1314 $wrapper->contents_like(
1315 qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1316 "?pat? command is working and found a match.",
1320 # Test the L command.
1322 my $wrapper = DebugWrap->new(
1331 prog => '../lib/perl5db/t/eval-line-bug',
1335 $wrapper->contents_like(
1337 ^\S*?eval-line-bug:\n
1338 \s*6:\s*my\ \$i\ =\ 5;\n
1339 \s*break\ if\ \(1\)\n
1340 \s*13:\s*\$i\ \+=\ \$q;\n
1341 \s*break\ if\ \(\(\$q\ ==\ 5\)\)\n
1343 "L command is listing breakpoints",
1347 # Test the L command for watch expressions.
1349 my $wrapper = DebugWrap->new(
1357 prog => '../lib/perl5db/t/eval-line-bug',
1361 $wrapper->contents_like(
1363 ^Watch-expressions:\n
1366 "L command is listing watch expressions",
1371 my $wrapper = DebugWrap->new(
1381 prog => '../lib/perl5db/t/eval-line-bug',
1385 $wrapper->contents_like(
1387 ^Watch-expressions:\n
1391 "L command is not listing deleted watch expressions",
1395 # Test the L command.
1397 my $wrapper = DebugWrap->new(
1406 prog => '../lib/perl5db/t/eval-line-bug',
1410 $wrapper->contents_like(
1412 ^\S*?eval-line-bug:\n
1413 \s*6:\s*my\ \$i\ =\ 5;\n
1414 \s*break\ if\ \(1\)\n
1415 \s*13:\s*\$i\ \+=\ \$q;\n
1416 \s*action:\s+print\ \$i\n
1418 "L command is listing actions and breakpoints",
1423 my $wrapper = DebugWrap->new(
1430 prog => '../lib/perl5db/t/rt-104168',
1434 $wrapper->contents_like(
1445 my $wrapper = DebugWrap->new(
1452 prog => '../lib/perl5db/t/rt-104168',
1456 $wrapper->contents_like(
1462 "S command with regex",
1467 my $wrapper = DebugWrap->new(
1474 prog => '../lib/perl5db/t/rt-104168',
1478 $wrapper->contents_unlike(
1482 "S command with negative regex",
1485 $wrapper->contents_like(
1489 "S command with negative regex - what it still matches",
1493 # Test the 'a' command.
1495 my $wrapper = DebugWrap->new(
1499 'a 13 print "\nVar<Q>=$q\n"',
1503 prog => '../lib/perl5db/t/eval-line-bug',
1507 $wrapper->output_like(qr#
1512 "a command is working",
1516 # Test the 'a' command with no line number.
1518 my $wrapper = DebugWrap->new(
1523 q/a print "Hello " . (3 * 4) . "\n";/,
1527 prog => '../lib/perl5db/t/test-a-statement-1',
1531 $wrapper->output_like(qr#
1532 (?:^Hello\ 12\n.*?){4}
1534 "a command with no line number is working",
1538 # Test the 'A' command
1540 my $wrapper = DebugWrap->new(
1544 'a 13 print "\nVar<Q>=$q\n"',
1549 prog => '../lib/perl5db/t/eval-line-bug',
1553 $wrapper->output_like(
1554 qr#\A\z#msx, # The empty string.
1555 "A command (for removing actions) is working",
1559 # Test the 'A *' command
1561 my $wrapper = DebugWrap->new(
1565 'a 6 print "\nFail!\n"',
1566 'a 13 print "\nVar<Q>=$q\n"',
1571 prog => '../lib/perl5db/t/eval-line-bug',
1575 $wrapper->output_like(
1576 qr#\A\z#msx, # The empty string.
1577 "'A *' command (for removing all actions) is working",
1582 my $wrapper = DebugWrap->new(
1589 'print "\nIDX=<$idx>\n"',
1592 prog => '../lib/perl5db/t/test-w-statement-1',
1597 $wrapper->contents_like(qr#
1599 \s+old\ value:\s+'1'\n
1600 \s+new\ value:\s+'2'\n
1602 'w command - watchpoint changed',
1604 $wrapper->output_like(qr#
1607 "w command - correct output from IDX",
1612 my $wrapper = DebugWrap->new(
1620 'print "\nIDX=<$idx>\n"',
1623 prog => '../lib/perl5db/t/test-w-statement-1',
1627 $wrapper->contents_unlike(qr#
1630 'W command - watchpoint was deleted',
1633 $wrapper->output_like(qr#
1636 "W command - stopped at end.",
1640 # Test the W * command.
1642 my $wrapper = DebugWrap->new(
1651 'print "\nIDX=<$idx>\n"',
1654 prog => '../lib/perl5db/t/test-w-statement-1',
1658 $wrapper->contents_unlike(qr#
1661 '"W *" command - watchpoint was deleted',
1664 $wrapper->output_like(qr#
1667 '"W *" command - stopped at end.',
1671 # Test the 'o' command (without further arguments).
1673 my $wrapper = DebugWrap->new(
1680 prog => '../lib/perl5db/t/test-w-statement-1',
1684 $wrapper->contents_like(qr#
1685 ^\s*warnLevel\ =\ '1'\n
1687 q#"o" command (without arguments) displays warnLevel#,
1690 $wrapper->contents_like(qr#
1691 ^\s*signalLevel\ =\ '1'\n
1693 q#"o" command (without arguments) displays signalLevel#,
1696 $wrapper->contents_like(qr#
1697 ^\s*dieLevel\ =\ '1'\n
1699 q#"o" command (without arguments) displays dieLevel#,
1702 $wrapper->contents_like(qr#
1703 ^\s*hashDepth\ =\ 'N/A'\n
1705 q#"o" command (without arguments) displays hashDepth#,
1709 # Test the 'o' query command.
1711 my $wrapper = DebugWrap->new(
1715 'o hashDepth? signalLevel?',
1718 prog => '../lib/perl5db/t/test-w-statement-1',
1722 $wrapper->contents_unlike(qr#warnLevel#,
1723 q#"o" query command does not display warnLevel#,
1726 $wrapper->contents_like(qr#
1727 ^\s*signalLevel\ =\ '1'\n
1729 q#"o" query command displays signalLevel#,
1732 $wrapper->contents_unlike(qr#dieLevel#,
1733 q#"o" query command does not display dieLevel#,
1736 $wrapper->contents_like(qr#
1737 ^\s*hashDepth\ =\ 'N/A'\n
1739 q#"o" query command displays hashDepth#,
1743 # Test the 'o' set command.
1745 my $wrapper = DebugWrap->new(
1753 prog => '../lib/perl5db/t/test-w-statement-1',
1757 $wrapper->contents_like(qr/
1758 ^\s*(signalLevel\ =\ '0'\n)
1762 q#o set command works#,
1765 $wrapper->contents_like(qr#
1766 ^\s*hashDepth\ =\ 'N/A'\n
1768 q#o set command - hashDepth#,
1772 # Test the '<' and "< ?" commands.
1774 my $wrapper = DebugWrap->new(
1778 q/< print "\nX=<$x>\n"/,
1784 prog => '../lib/perl5db/t/disable-breakpoints-1',
1788 $wrapper->contents_like(qr/
1789 ^pre-perl\ commands:\n
1790 \s*<\ --\ print\ "\\nX=<\$x>\\n"\n
1792 q#Test < and < ? commands - contents.#,
1795 $wrapper->output_like(qr#
1798 q#Test < and < ? commands - output.#,
1802 # Test the '< *' command.
1804 my $wrapper = DebugWrap->new(
1808 q/< print "\nX=<$x>\n"/,
1814 prog => '../lib/perl5db/t/disable-breakpoints-1',
1818 $wrapper->output_unlike(qr/FirstVal/,
1819 q#Test the '< *' command.#,
1823 # Test the '>' and "> ?" commands.
1825 my $wrapper = DebugWrap->new(
1830 q/> print "\nFOO=<$::foo>\n"/,
1836 prog => '../lib/perl5db/t/disable-breakpoints-1',
1840 $wrapper->contents_like(qr/
1841 ^post-perl\ commands:\n
1842 \s*>\ --\ print\ "\\nFOO=<\$::foo>\\n"\n
1844 q#Test > and > ? commands - contents.#,
1847 $wrapper->output_like(qr#
1850 q#Test > and > ? commands - output.#,
1854 # Test the '> *' command.
1856 my $wrapper = DebugWrap->new(
1860 q/> print "\nFOO=<$::foo>\n"/,
1866 prog => '../lib/perl5db/t/disable-breakpoints-1',
1870 $wrapper->output_unlike(qr/FOO=/,
1871 q#Test the '> *' command.#,
1875 # Test the < and > commands together
1877 my $wrapper = DebugWrap->new(
1882 q/< $::lorem += 10;/,
1883 q/> print "\nLOREM=<$::lorem>\n"/,
1890 prog => '../lib/perl5db/t/disable-breakpoints-1',
1894 $wrapper->output_like(qr#
1897 q#Test < and > commands. #,
1901 # Test the { ? and { [command] commands.
1903 my $wrapper = DebugWrap->new(
1914 prog => '../lib/perl5db/t/disable-breakpoints-1',
1918 $wrapper->contents_like(qr#
1919 ^No\ pre-debugger\ actions\.\n
1921 ^pre-debugger\ commands:\n
1924 ^5==>b\s+\$x\ =\ "FirstVal";\n
1928 9:\s+\$x\ =\ "SecondVal";\n
1931 'Test the pre-prompt debugger commands',
1935 # Test the { * command.
1937 my $wrapper = DebugWrap->new(
1945 q/print (("One" x 5), "\n");/,
1948 prog => '../lib/perl5db/t/disable-breakpoints-1',
1952 $wrapper->contents_like(qr#
1953 ^All\ \{\ actions\ cleared\.\n
1955 'Test the { * command',
1958 $wrapper->output_like(qr/OneOneOneOneOne/,
1959 '{ * test - output is OK.',
1963 # Test the ! command.
1965 my $wrapper = DebugWrap->new(
1973 prog => '../lib/perl5db/t/disable-breakpoints-1',
1977 $wrapper->contents_like(qr#
1978 (^3:\s+my\ \$dummy\ =\ 0;\n
1980 5:\s+\$x\ =\ "FirstVal";)\n
1985 'Test the ! command (along with l 3-5)',
1989 # Test the ! -number command.
1991 my $wrapper = DebugWrap->new(
2000 prog => '../lib/perl5db/t/disable-breakpoints-1',
2004 $wrapper->contents_like(qr#
2005 (^3:\s+my\ \$dummy\ =\ 0;\n
2007 5:\s+\$x\ =\ "FirstVal";)\n
2009 ^2==\>\s+my\ \$x\ =\ "One";\n
2014 'Test the ! -n command (along with l)',
2018 # Test the 'source' command.
2020 my $wrapper = DebugWrap->new(
2024 'source ../lib/perl5db/t/source-cmd-test.perldb',
2025 # If we have a 'q' here, then the typeahead will override the
2026 # input, and so it won't be reached - solution:
2027 # put a q inside the .perldb commands.
2028 # ( This may be a bug or a misfeature. )
2030 prog => '../lib/perl5db/t/disable-breakpoints-1',
2034 $wrapper->contents_like(qr#
2035 ^3:\s+my\ \$dummy\ =\ 0;\n
2037 5:\s+\$x\ =\ "FirstVal";\n
2041 9:\s+\$x\ =\ "SecondVal";\n
2044 'Test the source command (along with l)',
2048 # Test the 'source' command being traversed from withing typeahead.
2050 my $wrapper = DebugWrap->new(
2054 'source ../lib/perl5db/t/source-cmd-test-no-q.perldb',
2057 prog => '../lib/perl5db/t/disable-breakpoints-1',
2061 $wrapper->contents_like(qr#
2062 ^3:\s+my\ \$dummy\ =\ 0;\n
2064 5:\s+\$x\ =\ "FirstVal";\n
2068 9:\s+\$x\ =\ "SecondVal";\n
2071 'Test the source command inside a typeahead',
2075 # Test the 'H -number' command.
2077 my $wrapper = DebugWrap->new(
2090 prog => '../lib/perl5db/t/disable-breakpoints-1',
2094 $wrapper->contents_like(qr#
2096 \d+:\s+x\ \(20\+4\)\n
2099 \d+:\s+x\ "Hello\ World"\n
2103 'Test the H -num command',
2107 # Add a test for H (without arguments)
2109 my $wrapper = DebugWrap->new(
2122 prog => '../lib/perl5db/t/disable-breakpoints-1',
2126 $wrapper->contents_like(qr#
2127 ^\d+:\s+x\ \(20\+4\)\n
2130 \d+:\s+x\ "Hello\ World"\n
2134 'Test the H command (without a number.)',
2139 my $wrapper = DebugWrap->new(
2148 prog => '../lib/perl5db/t/test-l-statement-1',
2152 $wrapper->contents_like(
2154 ^1==>\s+\$x\ =\ 1;\n
2155 2:\s+print\ "1\\n";\n
2158 5:\s+print\ "2\\n";\n
2160 'Test the = (command alias) command.',
2164 # Test the m statement.
2166 my $wrapper = DebugWrap->new(
2173 prog => '../lib/perl5db/t/disable-breakpoints-1',
2177 $wrapper->contents_like(qr#
2178 ^via\ UNIVERSAL:\ DOES$
2180 "Test m for main - 1",
2183 $wrapper->contents_like(qr#
2184 ^via\ UNIVERSAL:\ can$
2186 "Test m for main - 2",
2190 # Test the m statement.
2192 my $wrapper = DebugWrap->new(
2201 prog => '../lib/perl5db/t/test-m-statement-1',
2205 $wrapper->contents_like(qr#^greet$#ms,
2206 "Test m for obj - 1",
2209 $wrapper->contents_like(qr#^via UNIVERSAL: can$#ms,
2210 "Test m for obj - 1",
2214 # Test the M command.
2216 my $wrapper = DebugWrap->new(
2223 prog => '../lib/perl5db/t/test-m-statement-1',
2227 $wrapper->contents_like(qr#
2228 ^'strict\.pm'\ =>\ '\d+\.\d+\ from
2235 # Test the recallCommand option.
2237 my $wrapper = DebugWrap->new(
2241 'o recallCommand=%',
2247 prog => '../lib/perl5db/t/disable-breakpoints-1',
2251 $wrapper->contents_like(qr#
2252 (^3:\s+my\ \$dummy\ =\ 0;\n
2254 5:\s+\$x\ =\ "FirstVal";)\n
2256 ^2==\>\s+my\ \$x\ =\ "One";\n
2261 'Test the o recallCommand option',
2265 # Test the dieLevel option
2267 my $wrapper = DebugWrap->new(
2275 prog => '../lib/perl5db/t/test-dieLevel-option-1',
2279 $wrapper->output_like(qr#
2280 ^This\ program\ dies\.\ at\ \S+\ line\ 18\.\n
2282 ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
2283 \s+main::bar\(\)\ called\ at\ \S+\ line\ 7\n
2284 \s+main::foo\(\)\ called\ at\ \S+\ line\ 21\n
2286 'Test the o dieLevel option',
2290 # Test the warnLevel option
2292 my $wrapper = DebugWrap->new(
2300 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2304 $wrapper->contents_like(qr#
2305 ^This\ is\ not\ a\ warning\.\ at\ \S+\ line\ 18\.\n
2307 ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
2308 \s+main::bar\(\)\ called\ at\ \S+\ line\ 25\n
2309 \s+main::myfunc\(\)\ called\ at\ \S+\ line\ 28\n
2311 'Test the o warnLevel option',
2315 # Test the t command
2317 my $wrapper = DebugWrap->new(
2325 prog => '../lib/perl5db/t/disable-breakpoints-1',
2329 $wrapper->contents_like(qr/
2330 ^main::\([^:]+:15\):\n
2331 15:\s+\$dummy\+\+;\n
2332 main::\([^:]+:17\):\n
2333 17:\s+\$x\ =\ "FourthVal";\n
2335 'Test the t command (without a number.)',
2339 # Test the o AutoTrace command
2341 my $wrapper = DebugWrap->new(
2349 prog => '../lib/perl5db/t/disable-breakpoints-1',
2353 $wrapper->contents_like(qr/
2354 ^main::\([^:]+:15\):\n
2355 15:\s+\$dummy\+\+;\n
2356 main::\([^:]+:17\):\n
2357 17:\s+\$x\ =\ "FourthVal";\n
2359 'Test the o AutoTrace command',
2363 # Test the t command with function calls
2365 my $wrapper = DebugWrap->new(
2376 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2380 $wrapper->contents_like(qr/
2381 ^main::\([^:]+:28\):\n
2383 main::myfunc\([^:]+:25\):\n
2386 'Test the t command with function calls.',
2390 # Test the o AutoTrace command with function calls
2392 my $wrapper = DebugWrap->new(
2403 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2407 $wrapper->contents_like(qr/
2408 ^main::\([^:]+:28\):\n
2410 main::myfunc\([^:]+:25\):\n
2413 'Test the t command with function calls.',
2417 # Test the final message.
2419 my $wrapper = DebugWrap->new(
2426 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2430 $wrapper->contents_like(qr/
2431 ^Debugged\ program\ terminated\.
2433 'Test the final "Debugged program terminated" message.',
2437 # Test the o inhibit_exit=0 command
2439 my $wrapper = DebugWrap->new(
2450 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2454 $wrapper->contents_unlike(qr/
2455 ^Debugged\ program\ terminated\.
2457 'Test the o inhibit_exit=0 command.',
2461 # Test the o PrintRet=1 option
2463 my $wrapper = DebugWrap->new(
2476 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2480 $wrapper->contents_like(
2481 qr/scalar context return from main::return_scalar: 20024/,
2482 "Test o PrintRet=1",
2486 # Test the o PrintRet=0 option
2488 my $wrapper = DebugWrap->new(
2501 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2505 $wrapper->contents_unlike(
2507 "Test o PrintRet=0",
2511 # Test the o PrintRet=1 option in list context
2513 my $wrapper = DebugWrap->new(
2526 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2530 $wrapper->contents_like(
2531 qr/list context return from main::return_list:\n0\s*'Foo'\n1\s*'Bar'\n2\s*'Baz'\n/,
2532 "Test o PrintRet=1 in list context",
2536 # Test the o PrintRet=0 option in list context
2538 my $wrapper = DebugWrap->new(
2551 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2555 $wrapper->contents_unlike(
2557 "Test o PrintRet=0 in list context",
2561 # Test the o PrintRet=1 option in void context
2563 my $wrapper = DebugWrap->new(
2576 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2580 $wrapper->contents_like(
2581 qr/void context return from main::return_void/,
2582 "Test o PrintRet=1 in void context",
2586 # Test the o PrintRet=1 option in void context
2588 my $wrapper = DebugWrap->new(
2601 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2605 $wrapper->contents_unlike(
2607 "Test o PrintRet=0 in void context",
2611 # Test the o frame option.
2613 my $wrapper = DebugWrap->new(
2617 # This is to avoid getting the "Debugger program terminated"
2618 # junk that interferes with the normal output.
2626 prog => '../lib/perl5db/t/test-frame-option-1',
2630 $wrapper->contents_like(
2632 in\s*\.=main::my_other_func\(3,\ 1200\)\ from.*?
2633 out\s*\.=main::my_other_func\(3,\ 1200\)\ from
2635 "Test o PrintRet=0 in void context",
2640 my $wrapper = DebugWrap->new(
2644 # This is to avoid getting the "Debugger program terminated"
2645 # junk that interferes with the normal output.
2650 prog => '../lib/perl5db/t/fact',
2654 $wrapper->contents_like(
2656 (?:^main::fact.*return\ \$n\ \*\ fact\(\$n\ -\ 1\);.*)
2662 # Test the w for lexical variables expression.
2664 my $wrapper = DebugWrap->new(
2668 # This is to avoid getting the "Debugger program terminated"
2669 # junk that interferes with the normal output.
2677 prog => '../lib/perl5db/t/break-on-dot',
2681 $wrapper->contents_like(
2683 \s+old\ value:\s+'1'\n
2684 \s+new\ value:\s+'2'\n
2686 "Test w for lexical values.",
2690 # Test the perldoc command
2691 # We don't actually run the program, but we need to provide one to the wrapper.
2695 or skip "man errors aren't especially portable", 1;
2696 local $ENV{LANG} = "C";
2697 local $ENV{LC_MESSAGE} = "C";
2698 local $ENV{LC_ALL} = "C";
2699 my $wrapper = DebugWrap->new(
2703 'perldoc perlrules',
2706 prog => '../lib/perl5db/t/fact',
2710 $wrapper->output_like(
2711 qr/No manual entry for perlrules/,
2712 'perldoc command works fine',
2717 1 while unlink ($rc_filename, $out_fn);