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