This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix test failure in lib/perl5db.t when mandoc is installed
[perl5.git] / lib / perl5db.t
CommitLineData
af6d5e29 1#!./perl
635f2c9e
RGS
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
6 require './test.pl';
7}
8
9use strict;
10use warnings;
f63574b5 11use Config;
635f2c9e
RGS
12
13BEGIN {
4cfe45a1
SF
14 if (! -c "/dev/null") {
15 print "1..0 # Skip: no /dev/null\n";
16 exit 0;
635f2c9e 17 }
4cfe45a1
SF
18
19 my $dev_tty = '/dev/tty';
20 $dev_tty = 'TT:' if ($^O eq 'VMS');
21 if (! -c $dev_tty) {
22 print "1..0 # Skip: no $dev_tty\n";
23 exit 0;
9366364f 24 }
b091e0d1 25 if ($ENV{PERL5DB}) {
4cfe45a1
SF
26 print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n";
27 exit 0;
b091e0d1 28 }
fc4b8164 29 $ENV{PERL_RL} = 'Perl'; # Suppress system Term::ReadLine::Gnu
635f2c9e
RGS
30}
31
23053931 32plan(123);
635f2c9e 33
4cfe45a1
SF
34my $rc_filename = '.perldb';
35
635f2c9e 36sub rc {
4cfe45a1
SF
37 open my $rc_fh, '>', $rc_filename
38 or die $!;
39 print {$rc_fh} @_;
40 close ($rc_fh);
41
3e5e55bd
DM
42 # overly permissive perms gives "Must not source insecure rcfile"
43 # and hangs at the DB(1> prompt
4cfe45a1 44 chmod 0644, $rc_filename;
635f2c9e
RGS
45}
46
4cfe45a1
SF
47sub _slurp
48{
49 my $filename = shift;
cd4eab35 50
4cfe45a1
SF
51 open my $in, '<', $filename
52 or die "Cannot open '$filename' for slurping - $!";
635f2c9e 53
4cfe45a1
SF
54 local $/;
55 my $contents = <$in>;
56
57 close($in);
58
59 return $contents;
60}
61
62my $out_fn = 'db.out';
635f2c9e 63
4cfe45a1 64sub _out_contents
c18cf8ce 65{
4cfe45a1 66 return _slurp($out_fn);
c18cf8ce 67}
635f2c9e 68
7eedc5ec
B
69
70# Test for Proxy constants
71{
72 rc(
4cfe45a1 73 <<'EOF',
7eedc5ec 74
24fc4d43 75&parse_options("NonStop=0 ReadLine=0 TTY=db.out");
4cfe45a1
SF
76
77sub afterinit {
78 push(@DB::typeahead,
79 'm main->s1',
80 'q',
81 );
82}
83
84EOF
7eedc5ec
B
85 );
86
87 my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
88 is($output, "", "proxy constant subroutines");
89}
90
b7bfa855
B
91# [perl #66110] Call a subroutine inside a regex
92{
93 local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
94 my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
aaa63dae 95 like($output, qr/\bAll tests successful\.$/, "[perl #66110]");
b7bfa855 96}
a7d38e67
KF
97# [ perl #116769] Frame=2
98{
99 local $ENV{PERLDB_OPTS} = "frame=2 nonstop";
0034e503 100 my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' );
a7d38e67 101 is( $?, 0, '[perl #116769] frame=2 does not crash debugger, exit == 0' );
0034e503 102 is( $output, "success\n" , '[perl #116769] code is run' );
a7d38e67 103}
ddd6e339
KF
104# [ perl #116771] autotrace
105{
106 local $ENV{PERLDB_OPTS} = "autotrace nonstop";
0034e503 107 my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' );
ddd6e339 108 is( $?, 0, '[perl #116771] autotrace does not crash debugger, exit == 0' );
0034e503 109 is( $output, "success\n" , '[perl #116771] code is run' );
ddd6e339 110}
aa8c2dcb
SF
111# [ perl #41461] Frame=2 noTTY
112{
113 local $ENV{PERLDB_OPTS} = "frame=2 noTTY nonstop";
114 rc('');
0034e503 115 my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' );
aa8c2dcb 116 is( $?, 0, '[perl #41461] frame=2 noTTY does not crash debugger, exit == 0' );
0034e503 117 is( $output, "success\n" , '[perl #41461] code is run' );
aa8c2dcb 118}
b7bfa855 119
5e2fff4a
SF
120package DebugWrap;
121
122sub new {
123 my $class = shift;
124
125 my $self = bless {}, $class;
126
127 $self->_init(@_);
128
129 return $self;
130}
131
132sub _cmds {
133 my $self = shift;
134
135 if (@_) {
136 $self->{_cmds} = shift;
137 }
138
139 return $self->{_cmds};
140}
141
142sub _prog {
143 my $self = shift;
144
145 if (@_) {
146 $self->{_prog} = shift;
147 }
148
149 return $self->{_prog};
150}
151
152sub _output {
153 my $self = shift;
154
155 if (@_) {
156 $self->{_output} = shift;
157 }
158
159 return $self->{_output};
160}
161
162sub _include_t
2211a10b 163{
5e2fff4a 164 my $self = shift;
2211a10b 165
5e2fff4a
SF
166 if (@_)
167 {
168 $self->{_include_t} = shift;
169 }
2211a10b 170
5e2fff4a 171 return $self->{_include_t};
2211a10b 172}
2211a10b 173
e931e533
SF
174sub _stderr_val
175{
176 my $self = shift;
177
178 if (@_)
179 {
180 $self->{_stderr_val} = shift;
181 }
182
183 return $self->{_stderr_val};
184}
185
186sub field
187{
188 my $self = shift;
189
190 if (@_)
191 {
192 $self->{field} = shift;
193 }
194
195 return $self->{field};
196}
b16615d5
SF
197
198sub _switches
199{
200 my $self = shift;
201
202 if (@_)
203 {
204 $self->{_switches} = shift;
205 }
206
207 return $self->{_switches};
208}
209
5e2fff4a
SF
210sub _contents
211{
212 my $self = shift;
2211a10b 213
5e2fff4a
SF
214 if (@_)
215 {
216 $self->{_contents} = shift;
217 }
218
219 return $self->{_contents};
2211a10b
SF
220}
221
5e2fff4a
SF
222sub _init
223{
224 my ($self, $args) = @_;
4cfe45a1 225
5e2fff4a
SF
226 my $cmds = $args->{cmds};
227
228 if (ref($cmds) ne 'ARRAY') {
229 die "cmds must be an array of commands.";
230 }
231
232 $self->_cmds($cmds);
233
234 my $prog = $args->{prog};
235
236 if (ref($prog) ne '' or !defined($prog)) {
237 die "prog should be a path to a program file.";
238 }
239
240 $self->_prog($prog);
241
242 $self->_include_t($args->{include_t} ? 1 : 0);
243
e931e533
SF
244 $self->_stderr_val(exists($args->{stderr}) ? $args->{stderr} : 1);
245
b16615d5
SF
246 if (exists($args->{switches}))
247 {
248 $self->_switches($args->{switches});
249 }
250
5e2fff4a
SF
251 $self->_run();
252
253 return;
254}
255
256sub _quote
e09195af 257{
5e2fff4a 258 my ($self, $str) = @_;
e09195af 259
5e2fff4a
SF
260 $str =~ s/(["\@\$\\])/\\$1/g;
261 $str =~ s/\n/\\n/g;
262 $str =~ s/\r/\\r/g;
263
264 return qq{"$str"};
265}
266
267sub _run {
268 my $self = shift;
269
24fc4d43 270 my $rc = qq{&parse_options("NonStop=0 TTY=db.out");\n};
5e2fff4a
SF
271
272 $rc .= join('',
273 map { "$_\n"}
274 (q#sub afterinit {#,
275 q#push (@DB::typeahead,#,
276 (map { $self->_quote($_) . "," } @{$self->_cmds()}),
277 q#);#,
278 q#}#,
279 )
e09195af
SF
280 );
281
5e2fff4a
SF
282 # I guess two objects like that cannot be used at the same time.
283 # Oh well.
284 ::rc($rc);
285
286 my $output =
287 ::runperl(
288 switches =>
289 [
b16615d5 290 ($self->_switches ? (@{$self->_switches()}) : ('-d')),
5e2fff4a
SF
291 ($self->_include_t ? ('-I', '../lib/perl5db/t') : ())
292 ],
e931e533
SF
293 (defined($self->_stderr_val())
294 ? (stderr => $self->_stderr_val())
295 : ()
296 ),
5e2fff4a
SF
297 progfile => $self->_prog()
298 );
299
300 $self->_output($output);
301
302 $self->_contents(::_out_contents());
303
304 return;
e09195af 305}
e09195af 306
20e060ce
SF
307sub get_output
308{
309 return shift->_output();
310}
311
5e2fff4a
SF
312sub output_like {
313 my ($self, $re, $msg) = @_;
314
315 local $::Level = $::Level + 1;
316 ::like($self->_output(), $re, $msg);
317}
318
72d7d80d
SF
319sub output_unlike {
320 my ($self, $re, $msg) = @_;
321
322 local $::Level = $::Level + 1;
323 ::unlike($self->_output(), $re, $msg);
324}
325
5e2fff4a
SF
326sub contents_like {
327 my ($self, $re, $msg) = @_;
328
329 local $::Level = $::Level + 1;
330 ::like($self->_contents(), $re, $msg);
331}
332
72d7d80d
SF
333sub contents_unlike {
334 my ($self, $re, $msg) = @_;
335
336 local $::Level = $::Level + 1;
337 ::unlike($self->_contents(), $re, $msg);
338}
339
5e2fff4a
SF
340package main;
341
708dd780
SF
342{
343 local $ENV{PERLDB_OPTS} = "ReadLine=0";
344 my $target = '../lib/perl5db/t/eval-line-bug';
345 my $wrapper = DebugWrap->new(
346 {
347 cmds =>
348 [
349 'b 23',
350 'n',
351 'n',
352 'n',
353 'c', # line 23
354 'n',
355 "p \@{'main::_<$target'}",
356 'q',
357 ],
358 prog => $target,
359 }
360 );
361 $wrapper->contents_like(
362 qr/sub factorial/,
363 'The ${main::_<filename} variable in the debugger was not destroyed',
364 );
365}
366
f0b5917d 367sub _calc_generic_wrapper
b2e270a3 368{
e931e533
SF
369 my $args = shift;
370
371 my $extra_opts = delete($args->{extra_opts});
5c976af9
SF
372 $extra_opts ||= '';
373 local $ENV{PERLDB_OPTS} = "ReadLine=0" . $extra_opts;
374 return DebugWrap->new(
b2e270a3 375 {
f0b5917d
SF
376 cmds => delete($args->{cmds}),
377 prog => delete($args->{prog}),
378 %$args,
379 }
380 );
381}
382
383sub _calc_new_var_wrapper
384{
385 my ($args) = @_;
386 return _calc_generic_wrapper(
387 {
b2e270a3
SF
388 cmds =>
389 [
390 'b 23',
e931e533 391 'c',
b2e270a3
SF
392 '$new_var = "Foo"',
393 'x "new_var = <$new_var>\\n"',
394 'q',
395 ],
e931e533 396 %$args,
b2e270a3
SF
397 }
398 );
5c976af9 399}
b2e270a3 400
12cb1cd2
SF
401sub _calc_threads_wrapper
402{
403 my $args = shift;
404
405 return _calc_new_var_wrapper(
406 {
407 switches => [ '-dt', ],
408 stderr => 1,
409 %$args
410 }
411 );
412}
413
5c976af9 414{
7cdb20ca 415 _calc_new_var_wrapper({ prog => '../lib/perl5db/t/eval-line-bug'})
5c976af9
SF
416 ->contents_like(
417 qr/new_var = <Foo>/,
418 "no strict 'vars' in evaluated lines.",
419 );
b2e270a3 420}
5c976af9 421
e931e533 422{
7cdb20ca 423 _calc_new_var_wrapper(
e931e533
SF
424 {
425 prog => '../lib/perl5db/t/lvalue-bug',
426 stderr => undef(),
427 },
428 )->output_like(
429 qr/foo is defined/,
430 'lvalue subs work in the debugger',
431 );
432}
433
8ebd940c 434{
7cdb20ca 435 _calc_new_var_wrapper(
8ebd940c
SF
436 {
437 prog => '../lib/perl5db/t/symbol-table-bug',
438 extra_opts => "NonStop=1",
439 stderr => undef(),
440 }
441 )->output_like(
442 qr/Undefined symbols 0/,
443 'there are no undefined values in the symbol table',
444 );
445}
446
b16615d5
SF
447SKIP:
448{
449 if ( $Config{usethreads} ) {
450 skip('This perl has threads, skipping non-threaded debugger tests');
451 }
452 else {
453 my $error = 'This Perl not built to support threads';
12cb1cd2 454 _calc_threads_wrapper(
b16615d5
SF
455 {
456 prog => '../lib/perl5db/t/eval-line-bug',
b16615d5
SF
457 }
458 )->output_like(
459 qr/\Q$error\E/,
460 'Perl debugger correctly complains that it was not built with threads',
461 );
462 }
463}
464
a9879eb8
SF
465SKIP:
466{
467 if ( $Config{usethreads} ) {
12cb1cd2 468 _calc_threads_wrapper(
a9879eb8
SF
469 {
470 prog => '../lib/perl5db/t/symbol-table-bug',
a9879eb8
SF
471 }
472 )->output_like(
473 qr/Undefined symbols 0/,
474 'there are no undefined values in the symbol table when running with thread support',
475 );
476 }
477 else {
478 skip("This perl is not threaded, skipping threaded debugger tests");
479 }
480}
481
31d5d77a
SF
482# Test [perl #61222]
483{
484 local $ENV{PERLDB_OPTS};
485 my $wrapper = DebugWrap->new(
486 {
487 cmds =>
488 [
489 'm Pie',
490 'q',
491 ],
492 prog => '../lib/perl5db/t/rt-61222',
493 }
494 );
495
496 $wrapper->contents_unlike(qr/INCORRECT/, "[perl #61222]");
497}
498
c698c518 499sub _calc_trace_wrapper
978684ed 500{
f0b5917d 501 my ($args) = @_;
978684ed 502
f0b5917d 503 return _calc_generic_wrapper(
978684ed
SF
504 {
505 cmds =>
506 [
507 't 2',
508 'c',
509 'q',
510 ],
978684ed
SF
511 %$args,
512 }
513 );
514}
515
516# [perl 104168] level option for tracing
517{
c698c518 518 my $wrapper = _calc_trace_wrapper({ prog => '../lib/perl5db/t/rt-104168' });
978684ed
SF
519 $wrapper->contents_like(qr/level 2/, "[perl #104168] - level 2 appears");
520 $wrapper->contents_unlike(qr/baz/, "[perl #104168] - no 'baz'");
521}
31d5d77a 522
20e060ce
SF
523# taint tests
524{
c698c518 525 my $wrapper = _calc_trace_wrapper(
20e060ce
SF
526 {
527 prog => '../lib/perl5db/t/taint',
528 extra_opts => ' NonStop=1',
529 switches => [ '-d', '-T', ],
530 }
531 );
532
533 my $output = $wrapper->get_output();
534 chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
535 is($output, '[$^X][done]', "taint");
536}
537
5e2fff4a
SF
538# Testing that we can set a line in the middle of the file.
539{
540 my $wrapper = DebugWrap->new(
541 {
542 cmds =>
543 [
544 'b ../lib/perl5db/t/MyModule.pm:12',
545 'c',
546 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
547 'c',
548 'q',
549 ],
550 include_t => 1,
551 prog => '../lib/perl5db/t/filename-line-breakpoint'
552 }
553 );
554
555 $wrapper->output_like(qr/
556 ^Var=Bar$
557 .*
558 ^In\ MyModule\.$
559 .*
560 ^In\ Main\ File\.$
561 .*
e09195af 562 /msx,
5e2fff4a 563 "Can set breakpoint in a line in the middle of the file.");
e09195af
SF
564}
565
5e2fff4a 566# Testing that we can set a breakpoint
e09195af 567{
5e2fff4a
SF
568 my $wrapper = DebugWrap->new(
569 {
570 prog => '../lib/perl5db/t/breakpoint-bug',
571 cmds =>
572 [
573 'b 6',
574 'c',
575 q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/,
576 'c',
577 'q',
578 ],
579 },
580 );
e09195af 581
5e2fff4a
SF
582 $wrapper->output_like(
583 qr/X=\{Two\}/msx,
584 "Can set breakpoint in a line."
585 );
586}
587
588# Testing that we can disable a breakpoint at a numeric line.
589{
590 my $wrapper = DebugWrap->new(
591 {
592 prog => '../lib/perl5db/t/disable-breakpoints-1',
593 cmds =>
594 [
595 'b 7',
596 'b 11',
597 'disable 7',
598 'c',
599 q/print "X={$x}\n";/,
600 'c',
601 'q',
602 ],
603 }
e09195af 604 );
b7bfa855 605
5e2fff4a
SF
606 $wrapper->output_like(qr/X=\{SecondVal\}/ms,
607 "Can set breakpoint in a line.");
e09195af 608}
e09195af 609
5e2fff4a
SF
610# Testing that we can re-enable a breakpoint at a numeric line.
611{
612 my $wrapper = DebugWrap->new(
613 {
614 prog => '../lib/perl5db/t/disable-breakpoints-2',
615 cmds =>
616 [
617 'b 8',
618 'b 24',
619 'disable 24',
620 'c',
621 'enable 24',
622 'c',
623 q/print "X={$x}\n";/,
624 'c',
625 'q',
626 ],
627 },
628 );
629
630 $wrapper->output_like(
631 qr/
e09195af
SF
632 X=\{SecondValOneHundred\}
633 /msx,
5e2fff4a
SF
634 "Can set breakpoint in a line."
635 );
e09195af 636}
635f2c9e
RGS
637# clean up.
638
e09195af
SF
639# Disable and enable for breakpoints on outer files.
640{
5e2fff4a
SF
641 my $wrapper = DebugWrap->new(
642 {
643 cmds =>
644 [
645 'b 10',
646 'b ../lib/perl5db/t/EnableModule.pm:14',
647 'disable ../lib/perl5db/t/EnableModule.pm:14',
648 'c',
649 'enable ../lib/perl5db/t/EnableModule.pm:14',
650 'c',
651 q/print "X={$x}\n";/,
652 'c',
653 'q',
654 ],
655 prog => '../lib/perl5db/t/disable-breakpoints-3',
656 include_t => 1,
657 }
e09195af
SF
658 );
659
5e2fff4a 660 $wrapper->output_like(qr/
e09195af
SF
661 X=\{SecondValTwoHundred\}
662 /msx,
663 "Can set breakpoint in a line.");
664}
bdba49ad
SF
665
666# Testing that the prompt with the information appears.
667{
5e2fff4a
SF
668 my $wrapper = DebugWrap->new(
669 {
670 cmds => ['q'],
671 prog => '../lib/perl5db/t/disable-breakpoints-1',
672 }
bdba49ad
SF
673 );
674
5e2fff4a 675 $wrapper->contents_like(qr/
bdba49ad
SF
676 ^main::\([^\)]*\bdisable-breakpoints-1:2\):\n
677 2:\s+my\ \$x\ =\ "One";\n
678 /msx,
679 "Prompt should display the first line of code.");
680}
681
682# Testing that R (restart) and "B *" work.
683{
5e2fff4a
SF
684 my $wrapper = DebugWrap->new(
685 {
686 cmds =>
687 [
688 'b 13',
689 'c',
690 'B *',
691 'b 9',
692 'R',
693 'c',
694 q/print "X={$x};dummy={$dummy}\n";/,
695 'q',
696 ],
697 prog => '../lib/perl5db/t/disable-breakpoints-1',
698 }
bdba49ad
SF
699 );
700
5e2fff4a 701 $wrapper->output_like(qr/
bdba49ad
SF
702 X=\{FirstVal\};dummy=\{1\}
703 /msx,
704 "Restart and delete all breakpoints work properly.");
705}
706
5d5d9ea3 707{
5e2fff4a
SF
708 my $wrapper = DebugWrap->new(
709 {
710 cmds =>
711 [
712 'c 15',
713 q/print "X={$x}\n";/,
714 'c',
715 'q',
716 ],
717 prog => '../lib/perl5db/t/disable-breakpoints-1',
718 }
5d5d9ea3
SF
719 );
720
5e2fff4a 721 $wrapper->output_like(qr/
5d5d9ea3
SF
722 X=\{ThirdVal\}
723 /msx,
724 "'c line_num' is working properly.");
725}
726
5343a617 727{
5e2fff4a
SF
728 my $wrapper = DebugWrap->new(
729 {
730 cmds =>
731 [
732 'n',
733 'n',
734 'b . $exp > 200',
735 'c',
736 q/print "Exp={$exp}\n";/,
737 'q',
738 ],
739 prog => '../lib/perl5db/t/break-on-dot',
740 }
5343a617 741 );
5343a617 742
5e2fff4a 743 $wrapper->output_like(qr/
5343a617
SF
744 Exp=\{256\}
745 /msx,
746 "'b .' is working correctly.");
747}
748
8dc67a69
SF
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
751{
5e2fff4a
SF
752 my $wrapper = DebugWrap->new(
753 {
754 cmds =>
755 [
756 'c back',
757 'q',
758 ],
759 prog => '../lib/perl5db/t/with-subroutine',
760 }
8dc67a69 761 );
8dc67a69 762
5e2fff4a 763 $wrapper->contents_like(
8dc67a69
SF
764 qr/
765 ^main::back\([^\)\n]*\bwith-subroutine:15\):[\ \t]*\n
766 ^15:\s*print\ "hello\ back\\n";
767 /msx,
768 "Prompt should display the line of code inside a subroutine.");
769}
770
984e0ec4
SF
771# Checking that the p command works.
772{
5e2fff4a
SF
773 my $wrapper = DebugWrap->new(
774 {
775 cmds =>
776 [
777 'p "<<<" . (4*6) . ">>>"',
778 'q',
779 ],
780 prog => '../lib/perl5db/t/with-subroutine',
781 }
984e0ec4
SF
782 );
783
5e2fff4a 784 $wrapper->contents_like(
984e0ec4
SF
785 qr/<<<24>>>/,
786 "p command works.");
787}
788
9f810cd7
SF
789# Tests for x.
790{
5e2fff4a
SF
791 my $wrapper = DebugWrap->new(
792 {
793 cmds =>
794 [
795 q/x {500 => 600}/,
796 'q',
797 ],
798 prog => '../lib/perl5db/t/with-subroutine',
799 }
9f810cd7
SF
800 );
801
5e2fff4a 802 $wrapper->contents_like(
9f810cd7
SF
803 # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
804 qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/ms,
805 "x command test."
806 );
807}
808
e3d167f6
SF
809# Tests for x with @_
810{
811 my $wrapper = DebugWrap->new(
812 {
813 cmds =>
814 [
815 'b 10',
816 'c',
817 'x @_',
818 'q',
819 ],
820 prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc',
821 }
822 );
823
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 '@_'./,
828 );
829}
830
e0cd3692
SF
831# Tests for mutating @_
832{
833 my $wrapper = DebugWrap->new(
834 {
835 cmds =>
836 [
837 'b 10',
838 'c',
839 'shift(@_)',
840 'print "\n\n\n(((" . join(",", @_) . ")))\n\n\n"',
841 'q',
842 ],
843 prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc',
844 }
845 );
846
847 $wrapper->output_like(
848 qr/^\(\(\(Capsula,GreekHumor,Socrates\)\)\)$/ms,
849 q/Mutating '@_'./,
850 );
851}
852
50acbf3b
SF
853# Tests for x with AutoTrace=1.
854{
855 my $wrapper = DebugWrap->new(
856 {
857 cmds =>
858 [
859 'n',
860 'o AutoTrace=1',
861 # So it may fail.
862 q/x "failure"/,
863 q/x \$x/,
864 'q',
865 ],
866 prog => '../lib/perl5db/t/with-subroutine',
867 }
868 );
869
870 $wrapper->contents_like(
871 # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
517cdf98 872 qr/^0\s+SCALAR\([^\)]+\)\n\s+-> 'hello world'\n/ms,
50acbf3b
SF
873 "x after AutoTrace=1 command is working."
874 );
875}
876
5bc17875
SF
877# Tests for "T" (stack trace).
878{
5bc17875 879 my $prog_fn = '../lib/perl5db/t/rt-104168';
5e2fff4a
SF
880 my $wrapper = DebugWrap->new(
881 {
882 prog => $prog_fn,
883 cmds =>
884 [
885 'c baz',
886 'T',
887 'q',
888 ],
889 }
890 );
5bc17875
SF
891 my $re_text = join('',
892 map {
893 sprintf(
894 "%s = %s\\(\\) called from file " .
895 "'" . quotemeta($prog_fn) . "' line %s\\n",
896 (map { quotemeta($_) } @$_)
897 )
2c247e84 898 }
5bc17875
SF
899 (
900 ['.', 'main::baz', 14,],
901 ['.', 'main::bar', 9,],
2c247e84 902 ['.', 'main::foo', 6],
5bc17875
SF
903 )
904 );
5e2fff4a 905 $wrapper->contents_like(
5bc17875
SF
906 # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
907 qr/^$re_text/ms,
908 "T command test."
909 );
910}
8fe891f1
SF
911
912# Test for s.
913{
5e2fff4a
SF
914 my $wrapper = DebugWrap->new(
915 {
916 cmds =>
917 [
918 'b 9',
919 'c',
920 's',
921 q/print "X={$x};dummy={$dummy}\n";/,
922 'q',
923 ],
924 prog => '../lib/perl5db/t/disable-breakpoints-1'
925 }
8fe891f1
SF
926 );
927
5e2fff4a 928 $wrapper->output_like(qr/
8fe891f1
SF
929 X=\{SecondVal\};dummy=\{1\}
930 /msx,
931 'test for s - single step',
932 );
933}
934
65ab0314 935{
5e2fff4a
SF
936 my $wrapper = DebugWrap->new(
937 {
938 cmds =>
939 [
940 'n',
941 'n',
942 'b . $exp > 200',
943 'c',
944 q/print "Exp={$exp}\n";/,
945 'q',
946 ],
947 prog => '../lib/perl5db/t/break-on-dot'
948 }
65ab0314
SF
949 );
950
5e2fff4a 951 $wrapper->output_like(qr/
65ab0314
SF
952 Exp=\{256\}
953 /msx,
954 "'b .' is working correctly.");
955}
956
957{
65ab0314 958 my $prog_fn = '../lib/perl5db/t/rt-104168';
5e2fff4a
SF
959 my $wrapper = DebugWrap->new(
960 {
961 cmds =>
962 [
963 's',
964 'q',
965 ],
966 prog => $prog_fn,
967 }
968 );
65ab0314 969
5e2fff4a 970 $wrapper->contents_like(
65ab0314
SF
971 qr/
972 ^main::foo\([^\)\n]*\brt-104168:9\):[\ \t]*\n
973 ^9:\s*bar\(\);
974 /msx,
975 'Test for the s command.',
976 );
977}
978
5d83cde2 979{
5e2fff4a
SF
980 my $wrapper = DebugWrap->new(
981 {
982 cmds =>
983 [
984 's uncalled_subroutine()',
985 'c',
986 'q',
987 ],
5d83cde2 988
5e2fff4a 989 prog => '../lib/perl5db/t/uncalled-subroutine'}
5d83cde2
SF
990 );
991
5e2fff4a 992 $wrapper->output_like(
5d83cde2
SF
993 qr/<1,2,3,4,5>\n/,
994 'uncalled_subroutine was called after s EXPR()',
995 );
5d83cde2
SF
996}
997
d7b8b95b 998{
5e2fff4a
SF
999 my $wrapper = DebugWrap->new(
1000 {
1001 cmds =>
1002 [
1003 'n uncalled_subroutine()',
1004 'c',
1005 'q',
1006 ],
1007 prog => '../lib/perl5db/t/uncalled-subroutine',
1008 }
d7b8b95b
SF
1009 );
1010
5e2fff4a 1011 $wrapper->output_like(
d7b8b95b
SF
1012 qr/<1,2,3,4,5>\n/,
1013 'uncalled_subroutine was called after n EXPR()',
1014 );
d7b8b95b
SF
1015}
1016
ea7bdd87
VP
1017{
1018 my $wrapper = DebugWrap->new(
1019 {
1020 cmds =>
1021 [
1022 'b fact',
1023 'c',
1024 'c',
1025 'c',
1026 'n',
1027 'print "<$n>"',
1028 'q',
1029 ],
1030 prog => '../lib/perl5db/t/fact',
1031 }
1032 );
1033
1034 $wrapper->output_like(
1035 qr/<3>/,
1036 'b subroutine works fine',
1037 );
1038}
1039
bf261418
FC
1040# Test for n with lvalue subs
1041DebugWrap->new({
1042 cmds =>
1043 [
e36e13a4
CB
1044 'n', 'print "<$x>\n"',
1045 'n', 'print "<$x>\n"',
bf261418
FC
1046 'q',
1047 ],
1048 prog => '../lib/perl5db/t/lsub-n',
1049})->output_like(
e36e13a4 1050 qr/<1>\n<11>\n/,
bf261418
FC
1051 'n steps over lvalue subs',
1052);
1053
f311474d
VP
1054# Test for 'M' (module list).
1055{
1056 my $wrapper = DebugWrap->new(
1057 {
1058 cmds =>
1059 [
1060 'M',
1061 'q',
1062 ],
1063 prog => '../lib/perl5db/t/load-modules'
1064 }
1065 );
1066
1067 $wrapper->contents_like(
1068 qr[Scalar/Util\.pm],
1069 'M (module list) works fine',
1070 );
1071}
1072
55783941
SF
1073{
1074 my $wrapper = DebugWrap->new(
1075 {
1076 cmds =>
1077 [
1078 'b 14',
1079 'c',
1080 '$flag = 1;',
1081 'r',
1082 'print "Var=$var\n";',
1083 'q',
1084 ],
1085 prog => '../lib/perl5db/t/test-r-statement',
1086 }
1087 );
1088
1089 $wrapper->output_like(
1090 qr/
1091 ^Foo$
1092 .*?
1093 ^Bar$
1094 .*?
1095 ^Var=Test$
1096 /msx,
1097 'r statement is working properly.',
1098 );
1099}
1100
1101{
1102 my $wrapper = DebugWrap->new(
1103 {
1104 cmds =>
1105 [
1106 'l',
1107 'q',
1108 ],
1109 prog => '../lib/perl5db/t/test-l-statement-1',
1110 }
1111 );
1112
1113 $wrapper->contents_like(
1114 qr/
1115 ^1==>\s+\$x\ =\ 1;\n
1116 2:\s+print\ "1\\n";\n
1117 3\s*\n
1118 4:\s+\$x\ =\ 2;\n
1119 5:\s+print\ "2\\n";\n
1120 /msx,
1121 'l statement is working properly (test No. 1).',
1122 );
1123}
1124
2c247e84
SF
1125{
1126 my $wrapper = DebugWrap->new(
1127 {
1128 cmds =>
1129 [
1130 'l',
1131 q/# After l 1/,
1132 'l',
1133 q/# After l 2/,
1134 '-',
1135 q/# After -/,
1136 'q',
1137 ],
1138 prog => '../lib/perl5db/t/test-l-statement-1',
1139 }
1140 );
1141
1142 my $first_l_out = qr/
1143 1==>\s+\$x\ =\ 1;\n
1144 2:\s+print\ "1\\n";\n
1145 3\s*\n
1146 4:\s+\$x\ =\ 2;\n
1147 5:\s+print\ "2\\n";\n
1148 6\s*\n
1149 7:\s+\$x\ =\ 3;\n
1150 8:\s+print\ "3\\n";\n
1151 9\s*\n
1152 10:\s+\$x\ =\ 4;\n
1153 /msx;
1154
1155 my $second_l_out = qr/
1156 11:\s+print\ "4\\n";\n
1157 12\s*\n
1158 13:\s+\$x\ =\ 5;\n
1159 14:\s+print\ "5\\n";\n
1160 15\s*\n
1161 16:\s+\$x\ =\ 6;\n
1162 17:\s+print\ "6\\n";\n
1163 18\s*\n
1164 19:\s+\$x\ =\ 7;\n
1165 20:\s+print\ "7\\n";\n
1166 /msx;
1167 $wrapper->contents_like(
1168 qr/
1169 ^$first_l_out
1170 [^\n]*?DB<\d+>\ \#\ After\ l\ 1\n
1171 [\ \t]*\n
1172 [^\n]*?DB<\d+>\ l\s*\n
1173 $second_l_out
1174 [^\n]*?DB<\d+>\ \#\ After\ l\ 2\n
1175 [\ \t]*\n
1176 [^\n]*?DB<\d+>\ -\s*\n
1177 $first_l_out
1178 [^\n]*?DB<\d+>\ \#\ After\ -\n
1179 /msx,
1180 'l followed by l and then followed by -',
1181 );
1182}
1183
1184{
1185 my $wrapper = DebugWrap->new(
1186 {
1187 cmds =>
1188 [
1189 'l fact',
1190 'q',
1191 ],
1192 prog => '../lib/perl5db/t/test-l-statement-2',
1193 }
1194 );
1195
1196 my $first_l_out = qr/
1197 6\s+sub\ fact\ \{\n
1198 7:\s+my\ \$n\ =\ shift;\n
1199 8:\s+if\ \(\$n\ >\ 1\)\ \{\n
1200 9:\s+return\ \$n\ \*\ fact\(\$n\ -\ 1\);
1201 /msx;
1202
1203 $wrapper->contents_like(
1204 qr/
1205 DB<1>\s+l\ fact\n
1206 $first_l_out
1207 /msx,
1208 'l subroutine_name',
1209 );
1210}
1211
1212{
1213 my $wrapper = DebugWrap->new(
1214 {
1215 cmds =>
1216 [
1217 'b fact',
1218 'c',
1219 # Repeat several times to avoid @typeahead problems.
1220 '.',
1221 '.',
1222 '.',
1223 '.',
1224 'q',
1225 ],
1226 prog => '../lib/perl5db/t/test-l-statement-2',
1227 }
1228 );
1229
1230 my $line_out = qr /
1231 ^main::fact\([^\n]*?:7\):\n
1232 ^7:\s+my\ \$n\ =\ shift;\n
1233 /msx;
1234
1235 $wrapper->contents_like(
1236 qr/
1237 $line_out
24fc4d43 1238 auto\(-\d+\)\s+DB<\d+>\s+\.\n
2c247e84
SF
1239 $line_out
1240 /msx,
1241 'Test the "." command',
1242 );
1243}
1244
1245# Testing that the f command works.
1246{
1247 my $wrapper = DebugWrap->new(
1248 {
1249 cmds =>
1250 [
1251 'f ../lib/perl5db/t/MyModule.pm',
1252 'b 12',
1253 'c',
1254 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
1255 'c',
1256 'q',
1257 ],
1258 include_t => 1,
1259 prog => '../lib/perl5db/t/filename-line-breakpoint'
1260 }
1261 );
1262
1263 $wrapper->output_like(qr/
1264 ^Var=Bar$
1265 .*
1266 ^In\ MyModule\.$
1267 .*
1268 ^In\ Main\ File\.$
1269 .*
1270 /msx,
1271 "f command is working.",
1272 );
1273}
1274
1275# We broke the /pattern/ command because apparently the CORE::eval-s inside
1276# lib/perl5db.pl cannot handle lexical variable properly. So we now fix this
1277# bug.
1278#
1279# TODO :
1280#
1281# 1. Go over the rest of the "eval"s in lib/perl5db.t and see if they cause
1282# problems.
1283{
1284 my $wrapper = DebugWrap->new(
1285 {
1286 cmds =>
1287 [
1288 '/for/',
1289 'q',
1290 ],
1291 prog => '../lib/perl5db/t/eval-line-bug',
1292 }
1293 );
1294
1295 $wrapper->contents_like(
1296 qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1297 "/pat/ command is working and found a match.",
1298 );
1299}
1300
1301{
1302 my $wrapper = DebugWrap->new(
1303 {
1304 cmds =>
1305 [
1306 'b 22',
1307 'c',
1308 '?for?',
1309 'q',
1310 ],
1311 prog => '../lib/perl5db/t/eval-line-bug',
1312 }
1313 );
1314
1315 $wrapper->contents_like(
1316 qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1317 "?pat? command is working and found a match.",
1318 );
1319}
1320
72d7d80d
SF
1321# Test the L command.
1322{
1323 my $wrapper = DebugWrap->new(
1324 {
1325 cmds =>
1326 [
1327 'b 6',
1328 'b 13 ($q == 5)',
1329 'L',
1330 'q',
1331 ],
1332 prog => '../lib/perl5db/t/eval-line-bug',
1333 }
1334 );
1335
1336 $wrapper->contents_like(
1337 qr#
1338 ^\S*?eval-line-bug:\n
1339 \s*6:\s*my\ \$i\ =\ 5;\n
1340 \s*break\ if\ \(1\)\n
1341 \s*13:\s*\$i\ \+=\ \$q;\n
1342 \s*break\ if\ \(\(\$q\ ==\ 5\)\)\n
1343 #msx,
1344 "L command is listing breakpoints",
1345 );
1346}
1347
1348# Test the L command for watch expressions.
1349{
1350 my $wrapper = DebugWrap->new(
1351 {
1352 cmds =>
1353 [
1354 'w (5+6)',
1355 'L',
1356 'q',
1357 ],
1358 prog => '../lib/perl5db/t/eval-line-bug',
1359 }
1360 );
1361
1362 $wrapper->contents_like(
1363 qr#
1364 ^Watch-expressions:\n
1365 \s*\(5\+6\)\n
1366 #msx,
1367 "L command is listing watch expressions",
1368 );
1369}
1370
1371{
1372 my $wrapper = DebugWrap->new(
1373 {
1374 cmds =>
1375 [
1376 'w (5+6)',
1377 'w (11*23)',
1378 'W (5+6)',
1379 'L',
1380 'q',
1381 ],
1382 prog => '../lib/perl5db/t/eval-line-bug',
1383 }
1384 );
1385
1386 $wrapper->contents_like(
1387 qr#
1388 ^Watch-expressions:\n
1389 \s*\(11\*23\)\n
1390 ^auto\(
1391 #msx,
1392 "L command is not listing deleted watch expressions",
1393 );
1394}
1395
1396# Test the L command.
1397{
1398 my $wrapper = DebugWrap->new(
1399 {
1400 cmds =>
1401 [
1402 'b 6',
1403 'a 13 print $i',
1404 'L',
1405 'q',
1406 ],
1407 prog => '../lib/perl5db/t/eval-line-bug',
1408 }
1409 );
1410
1411 $wrapper->contents_like(
1412 qr#
1413 ^\S*?eval-line-bug:\n
1414 \s*6:\s*my\ \$i\ =\ 5;\n
1415 \s*break\ if\ \(1\)\n
1416 \s*13:\s*\$i\ \+=\ \$q;\n
1417 \s*action:\s+print\ \$i\n
1418 #msx,
1419 "L command is listing actions and breakpoints",
1420 );
1421}
1422
1423{
1424 my $wrapper = DebugWrap->new(
1425 {
1426 cmds =>
1427 [
1428 'S',
1429 'q',
1430 ],
1431 prog => '../lib/perl5db/t/rt-104168',
1432 }
1433 );
1434
1435 $wrapper->contents_like(
1436 qr#
1437 ^main::bar\n
1438 main::baz\n
1439 main::foo\n
1440 #msx,
1441 "S command - 1",
1442 );
1443}
1444
1445{
1446 my $wrapper = DebugWrap->new(
1447 {
1448 cmds =>
1449 [
1450 'S ^main::ba',
1451 'q',
1452 ],
1453 prog => '../lib/perl5db/t/rt-104168',
1454 }
1455 );
1456
1457 $wrapper->contents_like(
1458 qr#
1459 ^main::bar\n
1460 main::baz\n
1461 auto\(
1462 #msx,
1463 "S command with regex",
1464 );
1465}
1466
1467{
1468 my $wrapper = DebugWrap->new(
1469 {
1470 cmds =>
1471 [
1472 'S !^main::ba',
1473 'q',
1474 ],
1475 prog => '../lib/perl5db/t/rt-104168',
1476 }
1477 );
1478
1479 $wrapper->contents_unlike(
1480 qr#
1481 ^main::ba
1482 #msx,
1483 "S command with negative regex",
1484 );
1485
1486 $wrapper->contents_like(
1487 qr#
1488 ^main::foo\n
1489 #msx,
1490 "S command with negative regex - what it still matches",
1491 );
1492}
1493
f4beae36 1494# Test the 'a' command.
72d7d80d
SF
1495{
1496 my $wrapper = DebugWrap->new(
1497 {
1498 cmds =>
1499 [
1500 'a 13 print "\nVar<Q>=$q\n"',
1501 'c',
1502 'q',
1503 ],
1504 prog => '../lib/perl5db/t/eval-line-bug',
1505 }
1506 );
1507
f3310455 1508 my $nl = $^O eq 'VMS' ? "" : "\\\n";
72d7d80d 1509 $wrapper->output_like(qr#
f3310455
TC
1510 \nVar<Q>=1$nl
1511 \nVar<Q>=2$nl
1512 \nVar<Q>=3
72d7d80d
SF
1513 #msx,
1514 "a command is working",
1515 );
1516}
1517
f4beae36
SF
1518# Test the 'a' command with no line number.
1519{
1520 my $wrapper = DebugWrap->new(
1521 {
1522 cmds =>
1523 [
1524 'n',
1525 q/a print "Hello " . (3 * 4) . "\n";/,
1526 'c',
1527 'q',
1528 ],
1529 prog => '../lib/perl5db/t/test-a-statement-1',
1530 }
1531 );
1532
1533 $wrapper->output_like(qr#
1534 (?:^Hello\ 12\n.*?){4}
1535 #msx,
1536 "a command with no line number is working",
1537 );
1538}
1539
72d7d80d
SF
1540# Test the 'A' command
1541{
1542 my $wrapper = DebugWrap->new(
1543 {
1544 cmds =>
1545 [
1546 'a 13 print "\nVar<Q>=$q\n"',
1547 'A 13',
1548 'c',
1549 'q',
1550 ],
1551 prog => '../lib/perl5db/t/eval-line-bug',
1552 }
1553 );
1554
1555 $wrapper->output_like(
1556 qr#\A\z#msx, # The empty string.
1557 "A command (for removing actions) is working",
1558 );
1559}
1560
1561# Test the 'A *' command
1562{
1563 my $wrapper = DebugWrap->new(
1564 {
1565 cmds =>
1566 [
1567 'a 6 print "\nFail!\n"',
1568 'a 13 print "\nVar<Q>=$q\n"',
1569 'A *',
1570 'c',
1571 'q',
1572 ],
1573 prog => '../lib/perl5db/t/eval-line-bug',
1574 }
1575 );
1576
1577 $wrapper->output_like(
1578 qr#\A\z#msx, # The empty string.
1579 "'A *' command (for removing all actions) is working",
1580 );
1581}
1582
1583{
1584 my $wrapper = DebugWrap->new(
1585 {
1586 cmds =>
1587 [
1588 'n',
1589 'w $foo',
1590 'c',
1591 'print "\nIDX=<$idx>\n"',
1592 'q',
1593 ],
1594 prog => '../lib/perl5db/t/test-w-statement-1',
1595 }
1596 );
1597
1598
1599 $wrapper->contents_like(qr#
1600 \$foo\ changed:\n
1601 \s+old\ value:\s+'1'\n
1602 \s+new\ value:\s+'2'\n
1603 #msx,
1604 'w command - watchpoint changed',
1605 );
1606 $wrapper->output_like(qr#
1607 \nIDX=<20>\n
1608 #msx,
1609 "w command - correct output from IDX",
1610 );
1611}
1612
1613{
1614 my $wrapper = DebugWrap->new(
1615 {
1616 cmds =>
1617 [
1618 'n',
1619 'w $foo',
1620 'W $foo',
1621 'c',
1622 'print "\nIDX=<$idx>\n"',
1623 'q',
1624 ],
1625 prog => '../lib/perl5db/t/test-w-statement-1',
1626 }
1627 );
1628
1629 $wrapper->contents_unlike(qr#
1630 \$foo\ changed:
1631 #msx,
1632 'W command - watchpoint was deleted',
1633 );
1634
1635 $wrapper->output_like(qr#
1636 \nIDX=<>\n
1637 #msx,
1638 "W command - stopped at end.",
1639 );
1640}
1641
1642# Test the W * command.
1643{
1644 my $wrapper = DebugWrap->new(
1645 {
1646 cmds =>
1647 [
1648 'n',
1649 'w $foo',
1650 'w ($foo*$foo)',
1651 'W *',
1652 'c',
1653 'print "\nIDX=<$idx>\n"',
1654 'q',
1655 ],
1656 prog => '../lib/perl5db/t/test-w-statement-1',
1657 }
1658 );
1659
1660 $wrapper->contents_unlike(qr#
1661 \$foo\ changed:
1662 #msx,
1663 '"W *" command - watchpoint was deleted',
1664 );
1665
1666 $wrapper->output_like(qr#
1667 \nIDX=<>\n
1668 #msx,
1669 '"W *" command - stopped at end.',
1670 );
1671}
1672
1673# Test the 'o' command (without further arguments).
1674{
1675 my $wrapper = DebugWrap->new(
1676 {
1677 cmds =>
1678 [
1679 'o',
1680 'q',
1681 ],
1682 prog => '../lib/perl5db/t/test-w-statement-1',
1683 }
1684 );
1685
1686 $wrapper->contents_like(qr#
1687 ^\s*warnLevel\ =\ '1'\n
1688 #msx,
1689 q#"o" command (without arguments) displays warnLevel#,
1690 );
1691
1692 $wrapper->contents_like(qr#
1693 ^\s*signalLevel\ =\ '1'\n
1694 #msx,
1695 q#"o" command (without arguments) displays signalLevel#,
1696 );
1697
1698 $wrapper->contents_like(qr#
1699 ^\s*dieLevel\ =\ '1'\n
1700 #msx,
1701 q#"o" command (without arguments) displays dieLevel#,
1702 );
1703
1704 $wrapper->contents_like(qr#
1705 ^\s*hashDepth\ =\ 'N/A'\n
1706 #msx,
1707 q#"o" command (without arguments) displays hashDepth#,
1708 );
1709}
1710
1711# Test the 'o' query command.
1712{
1713 my $wrapper = DebugWrap->new(
1714 {
1715 cmds =>
1716 [
1717 'o hashDepth? signalLevel?',
1718 'q',
1719 ],
1720 prog => '../lib/perl5db/t/test-w-statement-1',
1721 }
1722 );
1723
1724 $wrapper->contents_unlike(qr#warnLevel#,
1725 q#"o" query command does not display warnLevel#,
1726 );
1727
1728 $wrapper->contents_like(qr#
1729 ^\s*signalLevel\ =\ '1'\n
1730 #msx,
1731 q#"o" query command displays signalLevel#,
1732 );
1733
1734 $wrapper->contents_unlike(qr#dieLevel#,
1735 q#"o" query command does not display dieLevel#,
1736 );
1737
1738 $wrapper->contents_like(qr#
1739 ^\s*hashDepth\ =\ 'N/A'\n
1740 #msx,
1741 q#"o" query command displays hashDepth#,
1742 );
1743}
1744
1745# Test the 'o' set command.
1746{
1747 my $wrapper = DebugWrap->new(
1748 {
1749 cmds =>
1750 [
1751 'o signalLevel=0',
1752 'o',
1753 'q',
1754 ],
1755 prog => '../lib/perl5db/t/test-w-statement-1',
1756 }
1757 );
1758
1759 $wrapper->contents_like(qr/
1760 ^\s*(signalLevel\ =\ '0'\n)
1761 .*?
1762 ^\s*\1
1763 /msx,
1764 q#o set command works#,
1765 );
1766
1767 $wrapper->contents_like(qr#
1768 ^\s*hashDepth\ =\ 'N/A'\n
1769 #msx,
1770 q#o set command - hashDepth#,
1771 );
1772}
1773
1774# Test the '<' and "< ?" commands.
1775{
1776 my $wrapper = DebugWrap->new(
1777 {
1778 cmds =>
1779 [
1780 q/< print "\nX=<$x>\n"/,
1781 q/b 7/,
1782 q/< ?/,
1783 'c',
1784 'q',
1785 ],
1786 prog => '../lib/perl5db/t/disable-breakpoints-1',
1787 }
1788 );
1789
1790 $wrapper->contents_like(qr/
1791 ^pre-perl\ commands:\n
1792 \s*<\ --\ print\ "\\nX=<\$x>\\n"\n
1793 /msx,
1794 q#Test < and < ? commands - contents.#,
1795 );
1796
1797 $wrapper->output_like(qr#
1798 ^X=<FirstVal>\n
1799 #msx,
1800 q#Test < and < ? commands - output.#,
1801 );
1802}
1803
1804# Test the '< *' command.
1805{
1806 my $wrapper = DebugWrap->new(
1807 {
1808 cmds =>
1809 [
1810 q/< print "\nX=<$x>\n"/,
1811 q/b 7/,
1812 q/< */,
1813 'c',
1814 'q',
1815 ],
1816 prog => '../lib/perl5db/t/disable-breakpoints-1',
1817 }
1818 );
1819
1820 $wrapper->output_unlike(qr/FirstVal/,
1821 q#Test the '< *' command.#,
1822 );
1823}
1824
1825# Test the '>' and "> ?" commands.
1826{
1827 my $wrapper = DebugWrap->new(
1828 {
1829 cmds =>
1830 [
1831 q/$::foo = 500;/,
1832 q/> print "\nFOO=<$::foo>\n"/,
1833 q/b 7/,
1834 q/> ?/,
1835 'c',
1836 'q',
1837 ],
1838 prog => '../lib/perl5db/t/disable-breakpoints-1',
1839 }
1840 );
1841
1842 $wrapper->contents_like(qr/
1843 ^post-perl\ commands:\n
1844 \s*>\ --\ print\ "\\nFOO=<\$::foo>\\n"\n
1845 /msx,
1846 q#Test > and > ? commands - contents.#,
1847 );
1848
1849 $wrapper->output_like(qr#
1850 ^FOO=<500>\n
1851 #msx,
1852 q#Test > and > ? commands - output.#,
1853 );
1854}
1855
1856# Test the '> *' command.
1857{
1858 my $wrapper = DebugWrap->new(
1859 {
1860 cmds =>
1861 [
1862 q/> print "\nFOO=<$::foo>\n"/,
1863 q/b 7/,
1864 q/> */,
1865 'c',
1866 'q',
1867 ],
1868 prog => '../lib/perl5db/t/disable-breakpoints-1',
1869 }
1870 );
1871
1872 $wrapper->output_unlike(qr/FOO=/,
1873 q#Test the '> *' command.#,
1874 );
1875}
1876
be1dfd82
SF
1877# Test the < and > commands together
1878{
1879 my $wrapper = DebugWrap->new(
1880 {
1881 cmds =>
1882 [
1883 q/$::lorem = 0;/,
1884 q/< $::lorem += 10;/,
1885 q/> print "\nLOREM=<$::lorem>\n"/,
1886 q/b 7/,
1887 q/b 5/,
1888 'c',
1889 'c',
1890 'q',
1891 ],
1892 prog => '../lib/perl5db/t/disable-breakpoints-1',
1893 }
1894 );
1895
1896 $wrapper->output_like(qr#
1897 ^LOREM=<10>\n
1898 #msx,
1899 q#Test < and > commands. #,
1900 );
1901}
1902
95418017
SF
1903# Test the { ? and { [command] commands.
1904{
1905 my $wrapper = DebugWrap->new(
1906 {
1907 cmds =>
1908 [
1e121f70
SF
1909 '{ ?',
1910 '{ l',
1911 '{ ?',
95418017
SF
1912 q/b 5/,
1913 q/c/,
1914 q/q/,
1915 ],
1916 prog => '../lib/perl5db/t/disable-breakpoints-1',
1917 }
1918 );
1919
1920 $wrapper->contents_like(qr#
1921 ^No\ pre-debugger\ actions\.\n
1922 .*?
1923 ^pre-debugger\ commands:\n
1924 \s+\{\ --\ l\n
1925 .*?
1926 ^5==>b\s+\$x\ =\ "FirstVal";\n
1927 6\s*\n
1928 7:\s+\$dummy\+\+;\n
1929 8\s*\n
1930 9:\s+\$x\ =\ "SecondVal";\n
1931
1932 #msx,
1933 'Test the pre-prompt debugger commands',
1934 );
1935}
1936
3743412c
SF
1937# Test the { * command.
1938{
1939 my $wrapper = DebugWrap->new(
1940 {
1941 cmds =>
1942 [
1943 '{ q',
1944 '{ *',
1945 q/b 5/,
1946 q/c/,
1947 q/print (("One" x 5), "\n");/,
1948 q/q/,
1949 ],
1950 prog => '../lib/perl5db/t/disable-breakpoints-1',
1951 }
1952 );
1953
1954 $wrapper->contents_like(qr#
1955 ^All\ \{\ actions\ cleared\.\n
1956 #msx,
1957 'Test the { * command',
1958 );
1959
1960 $wrapper->output_like(qr/OneOneOneOneOne/,
1961 '{ * test - output is OK.',
1962 );
1963}
1964
1896f514
SF
1965# Test the ! command.
1966{
1967 my $wrapper = DebugWrap->new(
1968 {
1969 cmds =>
1970 [
1971 'l 3-5',
1972 '!',
1973 'q',
1974 ],
1975 prog => '../lib/perl5db/t/disable-breakpoints-1',
1976 }
1977 );
1978
1979 $wrapper->contents_like(qr#
1980 (^3:\s+my\ \$dummy\ =\ 0;\n
1981 4\s*\n
1982 5:\s+\$x\ =\ "FirstVal";)\n
1983 .*?
1984 ^l\ 3-5\n
1985 \1
1986 #msx,
1987 'Test the ! command (along with l 3-5)',
1988 );
1989}
1990
ada05bfe
SF
1991# Test the ! -number command.
1992{
1993 my $wrapper = DebugWrap->new(
1994 {
1995 cmds =>
1996 [
1997 'l 3-5',
1998 'l 2',
1999 '! -1',
2000 'q',
2001 ],
2002 prog => '../lib/perl5db/t/disable-breakpoints-1',
2003 }
2004 );
2005
2006 $wrapper->contents_like(qr#
2007 (^3:\s+my\ \$dummy\ =\ 0;\n
2008 4\s*\n
2009 5:\s+\$x\ =\ "FirstVal";)\n
2010 .*?
2011 ^2==\>\s+my\ \$x\ =\ "One";\n
2012 .*?
2013 ^l\ 3-5\n
2014 \1
2015 #msx,
2016 'Test the ! -n command (along with l)',
2017 );
2018}
2019
5442f949
SF
2020# Test the 'source' command.
2021{
2022 my $wrapper = DebugWrap->new(
2023 {
2024 cmds =>
2025 [
2026 'source ../lib/perl5db/t/source-cmd-test.perldb',
2027 # If we have a 'q' here, then the typeahead will override the
2028 # input, and so it won't be reached - solution:
2029 # put a q inside the .perldb commands.
2030 # ( This may be a bug or a misfeature. )
2031 ],
2032 prog => '../lib/perl5db/t/disable-breakpoints-1',
2033 }
2034 );
2035
2036 $wrapper->contents_like(qr#
2037 ^3:\s+my\ \$dummy\ =\ 0;\n
2038 4\s*\n
2039 5:\s+\$x\ =\ "FirstVal";\n
2040 6\s*\n
2041 7:\s+\$dummy\+\+;\n
2042 8\s*\n
2043 9:\s+\$x\ =\ "SecondVal";\n
2044 10\s*\n
2045 #msx,
2046 'Test the source command (along with l)',
2047 );
35879b90
SF
2048}
2049
2050# Test the 'source' command being traversed from withing typeahead.
2051{
2052 my $wrapper = DebugWrap->new(
2053 {
2054 cmds =>
2055 [
2056 'source ../lib/perl5db/t/source-cmd-test-no-q.perldb',
2057 'q',
2058 ],
2059 prog => '../lib/perl5db/t/disable-breakpoints-1',
2060 }
2061 );
5442f949 2062
35879b90
SF
2063 $wrapper->contents_like(qr#
2064 ^3:\s+my\ \$dummy\ =\ 0;\n
2065 4\s*\n
2066 5:\s+\$x\ =\ "FirstVal";\n
2067 6\s*\n
2068 7:\s+\$dummy\+\+;\n
2069 8\s*\n
2070 9:\s+\$x\ =\ "SecondVal";\n
2071 10\s*\n
2072 #msx,
2073 'Test the source command inside a typeahead',
2074 );
5442f949
SF
2075}
2076
741f88f9
SF
2077# Test the 'H -number' command.
2078{
2079 my $wrapper = DebugWrap->new(
2080 {
2081 cmds =>
2082 [
2083 'l 1-10',
2084 'l 5-10',
2085 'x "Hello World"',
2086 'l 1-5',
2087 'b 3',
2088 'x (20+4)',
2089 'H -7',
2090 'q',
2091 ],
2092 prog => '../lib/perl5db/t/disable-breakpoints-1',
2093 }
2094 );
2095
2096 $wrapper->contents_like(qr#
2097 ^\d+:\s+H\ -7\n
2098 \d+:\s+x\ \(20\+4\)\n
2099 \d+:\s+b\ 3\n
2100 \d+:\s+l\ 1-5\n
2101 \d+:\s+x\ "Hello\ World"\n
2102 \d+:\s+l\ 5-10\n
2103 \d+:\s+l\ 1-10\n
2104 #msx,
6bf7e1ad 2105 'Test the H -num command',
741f88f9
SF
2106 );
2107}
2108
761ec47e
SF
2109# Add a test for H (without arguments)
2110{
2111 my $wrapper = DebugWrap->new(
2112 {
2113 cmds =>
2114 [
2115 'l 1-10',
2116 'l 5-10',
2117 'x "Hello World"',
2118 'l 1-5',
2119 'b 3',
2120 'x (20+4)',
2121 'H',
2122 'q',
2123 ],
2124 prog => '../lib/perl5db/t/disable-breakpoints-1',
2125 }
2126 );
2127
2128 $wrapper->contents_like(qr#
2129 ^\d+:\s+x\ \(20\+4\)\n
2130 \d+:\s+b\ 3\n
2131 \d+:\s+l\ 1-5\n
2132 \d+:\s+x\ "Hello\ World"\n
2133 \d+:\s+l\ 5-10\n
2134 \d+:\s+l\ 1-10\n
2135 #msx,
6bf7e1ad 2136 'Test the H command (without a number.)',
761ec47e
SF
2137 );
2138}
2139
088a867e
SF
2140{
2141 my $wrapper = DebugWrap->new(
2142 {
2143 cmds =>
2144 [
2145 '= quit q',
2146 '= foobar l',
2147 'foobar',
2148 'quit',
2149 ],
2150 prog => '../lib/perl5db/t/test-l-statement-1',
2151 }
2152 );
2153
2154 $wrapper->contents_like(
2155 qr/
2156 ^1==>\s+\$x\ =\ 1;\n
2157 2:\s+print\ "1\\n";\n
2158 3\s*\n
2159 4:\s+\$x\ =\ 2;\n
2160 5:\s+print\ "2\\n";\n
2161 /msx,
2162 'Test the = (command alias) command.',
2163 );
2164}
2165
fedbbdd5 2166# Test the m statement.
12f1669f
SF
2167{
2168 my $wrapper = DebugWrap->new(
2169 {
2170 cmds =>
2171 [
2172 'm main',
2173 'q',
2174 ],
2175 prog => '../lib/perl5db/t/disable-breakpoints-1',
2176 }
2177 );
2178
2179 $wrapper->contents_like(qr#
2180 ^via\ UNIVERSAL:\ DOES$
2181 #msx,
2182 "Test m for main - 1",
2183 );
2184
2185 $wrapper->contents_like(qr#
2186 ^via\ UNIVERSAL:\ can$
2187 #msx,
2188 "Test m for main - 2",
2189 );
2190}
2191
fedbbdd5
SF
2192# Test the m statement.
2193{
2194 my $wrapper = DebugWrap->new(
2195 {
2196 cmds =>
2197 [
2198 'b 41',
2199 'c',
2200 'm $obj',
2201 'q',
2202 ],
2203 prog => '../lib/perl5db/t/test-m-statement-1',
2204 }
2205 );
2206
2207 $wrapper->contents_like(qr#^greet$#ms,
2208 "Test m for obj - 1",
2209 );
2210
2211 $wrapper->contents_like(qr#^via UNIVERSAL: can$#ms,
2212 "Test m for obj - 1",
2213 );
2214}
2215
2bceee64
SF
2216# Test the M command.
2217{
2218 my $wrapper = DebugWrap->new(
2219 {
2220 cmds =>
2221 [
2222 'M',
2223 'q',
2224 ],
2225 prog => '../lib/perl5db/t/test-m-statement-1',
2226 }
2227 );
2228
2229 $wrapper->contents_like(qr#
2230 ^'strict\.pm'\ =>\ '\d+\.\d+\ from
2231 #msx,
2232 "Test M",
2233 );
2234
2235}
2236
8b842515
SF
2237# Test the recallCommand option.
2238{
2239 my $wrapper = DebugWrap->new(
2240 {
2241 cmds =>
2242 [
2243 'o recallCommand=%',
2244 'l 3-5',
2245 'l 2',
2246 '% -1',
2247 'q',
2248 ],
2249 prog => '../lib/perl5db/t/disable-breakpoints-1',
2250 }
2251 );
2252
2253 $wrapper->contents_like(qr#
2254 (^3:\s+my\ \$dummy\ =\ 0;\n
2255 4\s*\n
2256 5:\s+\$x\ =\ "FirstVal";)\n
2257 .*?
2258 ^2==\>\s+my\ \$x\ =\ "One";\n
2259 .*?
2260 ^l\ 3-5\n
2261 \1
2262 #msx,
2263 'Test the o recallCommand option',
2264 );
2265}
b705c774
SF
2266
2267# Test the dieLevel option
2268{
2269 my $wrapper = DebugWrap->new(
2270 {
2271 cmds =>
2272 [
2273 q/o dieLevel='1'/,
2274 q/c/,
2275 'q',
2276 ],
2277 prog => '../lib/perl5db/t/test-dieLevel-option-1',
2278 }
2279 );
2280
2281 $wrapper->output_like(qr#
f3310455 2282 ^This\ program\ dies\.\ at\ \S+\ line\ 18\N*\.\n
b705c774
SF
2283 .*?
2284 ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
2285 \s+main::bar\(\)\ called\ at\ \S+\ line\ 7\n
2286 \s+main::foo\(\)\ called\ at\ \S+\ line\ 21\n
2287 #msx,
2288 'Test the o dieLevel option',
2289 );
2290}
2291
ca3d9398
SF
2292# Test the warnLevel option
2293{
2294 my $wrapper = DebugWrap->new(
2295 {
2296 cmds =>
2297 [
2298 q/o warnLevel='1'/,
2299 q/c/,
2300 'q',
2301 ],
2302 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2303 }
2304 );
2305
2306 $wrapper->contents_like(qr#
f3310455 2307 ^This\ is\ not\ a\ warning\.\ at\ \S+\ line\ 18\N*\.\n
ca3d9398
SF
2308 .*?
2309 ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
2310 \s+main::bar\(\)\ called\ at\ \S+\ line\ 25\n
2311 \s+main::myfunc\(\)\ called\ at\ \S+\ line\ 28\n
2312 #msx,
2313 'Test the o warnLevel option',
2314 );
2315}
2316
742c59c5
SF
2317# Test the t command
2318{
2319 my $wrapper = DebugWrap->new(
2320 {
2321 cmds =>
2322 [
2323 't',
2324 'c',
2325 'q',
2326 ],
2327 prog => '../lib/perl5db/t/disable-breakpoints-1',
2328 }
2329 );
2330
2331 $wrapper->contents_like(qr/
2332 ^main::\([^:]+:15\):\n
2333 15:\s+\$dummy\+\+;\n
2334 main::\([^:]+:17\):\n
2335 17:\s+\$x\ =\ "FourthVal";\n
2336 /msx,
2337 'Test the t command (without a number.)',
2338 );
2339}
2340
3d02bfa8
SF
2341# Test the o AutoTrace command
2342{
2343 my $wrapper = DebugWrap->new(
2344 {
2345 cmds =>
2346 [
2347 'o AutoTrace',
2348 'c',
2349 'q',
2350 ],
2351 prog => '../lib/perl5db/t/disable-breakpoints-1',
2352 }
2353 );
2354
2355 $wrapper->contents_like(qr/
2356 ^main::\([^:]+:15\):\n
2357 15:\s+\$dummy\+\+;\n
2358 main::\([^:]+:17\):\n
2359 17:\s+\$x\ =\ "FourthVal";\n
2360 /msx,
2361 'Test the o AutoTrace command',
2362 );
2363}
2364
f910787d
SF
2365# Test the t command with function calls
2366{
2367 my $wrapper = DebugWrap->new(
2368 {
2369 cmds =>
2370 [
2371 't',
2372 'b 18',
2373 'c',
2374 'x ["foo"]',
2375 'x ["bar"]',
2376 'q',
2377 ],
2378 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2379 }
2380 );
2381
2382 $wrapper->contents_like(qr/
2383 ^main::\([^:]+:28\):\n
2384 28:\s+myfunc\(\);\n
24fc4d43
TC
2385 auto\(-\d+\)\s+DB<1>\s+t\n
2386 Trace\ =\ on\n
2387 auto\(-\d+\)\s+DB<1>\s+b\ 18\n
2388 auto\(-\d+\)\s+DB<2>\s+c\n
f910787d
SF
2389 main::myfunc\([^:]+:25\):\n
2390 25:\s+bar\(\);\n
2391 /msx,
2392 'Test the t command with function calls.',
2393 );
2394}
2395
5e2b42dd
SF
2396# Test the o AutoTrace command with function calls
2397{
2398 my $wrapper = DebugWrap->new(
2399 {
2400 cmds =>
2401 [
2402 'o AutoTrace',
2403 'b 18',
2404 'c',
2405 'x ["foo"]',
2406 'x ["bar"]',
2407 'q',
2408 ],
2409 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2410 }
2411 );
2412
2413 $wrapper->contents_like(qr/
2414 ^main::\([^:]+:28\):\n
2415 28:\s+myfunc\(\);\n
24fc4d43
TC
2416 auto\(-\d+\)\s+DB<1>\s+o\ AutoTrace\n
2417 \s+AutoTrace\s+=\s+'1'\n
2418 auto\(-\d+\)\s+DB<2>\s+b\ 18\n
2419 auto\(-\d+\)\s+DB<3>\s+c\n
5e2b42dd
SF
2420 main::myfunc\([^:]+:25\):\n
2421 25:\s+bar\(\);\n
2422 /msx,
24fc4d43 2423 'Test the o AutoTrace command with function calls.',
5e2b42dd
SF
2424 );
2425}
7d9a5afb 2426
ef6abee5
SF
2427# Test the final message.
2428{
2429 my $wrapper = DebugWrap->new(
2430 {
2431 cmds =>
2432 [
2433 'c',
2434 'q',
2435 ],
2436 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2437 }
2438 );
2439
2440 $wrapper->contents_like(qr/
2441 ^Debugged\ program\ terminated\.
2442 /msx,
2443 'Test the final "Debugged program terminated" message.',
2444 );
2445}
2446
7d9a5afb
SF
2447# Test the o inhibit_exit=0 command
2448{
2449 my $wrapper = DebugWrap->new(
2450 {
2451 cmds =>
2452 [
2453 'o inhibit_exit=0',
2454 'n',
2455 'n',
2456 'n',
2457 'n',
2458 'q',
2459 ],
2460 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2461 }
2462 );
2463
2464 $wrapper->contents_unlike(qr/
2465 ^Debugged\ program\ terminated\.
2466 /msx,
2467 'Test the o inhibit_exit=0 command.',
2468 );
2469}
2470
4f7c5654 2471# Test the o PrintRet=1 option
413b1248
SF
2472{
2473 my $wrapper = DebugWrap->new(
2474 {
2475 cmds =>
2476 [
2477 'o PrintRet=1',
2478 'b 29',
2479 'c',
2480 q/$x = 's';/,
2481 'b 10',
2482 'c',
2483 'r',
2484 'q',
2485 ],
2486 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2487 }
2488 );
2489
2490 $wrapper->contents_like(
2491 qr/scalar context return from main::return_scalar: 20024/,
2492 "Test o PrintRet=1",
2493 );
2494}
2495
4f7c5654
SF
2496# Test the o PrintRet=0 option
2497{
2498 my $wrapper = DebugWrap->new(
2499 {
2500 cmds =>
2501 [
2502 'o PrintRet=0',
2503 'b 29',
2504 'c',
2505 q/$x = 's';/,
2506 'b 10',
2507 'c',
2508 'r',
2509 'q',
2510 ],
2511 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2512 }
2513 );
2514
2515 $wrapper->contents_unlike(
2516 qr/scalar context/,
2517 "Test o PrintRet=0",
2518 );
2519}
2520
855abc47
SF
2521# Test the o PrintRet=1 option in list context
2522{
2523 my $wrapper = DebugWrap->new(
2524 {
2525 cmds =>
2526 [
2527 'o PrintRet=1',
2528 'b 29',
2529 'c',
2530 q/$x = 'l';/,
2531 'b 17',
2532 'c',
2533 'r',
2534 'q',
2535 ],
2536 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2537 }
2538 );
2539
2540 $wrapper->contents_like(
2541 qr/list context return from main::return_list:\n0\s*'Foo'\n1\s*'Bar'\n2\s*'Baz'\n/,
2542 "Test o PrintRet=1 in list context",
2543 );
2544}
2545
d728fe0e
SF
2546# Test the o PrintRet=0 option in list context
2547{
2548 my $wrapper = DebugWrap->new(
2549 {
2550 cmds =>
2551 [
2552 'o PrintRet=0',
2553 'b 29',
2554 'c',
2555 q/$x = 'l';/,
2556 'b 17',
2557 'c',
2558 'r',
2559 'q',
2560 ],
2561 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2562 }
2563 );
2564
2565 $wrapper->contents_unlike(
2566 qr/list context/,
2567 "Test o PrintRet=0 in list context",
2568 );
2569}
2570
c8dcbe9b
SF
2571# Test the o PrintRet=1 option in void context
2572{
2573 my $wrapper = DebugWrap->new(
2574 {
2575 cmds =>
2576 [
2577 'o PrintRet=1',
2578 'b 29',
2579 'c',
2580 q/$x = 'v';/,
2581 'b 24',
2582 'c',
2583 'r',
2584 'q',
2585 ],
2586 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2587 }
2588 );
2589
2590 $wrapper->contents_like(
2591 qr/void context return from main::return_void/,
2592 "Test o PrintRet=1 in void context",
2593 );
2594}
2595
19957b55
SF
2596# Test the o PrintRet=1 option in void context
2597{
2598 my $wrapper = DebugWrap->new(
2599 {
2600 cmds =>
2601 [
2602 'o PrintRet=0',
2603 'b 29',
2604 'c',
2605 q/$x = 'v';/,
2606 'b 24',
2607 'c',
2608 'r',
2609 'q',
2610 ],
2611 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2612 }
2613 );
2614
2615 $wrapper->contents_unlike(
2616 qr/void context/,
2617 "Test o PrintRet=0 in void context",
2618 );
2619}
2620
473c46a8
SF
2621# Test the o frame option.
2622{
2623 my $wrapper = DebugWrap->new(
2624 {
2625 cmds =>
2626 [
2627 # This is to avoid getting the "Debugger program terminated"
2628 # junk that interferes with the normal output.
2629 'o inhibit_exit=0',
2630 'b 10',
2631 'c',
2632 'o frame=255',
2633 'c',
2634 'q',
2635 ],
2636 prog => '../lib/perl5db/t/test-frame-option-1',
2637 }
2638 );
2639
2640 $wrapper->contents_like(
2641 qr/
2642 in\s*\.=main::my_other_func\(3,\ 1200\)\ from.*?
2643 out\s*\.=main::my_other_func\(3,\ 1200\)\ from
2644 /msx,
2645 "Test o PrintRet=0 in void context",
2646 );
2647}
2648
e42327f3 2649{ # test t expr
e42327f3
TC
2650 my $wrapper = DebugWrap->new(
2651 {
2652 cmds =>
2653 [
2654 # This is to avoid getting the "Debugger program terminated"
2655 # junk that interferes with the normal output.
2656 'o inhibit_exit=0',
2657 't fact(3)',
2658 'q',
2659 ],
2660 prog => '../lib/perl5db/t/fact',
2661 }
2662 );
2663
2664 $wrapper->contents_like(
2665 qr/
2666 (?:^main::fact.*return\ \$n\ \*\ fact\(\$n\ -\ 1\);.*)
2667 /msx,
2668 "Test t expr",
2669 );
2670}
2671
5f5eab52
SF
2672# Test the w for lexical variables expression.
2673{
2674 my $wrapper = DebugWrap->new(
2675 {
2676 cmds =>
2677 [
2678 # This is to avoid getting the "Debugger program terminated"
2679 # junk that interferes with the normal output.
2680 'w $exp',
2681 'n',
2682 'n',
2683 'n',
2684 'n',
2685 'q',
2686 ],
2687 prog => '../lib/perl5db/t/break-on-dot',
2688 }
2689 );
2690
2691 $wrapper->contents_like(
2692 qr/
2693\s+old\ value:\s+'1'\n
2694\s+new\ value:\s+'2'\n
2695 /msx,
2696 "Test w for lexical values.",
2697 );
2698}
2699
c59f1e04
SF
2700# perl 5 RT #121509 regression bug.
2701# “perl debugger doesn't save starting dir to restart from”
2702# Thanks to Linda Walsh for reporting it.
2703{
2704 use File::Temp qw/tempdir/;
2705
2706 my $temp_dir = tempdir( CLEANUP => 1 );
2707
2708 local $ENV{__PERLDB_TEMP_DIR} = $temp_dir;
2709 my $wrapper = DebugWrap->new(
2710 {
2711 cmds =>
2712 [
2713 # This is to avoid getting the "Debugger program terminated"
2714 # junk that interferes with the normal output.
2715 'b _after_chdir',
2716 'c',
2717 'R',
2718 'b _finale',
2719 'c',
2720 'n',
2721 'n',
2722 'n',
2723 'n',
2724 'n',
2725 'n',
2726 'n',
2727 'n',
2728 'n',
2729 'n',
2730 'n',
2731 'n',
2732 'q',
2733 ],
2734 prog => '../lib/perl5db/t/rt-121509-restart-after-chdir',
2735 }
2736 );
2737
2738 $wrapper->output_like(
2739 qr/
2740In\ _finale\ No\ 1
2741 .*?
2742In\ _finale\ No\ 2
2743 .*?
2744In\ _finale\ No\ 3
2745 /msx,
2746 "Test that the debugger chdirs to the initial directory after a restart.",
2747 );
2748}
b019bbd2
NC
2749# Test the perldoc command
2750# We don't actually run the program, but we need to provide one to the wrapper.
08a004e4 2751SKIP:
b019bbd2 2752{
08a004e4
TC
2753 $^O eq "linux"
2754 or skip "man errors aren't especially portable", 1;
0244b879
NT
2755 -x '/usr/bin/man'
2756 or skip "man command seems to be missing", 1;
08a004e4 2757 local $ENV{LANG} = "C";
0b2badd3 2758 local $ENV{LC_MESSAGES} = "C";
f81b1f8b 2759 local $ENV{LC_ALL} = "C";
b019bbd2
NC
2760 my $wrapper = DebugWrap->new(
2761 {
2762 cmds =>
2763 [
2764 'perldoc perlrules',
2765 'q',
2766 ],
2767 prog => '../lib/perl5db/t/fact',
2768 }
2769 );
2770
2771 $wrapper->output_like(
8fe07b3c 2772 qr/No (?:manual )?entry for perlrules/,
b019bbd2
NC
2773 'perldoc command works fine',
2774 );
2775}
2776
0b1fcdcc
SF
2777# [perl #71678] debugger bug in evaluation of user actions ('a' command)
2778# Still evaluated after the script finishes.
2779{
2780 my $wrapper = DebugWrap->new(
2781 {
2782 cmds =>
2783 [
2784 q#a 9 print " \$arg = $arg\n"#,
2785 'c 9',
2786 's',
2787 'q',
2788 ],
2789 prog => '../lib/perl5db/t/test-a-statement-2',
2790 switches => [ '-dw', ],
2791 stderr => 1,
2792 }
2793 );
2794
2795 $wrapper->contents_unlike(qr/
2796 Use\ of\ uninitialized\ value\ \$arg\ in\ concatenation\ [\S ]+\ or\ string\ at
2797 /msx,
2798 'Test that the a command does not emit warnings on program exit.',
2799 );
2800}
2801
23053931
SF
2802{
2803 # perl 5 RT #126735 regression bug.
2804 local $ENV{PERLDB_OPTS} = "NonStop=0 RemotePort=non-existent-host.tld:9001";
2805 my $output = runperl( stdin => "q\n", stderr => 1, switches => [ '-d' ], prog => '../lib/perl5db/t/fact' );
2806 like(
2807 $output,
2808 qr/^Unable to connect to remote host:/ms,
2809 'Tried to connect.',
2810 );
2811 unlike(
2812 $output,
2813 qr/syntax error/,
2814 'Can quit from the debugger after a wrong RemotePort',
2815 );
2816}
2817
635f2c9e 2818END {
4cfe45a1 2819 1 while unlink ($rc_filename, $out_fn);
635f2c9e 2820}