This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make DosGlob.t more resilient
[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
f4beae36 31plan(106);
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
5bc17875
SF
801# Tests for "T" (stack trace).
802{
5bc17875 803 my $prog_fn = '../lib/perl5db/t/rt-104168';
5e2fff4a
SF
804 my $wrapper = DebugWrap->new(
805 {
806 prog => $prog_fn,
807 cmds =>
808 [
809 'c baz',
810 'T',
811 'q',
812 ],
813 }
814 );
5bc17875
SF
815 my $re_text = join('',
816 map {
817 sprintf(
818 "%s = %s\\(\\) called from file " .
819 "'" . quotemeta($prog_fn) . "' line %s\\n",
820 (map { quotemeta($_) } @$_)
821 )
2c247e84 822 }
5bc17875
SF
823 (
824 ['.', 'main::baz', 14,],
825 ['.', 'main::bar', 9,],
2c247e84 826 ['.', 'main::foo', 6],
5bc17875
SF
827 )
828 );
5e2fff4a 829 $wrapper->contents_like(
5bc17875
SF
830 # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
831 qr/^$re_text/ms,
832 "T command test."
833 );
834}
8fe891f1
SF
835
836# Test for s.
837{
5e2fff4a
SF
838 my $wrapper = DebugWrap->new(
839 {
840 cmds =>
841 [
842 'b 9',
843 'c',
844 's',
845 q/print "X={$x};dummy={$dummy}\n";/,
846 'q',
847 ],
848 prog => '../lib/perl5db/t/disable-breakpoints-1'
849 }
8fe891f1
SF
850 );
851
5e2fff4a 852 $wrapper->output_like(qr/
8fe891f1
SF
853 X=\{SecondVal\};dummy=\{1\}
854 /msx,
855 'test for s - single step',
856 );
857}
858
65ab0314 859{
5e2fff4a
SF
860 my $wrapper = DebugWrap->new(
861 {
862 cmds =>
863 [
864 'n',
865 'n',
866 'b . $exp > 200',
867 'c',
868 q/print "Exp={$exp}\n";/,
869 'q',
870 ],
871 prog => '../lib/perl5db/t/break-on-dot'
872 }
65ab0314
SF
873 );
874
5e2fff4a 875 $wrapper->output_like(qr/
65ab0314
SF
876 Exp=\{256\}
877 /msx,
878 "'b .' is working correctly.");
879}
880
881{
65ab0314 882 my $prog_fn = '../lib/perl5db/t/rt-104168';
5e2fff4a
SF
883 my $wrapper = DebugWrap->new(
884 {
885 cmds =>
886 [
887 's',
888 'q',
889 ],
890 prog => $prog_fn,
891 }
892 );
65ab0314 893
5e2fff4a 894 $wrapper->contents_like(
65ab0314
SF
895 qr/
896 ^main::foo\([^\)\n]*\brt-104168:9\):[\ \t]*\n
897 ^9:\s*bar\(\);
898 /msx,
899 'Test for the s command.',
900 );
901}
902
5d83cde2 903{
5e2fff4a
SF
904 my $wrapper = DebugWrap->new(
905 {
906 cmds =>
907 [
908 's uncalled_subroutine()',
909 'c',
910 'q',
911 ],
5d83cde2 912
5e2fff4a 913 prog => '../lib/perl5db/t/uncalled-subroutine'}
5d83cde2
SF
914 );
915
5e2fff4a 916 $wrapper->output_like(
5d83cde2
SF
917 qr/<1,2,3,4,5>\n/,
918 'uncalled_subroutine was called after s EXPR()',
919 );
5d83cde2
SF
920}
921
d7b8b95b 922{
5e2fff4a
SF
923 my $wrapper = DebugWrap->new(
924 {
925 cmds =>
926 [
927 'n uncalled_subroutine()',
928 'c',
929 'q',
930 ],
931 prog => '../lib/perl5db/t/uncalled-subroutine',
932 }
d7b8b95b
SF
933 );
934
5e2fff4a 935 $wrapper->output_like(
d7b8b95b
SF
936 qr/<1,2,3,4,5>\n/,
937 'uncalled_subroutine was called after n EXPR()',
938 );
d7b8b95b
SF
939}
940
ea7bdd87
VP
941{
942 my $wrapper = DebugWrap->new(
943 {
944 cmds =>
945 [
946 'b fact',
947 'c',
948 'c',
949 'c',
950 'n',
951 'print "<$n>"',
952 'q',
953 ],
954 prog => '../lib/perl5db/t/fact',
955 }
956 );
957
958 $wrapper->output_like(
959 qr/<3>/,
960 'b subroutine works fine',
961 );
962}
963
f311474d
VP
964# Test for 'M' (module list).
965{
966 my $wrapper = DebugWrap->new(
967 {
968 cmds =>
969 [
970 'M',
971 'q',
972 ],
973 prog => '../lib/perl5db/t/load-modules'
974 }
975 );
976
977 $wrapper->contents_like(
978 qr[Scalar/Util\.pm],
979 'M (module list) works fine',
980 );
981}
982
55783941
SF
983{
984 my $wrapper = DebugWrap->new(
985 {
986 cmds =>
987 [
988 'b 14',
989 'c',
990 '$flag = 1;',
991 'r',
992 'print "Var=$var\n";',
993 'q',
994 ],
995 prog => '../lib/perl5db/t/test-r-statement',
996 }
997 );
998
999 $wrapper->output_like(
1000 qr/
1001 ^Foo$
1002 .*?
1003 ^Bar$
1004 .*?
1005 ^Var=Test$
1006 /msx,
1007 'r statement is working properly.',
1008 );
1009}
1010
1011{
1012 my $wrapper = DebugWrap->new(
1013 {
1014 cmds =>
1015 [
1016 'l',
1017 'q',
1018 ],
1019 prog => '../lib/perl5db/t/test-l-statement-1',
1020 }
1021 );
1022
1023 $wrapper->contents_like(
1024 qr/
1025 ^1==>\s+\$x\ =\ 1;\n
1026 2:\s+print\ "1\\n";\n
1027 3\s*\n
1028 4:\s+\$x\ =\ 2;\n
1029 5:\s+print\ "2\\n";\n
1030 /msx,
1031 'l statement is working properly (test No. 1).',
1032 );
1033}
1034
2c247e84
SF
1035{
1036 my $wrapper = DebugWrap->new(
1037 {
1038 cmds =>
1039 [
1040 'l',
1041 q/# After l 1/,
1042 'l',
1043 q/# After l 2/,
1044 '-',
1045 q/# After -/,
1046 'q',
1047 ],
1048 prog => '../lib/perl5db/t/test-l-statement-1',
1049 }
1050 );
1051
1052 my $first_l_out = qr/
1053 1==>\s+\$x\ =\ 1;\n
1054 2:\s+print\ "1\\n";\n
1055 3\s*\n
1056 4:\s+\$x\ =\ 2;\n
1057 5:\s+print\ "2\\n";\n
1058 6\s*\n
1059 7:\s+\$x\ =\ 3;\n
1060 8:\s+print\ "3\\n";\n
1061 9\s*\n
1062 10:\s+\$x\ =\ 4;\n
1063 /msx;
1064
1065 my $second_l_out = qr/
1066 11:\s+print\ "4\\n";\n
1067 12\s*\n
1068 13:\s+\$x\ =\ 5;\n
1069 14:\s+print\ "5\\n";\n
1070 15\s*\n
1071 16:\s+\$x\ =\ 6;\n
1072 17:\s+print\ "6\\n";\n
1073 18\s*\n
1074 19:\s+\$x\ =\ 7;\n
1075 20:\s+print\ "7\\n";\n
1076 /msx;
1077 $wrapper->contents_like(
1078 qr/
1079 ^$first_l_out
1080 [^\n]*?DB<\d+>\ \#\ After\ l\ 1\n
1081 [\ \t]*\n
1082 [^\n]*?DB<\d+>\ l\s*\n
1083 $second_l_out
1084 [^\n]*?DB<\d+>\ \#\ After\ l\ 2\n
1085 [\ \t]*\n
1086 [^\n]*?DB<\d+>\ -\s*\n
1087 $first_l_out
1088 [^\n]*?DB<\d+>\ \#\ After\ -\n
1089 /msx,
1090 'l followed by l and then followed by -',
1091 );
1092}
1093
1094{
1095 my $wrapper = DebugWrap->new(
1096 {
1097 cmds =>
1098 [
1099 'l fact',
1100 'q',
1101 ],
1102 prog => '../lib/perl5db/t/test-l-statement-2',
1103 }
1104 );
1105
1106 my $first_l_out = qr/
1107 6\s+sub\ fact\ \{\n
1108 7:\s+my\ \$n\ =\ shift;\n
1109 8:\s+if\ \(\$n\ >\ 1\)\ \{\n
1110 9:\s+return\ \$n\ \*\ fact\(\$n\ -\ 1\);
1111 /msx;
1112
1113 $wrapper->contents_like(
1114 qr/
1115 DB<1>\s+l\ fact\n
1116 $first_l_out
1117 /msx,
1118 'l subroutine_name',
1119 );
1120}
1121
1122{
1123 my $wrapper = DebugWrap->new(
1124 {
1125 cmds =>
1126 [
1127 'b fact',
1128 'c',
1129 # Repeat several times to avoid @typeahead problems.
1130 '.',
1131 '.',
1132 '.',
1133 '.',
1134 'q',
1135 ],
1136 prog => '../lib/perl5db/t/test-l-statement-2',
1137 }
1138 );
1139
1140 my $line_out = qr /
1141 ^main::fact\([^\n]*?:7\):\n
1142 ^7:\s+my\ \$n\ =\ shift;\n
1143 /msx;
1144
1145 $wrapper->contents_like(
1146 qr/
1147 $line_out
1148 $line_out
1149 /msx,
1150 'Test the "." command',
1151 );
1152}
1153
1154# Testing that the f command works.
1155{
1156 my $wrapper = DebugWrap->new(
1157 {
1158 cmds =>
1159 [
1160 'f ../lib/perl5db/t/MyModule.pm',
1161 'b 12',
1162 'c',
1163 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
1164 'c',
1165 'q',
1166 ],
1167 include_t => 1,
1168 prog => '../lib/perl5db/t/filename-line-breakpoint'
1169 }
1170 );
1171
1172 $wrapper->output_like(qr/
1173 ^Var=Bar$
1174 .*
1175 ^In\ MyModule\.$
1176 .*
1177 ^In\ Main\ File\.$
1178 .*
1179 /msx,
1180 "f command is working.",
1181 );
1182}
1183
1184# We broke the /pattern/ command because apparently the CORE::eval-s inside
1185# lib/perl5db.pl cannot handle lexical variable properly. So we now fix this
1186# bug.
1187#
1188# TODO :
1189#
1190# 1. Go over the rest of the "eval"s in lib/perl5db.t and see if they cause
1191# problems.
1192{
1193 my $wrapper = DebugWrap->new(
1194 {
1195 cmds =>
1196 [
1197 '/for/',
1198 'q',
1199 ],
1200 prog => '../lib/perl5db/t/eval-line-bug',
1201 }
1202 );
1203
1204 $wrapper->contents_like(
1205 qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1206 "/pat/ command is working and found a match.",
1207 );
1208}
1209
1210{
1211 my $wrapper = DebugWrap->new(
1212 {
1213 cmds =>
1214 [
1215 'b 22',
1216 'c',
1217 '?for?',
1218 'q',
1219 ],
1220 prog => '../lib/perl5db/t/eval-line-bug',
1221 }
1222 );
1223
1224 $wrapper->contents_like(
1225 qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1226 "?pat? command is working and found a match.",
1227 );
1228}
1229
72d7d80d
SF
1230# Test the L command.
1231{
1232 my $wrapper = DebugWrap->new(
1233 {
1234 cmds =>
1235 [
1236 'b 6',
1237 'b 13 ($q == 5)',
1238 'L',
1239 'q',
1240 ],
1241 prog => '../lib/perl5db/t/eval-line-bug',
1242 }
1243 );
1244
1245 $wrapper->contents_like(
1246 qr#
1247 ^\S*?eval-line-bug:\n
1248 \s*6:\s*my\ \$i\ =\ 5;\n
1249 \s*break\ if\ \(1\)\n
1250 \s*13:\s*\$i\ \+=\ \$q;\n
1251 \s*break\ if\ \(\(\$q\ ==\ 5\)\)\n
1252 #msx,
1253 "L command is listing breakpoints",
1254 );
1255}
1256
1257# Test the L command for watch expressions.
1258{
1259 my $wrapper = DebugWrap->new(
1260 {
1261 cmds =>
1262 [
1263 'w (5+6)',
1264 'L',
1265 'q',
1266 ],
1267 prog => '../lib/perl5db/t/eval-line-bug',
1268 }
1269 );
1270
1271 $wrapper->contents_like(
1272 qr#
1273 ^Watch-expressions:\n
1274 \s*\(5\+6\)\n
1275 #msx,
1276 "L command is listing watch expressions",
1277 );
1278}
1279
1280{
1281 my $wrapper = DebugWrap->new(
1282 {
1283 cmds =>
1284 [
1285 'w (5+6)',
1286 'w (11*23)',
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*\(11\*23\)\n
1299 ^auto\(
1300 #msx,
1301 "L command is not listing deleted watch expressions",
1302 );
1303}
1304
1305# Test the L command.
1306{
1307 my $wrapper = DebugWrap->new(
1308 {
1309 cmds =>
1310 [
1311 'b 6',
1312 'a 13 print $i',
1313 'L',
1314 'q',
1315 ],
1316 prog => '../lib/perl5db/t/eval-line-bug',
1317 }
1318 );
1319
1320 $wrapper->contents_like(
1321 qr#
1322 ^\S*?eval-line-bug:\n
1323 \s*6:\s*my\ \$i\ =\ 5;\n
1324 \s*break\ if\ \(1\)\n
1325 \s*13:\s*\$i\ \+=\ \$q;\n
1326 \s*action:\s+print\ \$i\n
1327 #msx,
1328 "L command is listing actions and breakpoints",
1329 );
1330}
1331
1332{
1333 my $wrapper = DebugWrap->new(
1334 {
1335 cmds =>
1336 [
1337 'S',
1338 'q',
1339 ],
1340 prog => '../lib/perl5db/t/rt-104168',
1341 }
1342 );
1343
1344 $wrapper->contents_like(
1345 qr#
1346 ^main::bar\n
1347 main::baz\n
1348 main::foo\n
1349 #msx,
1350 "S command - 1",
1351 );
1352}
1353
1354{
1355 my $wrapper = DebugWrap->new(
1356 {
1357 cmds =>
1358 [
1359 'S ^main::ba',
1360 'q',
1361 ],
1362 prog => '../lib/perl5db/t/rt-104168',
1363 }
1364 );
1365
1366 $wrapper->contents_like(
1367 qr#
1368 ^main::bar\n
1369 main::baz\n
1370 auto\(
1371 #msx,
1372 "S command with regex",
1373 );
1374}
1375
1376{
1377 my $wrapper = DebugWrap->new(
1378 {
1379 cmds =>
1380 [
1381 'S !^main::ba',
1382 'q',
1383 ],
1384 prog => '../lib/perl5db/t/rt-104168',
1385 }
1386 );
1387
1388 $wrapper->contents_unlike(
1389 qr#
1390 ^main::ba
1391 #msx,
1392 "S command with negative regex",
1393 );
1394
1395 $wrapper->contents_like(
1396 qr#
1397 ^main::foo\n
1398 #msx,
1399 "S command with negative regex - what it still matches",
1400 );
1401}
1402
f4beae36 1403# Test the 'a' command.
72d7d80d
SF
1404{
1405 my $wrapper = DebugWrap->new(
1406 {
1407 cmds =>
1408 [
1409 'a 13 print "\nVar<Q>=$q\n"',
1410 'c',
1411 'q',
1412 ],
1413 prog => '../lib/perl5db/t/eval-line-bug',
1414 }
1415 );
1416
1417 $wrapper->output_like(qr#
1418 \nVar<Q>=1\n
1419 \nVar<Q>=2\n
1420 \nVar<Q>=3\n
1421 #msx,
1422 "a command is working",
1423 );
1424}
1425
f4beae36
SF
1426# Test the 'a' command with no line number.
1427{
1428 my $wrapper = DebugWrap->new(
1429 {
1430 cmds =>
1431 [
1432 'n',
1433 q/a print "Hello " . (3 * 4) . "\n";/,
1434 'c',
1435 'q',
1436 ],
1437 prog => '../lib/perl5db/t/test-a-statement-1',
1438 }
1439 );
1440
1441 $wrapper->output_like(qr#
1442 (?:^Hello\ 12\n.*?){4}
1443 #msx,
1444 "a command with no line number is working",
1445 );
1446}
1447
72d7d80d
SF
1448# Test the 'A' command
1449{
1450 my $wrapper = DebugWrap->new(
1451 {
1452 cmds =>
1453 [
1454 'a 13 print "\nVar<Q>=$q\n"',
1455 'A 13',
1456 'c',
1457 'q',
1458 ],
1459 prog => '../lib/perl5db/t/eval-line-bug',
1460 }
1461 );
1462
1463 $wrapper->output_like(
1464 qr#\A\z#msx, # The empty string.
1465 "A command (for removing actions) is working",
1466 );
1467}
1468
1469# Test the 'A *' command
1470{
1471 my $wrapper = DebugWrap->new(
1472 {
1473 cmds =>
1474 [
1475 'a 6 print "\nFail!\n"',
1476 'a 13 print "\nVar<Q>=$q\n"',
1477 'A *',
1478 'c',
1479 'q',
1480 ],
1481 prog => '../lib/perl5db/t/eval-line-bug',
1482 }
1483 );
1484
1485 $wrapper->output_like(
1486 qr#\A\z#msx, # The empty string.
1487 "'A *' command (for removing all actions) is working",
1488 );
1489}
1490
1491{
1492 my $wrapper = DebugWrap->new(
1493 {
1494 cmds =>
1495 [
1496 'n',
1497 'w $foo',
1498 'c',
1499 'print "\nIDX=<$idx>\n"',
1500 'q',
1501 ],
1502 prog => '../lib/perl5db/t/test-w-statement-1',
1503 }
1504 );
1505
1506
1507 $wrapper->contents_like(qr#
1508 \$foo\ changed:\n
1509 \s+old\ value:\s+'1'\n
1510 \s+new\ value:\s+'2'\n
1511 #msx,
1512 'w command - watchpoint changed',
1513 );
1514 $wrapper->output_like(qr#
1515 \nIDX=<20>\n
1516 #msx,
1517 "w command - correct output from IDX",
1518 );
1519}
1520
1521{
1522 my $wrapper = DebugWrap->new(
1523 {
1524 cmds =>
1525 [
1526 'n',
1527 'w $foo',
1528 'W $foo',
1529 'c',
1530 'print "\nIDX=<$idx>\n"',
1531 'q',
1532 ],
1533 prog => '../lib/perl5db/t/test-w-statement-1',
1534 }
1535 );
1536
1537 $wrapper->contents_unlike(qr#
1538 \$foo\ changed:
1539 #msx,
1540 'W command - watchpoint was deleted',
1541 );
1542
1543 $wrapper->output_like(qr#
1544 \nIDX=<>\n
1545 #msx,
1546 "W command - stopped at end.",
1547 );
1548}
1549
1550# Test the W * command.
1551{
1552 my $wrapper = DebugWrap->new(
1553 {
1554 cmds =>
1555 [
1556 'n',
1557 'w $foo',
1558 'w ($foo*$foo)',
1559 'W *',
1560 'c',
1561 'print "\nIDX=<$idx>\n"',
1562 'q',
1563 ],
1564 prog => '../lib/perl5db/t/test-w-statement-1',
1565 }
1566 );
1567
1568 $wrapper->contents_unlike(qr#
1569 \$foo\ changed:
1570 #msx,
1571 '"W *" command - watchpoint was deleted',
1572 );
1573
1574 $wrapper->output_like(qr#
1575 \nIDX=<>\n
1576 #msx,
1577 '"W *" command - stopped at end.',
1578 );
1579}
1580
1581# Test the 'o' command (without further arguments).
1582{
1583 my $wrapper = DebugWrap->new(
1584 {
1585 cmds =>
1586 [
1587 'o',
1588 'q',
1589 ],
1590 prog => '../lib/perl5db/t/test-w-statement-1',
1591 }
1592 );
1593
1594 $wrapper->contents_like(qr#
1595 ^\s*warnLevel\ =\ '1'\n
1596 #msx,
1597 q#"o" command (without arguments) displays warnLevel#,
1598 );
1599
1600 $wrapper->contents_like(qr#
1601 ^\s*signalLevel\ =\ '1'\n
1602 #msx,
1603 q#"o" command (without arguments) displays signalLevel#,
1604 );
1605
1606 $wrapper->contents_like(qr#
1607 ^\s*dieLevel\ =\ '1'\n
1608 #msx,
1609 q#"o" command (without arguments) displays dieLevel#,
1610 );
1611
1612 $wrapper->contents_like(qr#
1613 ^\s*hashDepth\ =\ 'N/A'\n
1614 #msx,
1615 q#"o" command (without arguments) displays hashDepth#,
1616 );
1617}
1618
1619# Test the 'o' query command.
1620{
1621 my $wrapper = DebugWrap->new(
1622 {
1623 cmds =>
1624 [
1625 'o hashDepth? signalLevel?',
1626 'q',
1627 ],
1628 prog => '../lib/perl5db/t/test-w-statement-1',
1629 }
1630 );
1631
1632 $wrapper->contents_unlike(qr#warnLevel#,
1633 q#"o" query command does not display warnLevel#,
1634 );
1635
1636 $wrapper->contents_like(qr#
1637 ^\s*signalLevel\ =\ '1'\n
1638 #msx,
1639 q#"o" query command displays signalLevel#,
1640 );
1641
1642 $wrapper->contents_unlike(qr#dieLevel#,
1643 q#"o" query command does not display dieLevel#,
1644 );
1645
1646 $wrapper->contents_like(qr#
1647 ^\s*hashDepth\ =\ 'N/A'\n
1648 #msx,
1649 q#"o" query command displays hashDepth#,
1650 );
1651}
1652
1653# Test the 'o' set command.
1654{
1655 my $wrapper = DebugWrap->new(
1656 {
1657 cmds =>
1658 [
1659 'o signalLevel=0',
1660 'o',
1661 'q',
1662 ],
1663 prog => '../lib/perl5db/t/test-w-statement-1',
1664 }
1665 );
1666
1667 $wrapper->contents_like(qr/
1668 ^\s*(signalLevel\ =\ '0'\n)
1669 .*?
1670 ^\s*\1
1671 /msx,
1672 q#o set command works#,
1673 );
1674
1675 $wrapper->contents_like(qr#
1676 ^\s*hashDepth\ =\ 'N/A'\n
1677 #msx,
1678 q#o set command - hashDepth#,
1679 );
1680}
1681
1682# Test the '<' and "< ?" commands.
1683{
1684 my $wrapper = DebugWrap->new(
1685 {
1686 cmds =>
1687 [
1688 q/< print "\nX=<$x>\n"/,
1689 q/b 7/,
1690 q/< ?/,
1691 'c',
1692 'q',
1693 ],
1694 prog => '../lib/perl5db/t/disable-breakpoints-1',
1695 }
1696 );
1697
1698 $wrapper->contents_like(qr/
1699 ^pre-perl\ commands:\n
1700 \s*<\ --\ print\ "\\nX=<\$x>\\n"\n
1701 /msx,
1702 q#Test < and < ? commands - contents.#,
1703 );
1704
1705 $wrapper->output_like(qr#
1706 ^X=<FirstVal>\n
1707 #msx,
1708 q#Test < and < ? commands - output.#,
1709 );
1710}
1711
1712# Test the '< *' command.
1713{
1714 my $wrapper = DebugWrap->new(
1715 {
1716 cmds =>
1717 [
1718 q/< print "\nX=<$x>\n"/,
1719 q/b 7/,
1720 q/< */,
1721 'c',
1722 'q',
1723 ],
1724 prog => '../lib/perl5db/t/disable-breakpoints-1',
1725 }
1726 );
1727
1728 $wrapper->output_unlike(qr/FirstVal/,
1729 q#Test the '< *' command.#,
1730 );
1731}
1732
1733# Test the '>' and "> ?" commands.
1734{
1735 my $wrapper = DebugWrap->new(
1736 {
1737 cmds =>
1738 [
1739 q/$::foo = 500;/,
1740 q/> print "\nFOO=<$::foo>\n"/,
1741 q/b 7/,
1742 q/> ?/,
1743 'c',
1744 'q',
1745 ],
1746 prog => '../lib/perl5db/t/disable-breakpoints-1',
1747 }
1748 );
1749
1750 $wrapper->contents_like(qr/
1751 ^post-perl\ commands:\n
1752 \s*>\ --\ print\ "\\nFOO=<\$::foo>\\n"\n
1753 /msx,
1754 q#Test > and > ? commands - contents.#,
1755 );
1756
1757 $wrapper->output_like(qr#
1758 ^FOO=<500>\n
1759 #msx,
1760 q#Test > and > ? commands - output.#,
1761 );
1762}
1763
1764# Test the '> *' command.
1765{
1766 my $wrapper = DebugWrap->new(
1767 {
1768 cmds =>
1769 [
1770 q/> print "\nFOO=<$::foo>\n"/,
1771 q/b 7/,
1772 q/> */,
1773 'c',
1774 'q',
1775 ],
1776 prog => '../lib/perl5db/t/disable-breakpoints-1',
1777 }
1778 );
1779
1780 $wrapper->output_unlike(qr/FOO=/,
1781 q#Test the '> *' command.#,
1782 );
1783}
1784
be1dfd82
SF
1785# Test the < and > commands together
1786{
1787 my $wrapper = DebugWrap->new(
1788 {
1789 cmds =>
1790 [
1791 q/$::lorem = 0;/,
1792 q/< $::lorem += 10;/,
1793 q/> print "\nLOREM=<$::lorem>\n"/,
1794 q/b 7/,
1795 q/b 5/,
1796 'c',
1797 'c',
1798 'q',
1799 ],
1800 prog => '../lib/perl5db/t/disable-breakpoints-1',
1801 }
1802 );
1803
1804 $wrapper->output_like(qr#
1805 ^LOREM=<10>\n
1806 #msx,
1807 q#Test < and > commands. #,
1808 );
1809}
1810
95418017
SF
1811# Test the { ? and { [command] commands.
1812{
1813 my $wrapper = DebugWrap->new(
1814 {
1815 cmds =>
1816 [
1e121f70
SF
1817 '{ ?',
1818 '{ l',
1819 '{ ?',
95418017
SF
1820 q/b 5/,
1821 q/c/,
1822 q/q/,
1823 ],
1824 prog => '../lib/perl5db/t/disable-breakpoints-1',
1825 }
1826 );
1827
1828 $wrapper->contents_like(qr#
1829 ^No\ pre-debugger\ actions\.\n
1830 .*?
1831 ^pre-debugger\ commands:\n
1832 \s+\{\ --\ l\n
1833 .*?
1834 ^5==>b\s+\$x\ =\ "FirstVal";\n
1835 6\s*\n
1836 7:\s+\$dummy\+\+;\n
1837 8\s*\n
1838 9:\s+\$x\ =\ "SecondVal";\n
1839
1840 #msx,
1841 'Test the pre-prompt debugger commands',
1842 );
1843}
1844
3743412c
SF
1845# Test the { * command.
1846{
1847 my $wrapper = DebugWrap->new(
1848 {
1849 cmds =>
1850 [
1851 '{ q',
1852 '{ *',
1853 q/b 5/,
1854 q/c/,
1855 q/print (("One" x 5), "\n");/,
1856 q/q/,
1857 ],
1858 prog => '../lib/perl5db/t/disable-breakpoints-1',
1859 }
1860 );
1861
1862 $wrapper->contents_like(qr#
1863 ^All\ \{\ actions\ cleared\.\n
1864 #msx,
1865 'Test the { * command',
1866 );
1867
1868 $wrapper->output_like(qr/OneOneOneOneOne/,
1869 '{ * test - output is OK.',
1870 );
1871}
1872
1896f514
SF
1873# Test the ! command.
1874{
1875 my $wrapper = DebugWrap->new(
1876 {
1877 cmds =>
1878 [
1879 'l 3-5',
1880 '!',
1881 'q',
1882 ],
1883 prog => '../lib/perl5db/t/disable-breakpoints-1',
1884 }
1885 );
1886
1887 $wrapper->contents_like(qr#
1888 (^3:\s+my\ \$dummy\ =\ 0;\n
1889 4\s*\n
1890 5:\s+\$x\ =\ "FirstVal";)\n
1891 .*?
1892 ^l\ 3-5\n
1893 \1
1894 #msx,
1895 'Test the ! command (along with l 3-5)',
1896 );
1897}
1898
ada05bfe
SF
1899# Test the ! -number command.
1900{
1901 my $wrapper = DebugWrap->new(
1902 {
1903 cmds =>
1904 [
1905 'l 3-5',
1906 'l 2',
1907 '! -1',
1908 'q',
1909 ],
1910 prog => '../lib/perl5db/t/disable-breakpoints-1',
1911 }
1912 );
1913
1914 $wrapper->contents_like(qr#
1915 (^3:\s+my\ \$dummy\ =\ 0;\n
1916 4\s*\n
1917 5:\s+\$x\ =\ "FirstVal";)\n
1918 .*?
1919 ^2==\>\s+my\ \$x\ =\ "One";\n
1920 .*?
1921 ^l\ 3-5\n
1922 \1
1923 #msx,
1924 'Test the ! -n command (along with l)',
1925 );
1926}
1927
5442f949
SF
1928# Test the 'source' command.
1929{
1930 my $wrapper = DebugWrap->new(
1931 {
1932 cmds =>
1933 [
1934 'source ../lib/perl5db/t/source-cmd-test.perldb',
1935 # If we have a 'q' here, then the typeahead will override the
1936 # input, and so it won't be reached - solution:
1937 # put a q inside the .perldb commands.
1938 # ( This may be a bug or a misfeature. )
1939 ],
1940 prog => '../lib/perl5db/t/disable-breakpoints-1',
1941 }
1942 );
1943
1944 $wrapper->contents_like(qr#
1945 ^3:\s+my\ \$dummy\ =\ 0;\n
1946 4\s*\n
1947 5:\s+\$x\ =\ "FirstVal";\n
1948 6\s*\n
1949 7:\s+\$dummy\+\+;\n
1950 8\s*\n
1951 9:\s+\$x\ =\ "SecondVal";\n
1952 10\s*\n
1953 #msx,
1954 'Test the source command (along with l)',
1955 );
35879b90
SF
1956}
1957
1958# Test the 'source' command being traversed from withing typeahead.
1959{
1960 my $wrapper = DebugWrap->new(
1961 {
1962 cmds =>
1963 [
1964 'source ../lib/perl5db/t/source-cmd-test-no-q.perldb',
1965 'q',
1966 ],
1967 prog => '../lib/perl5db/t/disable-breakpoints-1',
1968 }
1969 );
5442f949 1970
35879b90
SF
1971 $wrapper->contents_like(qr#
1972 ^3:\s+my\ \$dummy\ =\ 0;\n
1973 4\s*\n
1974 5:\s+\$x\ =\ "FirstVal";\n
1975 6\s*\n
1976 7:\s+\$dummy\+\+;\n
1977 8\s*\n
1978 9:\s+\$x\ =\ "SecondVal";\n
1979 10\s*\n
1980 #msx,
1981 'Test the source command inside a typeahead',
1982 );
5442f949
SF
1983}
1984
741f88f9
SF
1985# Test the 'H -number' command.
1986{
1987 my $wrapper = DebugWrap->new(
1988 {
1989 cmds =>
1990 [
1991 'l 1-10',
1992 'l 5-10',
1993 'x "Hello World"',
1994 'l 1-5',
1995 'b 3',
1996 'x (20+4)',
1997 'H -7',
1998 'q',
1999 ],
2000 prog => '../lib/perl5db/t/disable-breakpoints-1',
2001 }
2002 );
2003
2004 $wrapper->contents_like(qr#
2005 ^\d+:\s+H\ -7\n
2006 \d+:\s+x\ \(20\+4\)\n
2007 \d+:\s+b\ 3\n
2008 \d+:\s+l\ 1-5\n
2009 \d+:\s+x\ "Hello\ World"\n
2010 \d+:\s+l\ 5-10\n
2011 \d+:\s+l\ 1-10\n
2012 #msx,
6bf7e1ad 2013 'Test the H -num command',
741f88f9
SF
2014 );
2015}
2016
761ec47e
SF
2017# Add a test for H (without arguments)
2018{
2019 my $wrapper = DebugWrap->new(
2020 {
2021 cmds =>
2022 [
2023 'l 1-10',
2024 'l 5-10',
2025 'x "Hello World"',
2026 'l 1-5',
2027 'b 3',
2028 'x (20+4)',
2029 'H',
2030 'q',
2031 ],
2032 prog => '../lib/perl5db/t/disable-breakpoints-1',
2033 }
2034 );
2035
2036 $wrapper->contents_like(qr#
2037 ^\d+:\s+x\ \(20\+4\)\n
2038 \d+:\s+b\ 3\n
2039 \d+:\s+l\ 1-5\n
2040 \d+:\s+x\ "Hello\ World"\n
2041 \d+:\s+l\ 5-10\n
2042 \d+:\s+l\ 1-10\n
2043 #msx,
6bf7e1ad 2044 'Test the H command (without a number.)',
761ec47e
SF
2045 );
2046}
2047
088a867e
SF
2048{
2049 my $wrapper = DebugWrap->new(
2050 {
2051 cmds =>
2052 [
2053 '= quit q',
2054 '= foobar l',
2055 'foobar',
2056 'quit',
2057 ],
2058 prog => '../lib/perl5db/t/test-l-statement-1',
2059 }
2060 );
2061
2062 $wrapper->contents_like(
2063 qr/
2064 ^1==>\s+\$x\ =\ 1;\n
2065 2:\s+print\ "1\\n";\n
2066 3\s*\n
2067 4:\s+\$x\ =\ 2;\n
2068 5:\s+print\ "2\\n";\n
2069 /msx,
2070 'Test the = (command alias) command.',
2071 );
2072}
2073
fedbbdd5 2074# Test the m statement.
12f1669f
SF
2075{
2076 my $wrapper = DebugWrap->new(
2077 {
2078 cmds =>
2079 [
2080 'm main',
2081 'q',
2082 ],
2083 prog => '../lib/perl5db/t/disable-breakpoints-1',
2084 }
2085 );
2086
2087 $wrapper->contents_like(qr#
2088 ^via\ UNIVERSAL:\ DOES$
2089 #msx,
2090 "Test m for main - 1",
2091 );
2092
2093 $wrapper->contents_like(qr#
2094 ^via\ UNIVERSAL:\ can$
2095 #msx,
2096 "Test m for main - 2",
2097 );
2098}
2099
fedbbdd5
SF
2100# Test the m statement.
2101{
2102 my $wrapper = DebugWrap->new(
2103 {
2104 cmds =>
2105 [
2106 'b 41',
2107 'c',
2108 'm $obj',
2109 'q',
2110 ],
2111 prog => '../lib/perl5db/t/test-m-statement-1',
2112 }
2113 );
2114
2115 $wrapper->contents_like(qr#^greet$#ms,
2116 "Test m for obj - 1",
2117 );
2118
2119 $wrapper->contents_like(qr#^via UNIVERSAL: can$#ms,
2120 "Test m for obj - 1",
2121 );
2122}
2123
2bceee64
SF
2124# Test the M command.
2125{
2126 my $wrapper = DebugWrap->new(
2127 {
2128 cmds =>
2129 [
2130 'M',
2131 'q',
2132 ],
2133 prog => '../lib/perl5db/t/test-m-statement-1',
2134 }
2135 );
2136
2137 $wrapper->contents_like(qr#
2138 ^'strict\.pm'\ =>\ '\d+\.\d+\ from
2139 #msx,
2140 "Test M",
2141 );
2142
2143}
2144
8b842515
SF
2145# Test the recallCommand option.
2146{
2147 my $wrapper = DebugWrap->new(
2148 {
2149 cmds =>
2150 [
2151 'o recallCommand=%',
2152 'l 3-5',
2153 'l 2',
2154 '% -1',
2155 'q',
2156 ],
2157 prog => '../lib/perl5db/t/disable-breakpoints-1',
2158 }
2159 );
2160
2161 $wrapper->contents_like(qr#
2162 (^3:\s+my\ \$dummy\ =\ 0;\n
2163 4\s*\n
2164 5:\s+\$x\ =\ "FirstVal";)\n
2165 .*?
2166 ^2==\>\s+my\ \$x\ =\ "One";\n
2167 .*?
2168 ^l\ 3-5\n
2169 \1
2170 #msx,
2171 'Test the o recallCommand option',
2172 );
2173}
b705c774
SF
2174
2175# Test the dieLevel option
2176{
2177 my $wrapper = DebugWrap->new(
2178 {
2179 cmds =>
2180 [
2181 q/o dieLevel='1'/,
2182 q/c/,
2183 'q',
2184 ],
2185 prog => '../lib/perl5db/t/test-dieLevel-option-1',
2186 }
2187 );
2188
2189 $wrapper->output_like(qr#
2190 ^This\ program\ dies\.\ at\ \S+\ line\ 18\.\n
2191 .*?
2192 ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
2193 \s+main::bar\(\)\ called\ at\ \S+\ line\ 7\n
2194 \s+main::foo\(\)\ called\ at\ \S+\ line\ 21\n
2195 #msx,
2196 'Test the o dieLevel option',
2197 );
2198}
2199
ca3d9398
SF
2200# Test the warnLevel option
2201{
2202 my $wrapper = DebugWrap->new(
2203 {
2204 cmds =>
2205 [
2206 q/o warnLevel='1'/,
2207 q/c/,
2208 'q',
2209 ],
2210 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2211 }
2212 );
2213
2214 $wrapper->contents_like(qr#
2215 ^This\ is\ not\ a\ warning\.\ at\ \S+\ line\ 18\.\n
2216 .*?
2217 ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
2218 \s+main::bar\(\)\ called\ at\ \S+\ line\ 25\n
2219 \s+main::myfunc\(\)\ called\ at\ \S+\ line\ 28\n
2220 #msx,
2221 'Test the o warnLevel option',
2222 );
2223}
2224
742c59c5
SF
2225# Test the t command
2226{
2227 my $wrapper = DebugWrap->new(
2228 {
2229 cmds =>
2230 [
2231 't',
2232 'c',
2233 'q',
2234 ],
2235 prog => '../lib/perl5db/t/disable-breakpoints-1',
2236 }
2237 );
2238
2239 $wrapper->contents_like(qr/
2240 ^main::\([^:]+:15\):\n
2241 15:\s+\$dummy\+\+;\n
2242 main::\([^:]+:17\):\n
2243 17:\s+\$x\ =\ "FourthVal";\n
2244 /msx,
2245 'Test the t command (without a number.)',
2246 );
2247}
2248
3d02bfa8
SF
2249# Test the o AutoTrace command
2250{
2251 my $wrapper = DebugWrap->new(
2252 {
2253 cmds =>
2254 [
2255 'o AutoTrace',
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 o AutoTrace command',
2270 );
2271}
2272
f910787d
SF
2273# Test the t command with function calls
2274{
2275 my $wrapper = DebugWrap->new(
2276 {
2277 cmds =>
2278 [
2279 't',
2280 'b 18',
2281 'c',
2282 'x ["foo"]',
2283 'x ["bar"]',
2284 'q',
2285 ],
2286 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2287 }
2288 );
2289
2290 $wrapper->contents_like(qr/
2291 ^main::\([^:]+:28\):\n
2292 28:\s+myfunc\(\);\n
2293 main::myfunc\([^:]+:25\):\n
2294 25:\s+bar\(\);\n
2295 /msx,
2296 'Test the t command with function calls.',
2297 );
2298}
2299
5e2b42dd
SF
2300# Test the o AutoTrace command with function calls
2301{
2302 my $wrapper = DebugWrap->new(
2303 {
2304 cmds =>
2305 [
2306 'o AutoTrace',
2307 'b 18',
2308 'c',
2309 'x ["foo"]',
2310 'x ["bar"]',
2311 'q',
2312 ],
2313 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2314 }
2315 );
2316
2317 $wrapper->contents_like(qr/
2318 ^main::\([^:]+:28\):\n
2319 28:\s+myfunc\(\);\n
2320 main::myfunc\([^:]+:25\):\n
2321 25:\s+bar\(\);\n
2322 /msx,
2323 'Test the t command with function calls.',
2324 );
2325}
7d9a5afb 2326
ef6abee5
SF
2327# Test the final message.
2328{
2329 my $wrapper = DebugWrap->new(
2330 {
2331 cmds =>
2332 [
2333 'c',
2334 'q',
2335 ],
2336 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2337 }
2338 );
2339
2340 $wrapper->contents_like(qr/
2341 ^Debugged\ program\ terminated\.
2342 /msx,
2343 'Test the final "Debugged program terminated" message.',
2344 );
2345}
2346
7d9a5afb
SF
2347# Test the o inhibit_exit=0 command
2348{
2349 my $wrapper = DebugWrap->new(
2350 {
2351 cmds =>
2352 [
2353 'o inhibit_exit=0',
2354 'n',
2355 'n',
2356 'n',
2357 'n',
2358 'q',
2359 ],
2360 prog => '../lib/perl5db/t/test-warnLevel-option-1',
2361 }
2362 );
2363
2364 $wrapper->contents_unlike(qr/
2365 ^Debugged\ program\ terminated\.
2366 /msx,
2367 'Test the o inhibit_exit=0 command.',
2368 );
2369}
2370
4f7c5654 2371# Test the o PrintRet=1 option
413b1248
SF
2372{
2373 my $wrapper = DebugWrap->new(
2374 {
2375 cmds =>
2376 [
2377 'o PrintRet=1',
2378 'b 29',
2379 'c',
2380 q/$x = 's';/,
2381 'b 10',
2382 'c',
2383 'r',
2384 'q',
2385 ],
2386 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2387 }
2388 );
2389
2390 $wrapper->contents_like(
2391 qr/scalar context return from main::return_scalar: 20024/,
2392 "Test o PrintRet=1",
2393 );
2394}
2395
4f7c5654
SF
2396# Test the o PrintRet=0 option
2397{
2398 my $wrapper = DebugWrap->new(
2399 {
2400 cmds =>
2401 [
2402 'o PrintRet=0',
2403 'b 29',
2404 'c',
2405 q/$x = 's';/,
2406 'b 10',
2407 'c',
2408 'r',
2409 'q',
2410 ],
2411 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2412 }
2413 );
2414
2415 $wrapper->contents_unlike(
2416 qr/scalar context/,
2417 "Test o PrintRet=0",
2418 );
2419}
2420
855abc47
SF
2421# Test the o PrintRet=1 option in list context
2422{
2423 my $wrapper = DebugWrap->new(
2424 {
2425 cmds =>
2426 [
2427 'o PrintRet=1',
2428 'b 29',
2429 'c',
2430 q/$x = 'l';/,
2431 'b 17',
2432 'c',
2433 'r',
2434 'q',
2435 ],
2436 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2437 }
2438 );
2439
2440 $wrapper->contents_like(
2441 qr/list context return from main::return_list:\n0\s*'Foo'\n1\s*'Bar'\n2\s*'Baz'\n/,
2442 "Test o PrintRet=1 in list context",
2443 );
2444}
2445
d728fe0e
SF
2446# Test the o PrintRet=0 option in list context
2447{
2448 my $wrapper = DebugWrap->new(
2449 {
2450 cmds =>
2451 [
2452 'o PrintRet=0',
2453 'b 29',
2454 'c',
2455 q/$x = 'l';/,
2456 'b 17',
2457 'c',
2458 'r',
2459 'q',
2460 ],
2461 prog => '../lib/perl5db/t/test-PrintRet-option-1',
2462 }
2463 );
2464
2465 $wrapper->contents_unlike(
2466 qr/list context/,
2467 "Test o PrintRet=0 in list context",
2468 );
2469}
2470
c8dcbe9b
SF
2471# Test the o PrintRet=1 option in void context
2472{
2473 my $wrapper = DebugWrap->new(
2474 {
2475 cmds =>
2476 [
2477 'o PrintRet=1',
2478 'b 29',
2479 'c',
2480 q/$x = 'v';/,
2481 'b 24',
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/void context return from main::return_void/,
2492 "Test o PrintRet=1 in void context",
2493 );
2494}
2495
19957b55
SF
2496# Test the o PrintRet=1 option in void context
2497{
2498 my $wrapper = DebugWrap->new(
2499 {
2500 cmds =>
2501 [
2502 'o PrintRet=0',
2503 'b 29',
2504 'c',
2505 q/$x = 'v';/,
2506 'b 24',
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/void context/,
2517 "Test o PrintRet=0 in void context",
2518 );
2519}
2520
473c46a8
SF
2521# Test the o frame option.
2522{
2523 my $wrapper = DebugWrap->new(
2524 {
2525 cmds =>
2526 [
2527 # This is to avoid getting the "Debugger program terminated"
2528 # junk that interferes with the normal output.
2529 'o inhibit_exit=0',
2530 'b 10',
2531 'c',
2532 'o frame=255',
2533 'c',
2534 'q',
2535 ],
2536 prog => '../lib/perl5db/t/test-frame-option-1',
2537 }
2538 );
2539
2540 $wrapper->contents_like(
2541 qr/
2542 in\s*\.=main::my_other_func\(3,\ 1200\)\ from.*?
2543 out\s*\.=main::my_other_func\(3,\ 1200\)\ from
2544 /msx,
2545 "Test o PrintRet=0 in void context",
2546 );
2547}
2548
635f2c9e 2549END {
4cfe45a1 2550 1 while unlink ($rc_filename, $out_fn);
635f2c9e 2551}