This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Test the m command.
[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
12f1669f 31plan(86);
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
1403# Test the a command.
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
1426# Test the 'A' command
1427{
1428 my $wrapper = DebugWrap->new(
1429 {
1430 cmds =>
1431 [
1432 'a 13 print "\nVar<Q>=$q\n"',
1433 'A 13',
1434 'c',
1435 'q',
1436 ],
1437 prog => '../lib/perl5db/t/eval-line-bug',
1438 }
1439 );
1440
1441 $wrapper->output_like(
1442 qr#\A\z#msx, # The empty string.
1443 "A command (for removing actions) is working",
1444 );
1445}
1446
1447# Test the 'A *' command
1448{
1449 my $wrapper = DebugWrap->new(
1450 {
1451 cmds =>
1452 [
1453 'a 6 print "\nFail!\n"',
1454 'a 13 print "\nVar<Q>=$q\n"',
1455 'A *',
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 all actions) is working",
1466 );
1467}
1468
1469{
1470 my $wrapper = DebugWrap->new(
1471 {
1472 cmds =>
1473 [
1474 'n',
1475 'w $foo',
1476 'c',
1477 'print "\nIDX=<$idx>\n"',
1478 'q',
1479 ],
1480 prog => '../lib/perl5db/t/test-w-statement-1',
1481 }
1482 );
1483
1484
1485 $wrapper->contents_like(qr#
1486 \$foo\ changed:\n
1487 \s+old\ value:\s+'1'\n
1488 \s+new\ value:\s+'2'\n
1489 #msx,
1490 'w command - watchpoint changed',
1491 );
1492 $wrapper->output_like(qr#
1493 \nIDX=<20>\n
1494 #msx,
1495 "w command - correct output from IDX",
1496 );
1497}
1498
1499{
1500 my $wrapper = DebugWrap->new(
1501 {
1502 cmds =>
1503 [
1504 'n',
1505 'w $foo',
1506 'W $foo',
1507 'c',
1508 'print "\nIDX=<$idx>\n"',
1509 'q',
1510 ],
1511 prog => '../lib/perl5db/t/test-w-statement-1',
1512 }
1513 );
1514
1515 $wrapper->contents_unlike(qr#
1516 \$foo\ changed:
1517 #msx,
1518 'W command - watchpoint was deleted',
1519 );
1520
1521 $wrapper->output_like(qr#
1522 \nIDX=<>\n
1523 #msx,
1524 "W command - stopped at end.",
1525 );
1526}
1527
1528# Test the W * command.
1529{
1530 my $wrapper = DebugWrap->new(
1531 {
1532 cmds =>
1533 [
1534 'n',
1535 'w $foo',
1536 'w ($foo*$foo)',
1537 'W *',
1538 'c',
1539 'print "\nIDX=<$idx>\n"',
1540 'q',
1541 ],
1542 prog => '../lib/perl5db/t/test-w-statement-1',
1543 }
1544 );
1545
1546 $wrapper->contents_unlike(qr#
1547 \$foo\ changed:
1548 #msx,
1549 '"W *" command - watchpoint was deleted',
1550 );
1551
1552 $wrapper->output_like(qr#
1553 \nIDX=<>\n
1554 #msx,
1555 '"W *" command - stopped at end.',
1556 );
1557}
1558
1559# Test the 'o' command (without further arguments).
1560{
1561 my $wrapper = DebugWrap->new(
1562 {
1563 cmds =>
1564 [
1565 'o',
1566 'q',
1567 ],
1568 prog => '../lib/perl5db/t/test-w-statement-1',
1569 }
1570 );
1571
1572 $wrapper->contents_like(qr#
1573 ^\s*warnLevel\ =\ '1'\n
1574 #msx,
1575 q#"o" command (without arguments) displays warnLevel#,
1576 );
1577
1578 $wrapper->contents_like(qr#
1579 ^\s*signalLevel\ =\ '1'\n
1580 #msx,
1581 q#"o" command (without arguments) displays signalLevel#,
1582 );
1583
1584 $wrapper->contents_like(qr#
1585 ^\s*dieLevel\ =\ '1'\n
1586 #msx,
1587 q#"o" command (without arguments) displays dieLevel#,
1588 );
1589
1590 $wrapper->contents_like(qr#
1591 ^\s*hashDepth\ =\ 'N/A'\n
1592 #msx,
1593 q#"o" command (without arguments) displays hashDepth#,
1594 );
1595}
1596
1597# Test the 'o' query command.
1598{
1599 my $wrapper = DebugWrap->new(
1600 {
1601 cmds =>
1602 [
1603 'o hashDepth? signalLevel?',
1604 'q',
1605 ],
1606 prog => '../lib/perl5db/t/test-w-statement-1',
1607 }
1608 );
1609
1610 $wrapper->contents_unlike(qr#warnLevel#,
1611 q#"o" query command does not display warnLevel#,
1612 );
1613
1614 $wrapper->contents_like(qr#
1615 ^\s*signalLevel\ =\ '1'\n
1616 #msx,
1617 q#"o" query command displays signalLevel#,
1618 );
1619
1620 $wrapper->contents_unlike(qr#dieLevel#,
1621 q#"o" query command does not display dieLevel#,
1622 );
1623
1624 $wrapper->contents_like(qr#
1625 ^\s*hashDepth\ =\ 'N/A'\n
1626 #msx,
1627 q#"o" query command displays hashDepth#,
1628 );
1629}
1630
1631# Test the 'o' set command.
1632{
1633 my $wrapper = DebugWrap->new(
1634 {
1635 cmds =>
1636 [
1637 'o signalLevel=0',
1638 'o',
1639 'q',
1640 ],
1641 prog => '../lib/perl5db/t/test-w-statement-1',
1642 }
1643 );
1644
1645 $wrapper->contents_like(qr/
1646 ^\s*(signalLevel\ =\ '0'\n)
1647 .*?
1648 ^\s*\1
1649 /msx,
1650 q#o set command works#,
1651 );
1652
1653 $wrapper->contents_like(qr#
1654 ^\s*hashDepth\ =\ 'N/A'\n
1655 #msx,
1656 q#o set command - hashDepth#,
1657 );
1658}
1659
1660# Test the '<' and "< ?" commands.
1661{
1662 my $wrapper = DebugWrap->new(
1663 {
1664 cmds =>
1665 [
1666 q/< print "\nX=<$x>\n"/,
1667 q/b 7/,
1668 q/< ?/,
1669 'c',
1670 'q',
1671 ],
1672 prog => '../lib/perl5db/t/disable-breakpoints-1',
1673 }
1674 );
1675
1676 $wrapper->contents_like(qr/
1677 ^pre-perl\ commands:\n
1678 \s*<\ --\ print\ "\\nX=<\$x>\\n"\n
1679 /msx,
1680 q#Test < and < ? commands - contents.#,
1681 );
1682
1683 $wrapper->output_like(qr#
1684 ^X=<FirstVal>\n
1685 #msx,
1686 q#Test < and < ? commands - output.#,
1687 );
1688}
1689
1690# Test the '< *' command.
1691{
1692 my $wrapper = DebugWrap->new(
1693 {
1694 cmds =>
1695 [
1696 q/< print "\nX=<$x>\n"/,
1697 q/b 7/,
1698 q/< */,
1699 'c',
1700 'q',
1701 ],
1702 prog => '../lib/perl5db/t/disable-breakpoints-1',
1703 }
1704 );
1705
1706 $wrapper->output_unlike(qr/FirstVal/,
1707 q#Test the '< *' command.#,
1708 );
1709}
1710
1711# Test the '>' and "> ?" commands.
1712{
1713 my $wrapper = DebugWrap->new(
1714 {
1715 cmds =>
1716 [
1717 q/$::foo = 500;/,
1718 q/> print "\nFOO=<$::foo>\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->contents_like(qr/
1729 ^post-perl\ commands:\n
1730 \s*>\ --\ print\ "\\nFOO=<\$::foo>\\n"\n
1731 /msx,
1732 q#Test > and > ? commands - contents.#,
1733 );
1734
1735 $wrapper->output_like(qr#
1736 ^FOO=<500>\n
1737 #msx,
1738 q#Test > and > ? commands - output.#,
1739 );
1740}
1741
1742# Test the '> *' command.
1743{
1744 my $wrapper = DebugWrap->new(
1745 {
1746 cmds =>
1747 [
1748 q/> print "\nFOO=<$::foo>\n"/,
1749 q/b 7/,
1750 q/> */,
1751 'c',
1752 'q',
1753 ],
1754 prog => '../lib/perl5db/t/disable-breakpoints-1',
1755 }
1756 );
1757
1758 $wrapper->output_unlike(qr/FOO=/,
1759 q#Test the '> *' command.#,
1760 );
1761}
1762
be1dfd82
SF
1763# Test the < and > commands together
1764{
1765 my $wrapper = DebugWrap->new(
1766 {
1767 cmds =>
1768 [
1769 q/$::lorem = 0;/,
1770 q/< $::lorem += 10;/,
1771 q/> print "\nLOREM=<$::lorem>\n"/,
1772 q/b 7/,
1773 q/b 5/,
1774 'c',
1775 'c',
1776 'q',
1777 ],
1778 prog => '../lib/perl5db/t/disable-breakpoints-1',
1779 }
1780 );
1781
1782 $wrapper->output_like(qr#
1783 ^LOREM=<10>\n
1784 #msx,
1785 q#Test < and > commands. #,
1786 );
1787}
1788
95418017
SF
1789# Test the { ? and { [command] commands.
1790{
1791 my $wrapper = DebugWrap->new(
1792 {
1793 cmds =>
1794 [
1e121f70
SF
1795 '{ ?',
1796 '{ l',
1797 '{ ?',
95418017
SF
1798 q/b 5/,
1799 q/c/,
1800 q/q/,
1801 ],
1802 prog => '../lib/perl5db/t/disable-breakpoints-1',
1803 }
1804 );
1805
1806 $wrapper->contents_like(qr#
1807 ^No\ pre-debugger\ actions\.\n
1808 .*?
1809 ^pre-debugger\ commands:\n
1810 \s+\{\ --\ l\n
1811 .*?
1812 ^5==>b\s+\$x\ =\ "FirstVal";\n
1813 6\s*\n
1814 7:\s+\$dummy\+\+;\n
1815 8\s*\n
1816 9:\s+\$x\ =\ "SecondVal";\n
1817
1818 #msx,
1819 'Test the pre-prompt debugger commands',
1820 );
1821}
1822
3743412c
SF
1823# Test the { * command.
1824{
1825 my $wrapper = DebugWrap->new(
1826 {
1827 cmds =>
1828 [
1829 '{ q',
1830 '{ *',
1831 q/b 5/,
1832 q/c/,
1833 q/print (("One" x 5), "\n");/,
1834 q/q/,
1835 ],
1836 prog => '../lib/perl5db/t/disable-breakpoints-1',
1837 }
1838 );
1839
1840 $wrapper->contents_like(qr#
1841 ^All\ \{\ actions\ cleared\.\n
1842 #msx,
1843 'Test the { * command',
1844 );
1845
1846 $wrapper->output_like(qr/OneOneOneOneOne/,
1847 '{ * test - output is OK.',
1848 );
1849}
1850
1896f514
SF
1851# Test the ! command.
1852{
1853 my $wrapper = DebugWrap->new(
1854 {
1855 cmds =>
1856 [
1857 'l 3-5',
1858 '!',
1859 'q',
1860 ],
1861 prog => '../lib/perl5db/t/disable-breakpoints-1',
1862 }
1863 );
1864
1865 $wrapper->contents_like(qr#
1866 (^3:\s+my\ \$dummy\ =\ 0;\n
1867 4\s*\n
1868 5:\s+\$x\ =\ "FirstVal";)\n
1869 .*?
1870 ^l\ 3-5\n
1871 \1
1872 #msx,
1873 'Test the ! command (along with l 3-5)',
1874 );
1875}
1876
ada05bfe
SF
1877# Test the ! -number command.
1878{
1879 my $wrapper = DebugWrap->new(
1880 {
1881 cmds =>
1882 [
1883 'l 3-5',
1884 'l 2',
1885 '! -1',
1886 'q',
1887 ],
1888 prog => '../lib/perl5db/t/disable-breakpoints-1',
1889 }
1890 );
1891
1892 $wrapper->contents_like(qr#
1893 (^3:\s+my\ \$dummy\ =\ 0;\n
1894 4\s*\n
1895 5:\s+\$x\ =\ "FirstVal";)\n
1896 .*?
1897 ^2==\>\s+my\ \$x\ =\ "One";\n
1898 .*?
1899 ^l\ 3-5\n
1900 \1
1901 #msx,
1902 'Test the ! -n command (along with l)',
1903 );
1904}
1905
5442f949
SF
1906# Test the 'source' command.
1907{
1908 my $wrapper = DebugWrap->new(
1909 {
1910 cmds =>
1911 [
1912 'source ../lib/perl5db/t/source-cmd-test.perldb',
1913 # If we have a 'q' here, then the typeahead will override the
1914 # input, and so it won't be reached - solution:
1915 # put a q inside the .perldb commands.
1916 # ( This may be a bug or a misfeature. )
1917 ],
1918 prog => '../lib/perl5db/t/disable-breakpoints-1',
1919 }
1920 );
1921
1922 $wrapper->contents_like(qr#
1923 ^3:\s+my\ \$dummy\ =\ 0;\n
1924 4\s*\n
1925 5:\s+\$x\ =\ "FirstVal";\n
1926 6\s*\n
1927 7:\s+\$dummy\+\+;\n
1928 8\s*\n
1929 9:\s+\$x\ =\ "SecondVal";\n
1930 10\s*\n
1931 #msx,
1932 'Test the source command (along with l)',
1933 );
35879b90
SF
1934}
1935
1936# Test the 'source' command being traversed from withing typeahead.
1937{
1938 my $wrapper = DebugWrap->new(
1939 {
1940 cmds =>
1941 [
1942 'source ../lib/perl5db/t/source-cmd-test-no-q.perldb',
1943 'q',
1944 ],
1945 prog => '../lib/perl5db/t/disable-breakpoints-1',
1946 }
1947 );
5442f949 1948
35879b90
SF
1949 $wrapper->contents_like(qr#
1950 ^3:\s+my\ \$dummy\ =\ 0;\n
1951 4\s*\n
1952 5:\s+\$x\ =\ "FirstVal";\n
1953 6\s*\n
1954 7:\s+\$dummy\+\+;\n
1955 8\s*\n
1956 9:\s+\$x\ =\ "SecondVal";\n
1957 10\s*\n
1958 #msx,
1959 'Test the source command inside a typeahead',
1960 );
5442f949
SF
1961}
1962
741f88f9
SF
1963# Test the 'H -number' command.
1964{
1965 my $wrapper = DebugWrap->new(
1966 {
1967 cmds =>
1968 [
1969 'l 1-10',
1970 'l 5-10',
1971 'x "Hello World"',
1972 'l 1-5',
1973 'b 3',
1974 'x (20+4)',
1975 'H -7',
1976 'q',
1977 ],
1978 prog => '../lib/perl5db/t/disable-breakpoints-1',
1979 }
1980 );
1981
1982 $wrapper->contents_like(qr#
1983 ^\d+:\s+H\ -7\n
1984 \d+:\s+x\ \(20\+4\)\n
1985 \d+:\s+b\ 3\n
1986 \d+:\s+l\ 1-5\n
1987 \d+:\s+x\ "Hello\ World"\n
1988 \d+:\s+l\ 5-10\n
1989 \d+:\s+l\ 1-10\n
1990 #msx,
6bf7e1ad 1991 'Test the H -num command',
741f88f9
SF
1992 );
1993}
1994
761ec47e
SF
1995# Add a test for H (without arguments)
1996{
1997 my $wrapper = DebugWrap->new(
1998 {
1999 cmds =>
2000 [
2001 'l 1-10',
2002 'l 5-10',
2003 'x "Hello World"',
2004 'l 1-5',
2005 'b 3',
2006 'x (20+4)',
2007 'H',
2008 'q',
2009 ],
2010 prog => '../lib/perl5db/t/disable-breakpoints-1',
2011 }
2012 );
2013
2014 $wrapper->contents_like(qr#
2015 ^\d+:\s+x\ \(20\+4\)\n
2016 \d+:\s+b\ 3\n
2017 \d+:\s+l\ 1-5\n
2018 \d+:\s+x\ "Hello\ World"\n
2019 \d+:\s+l\ 5-10\n
2020 \d+:\s+l\ 1-10\n
2021 #msx,
6bf7e1ad 2022 'Test the H command (without a number.)',
761ec47e
SF
2023 );
2024}
2025
088a867e
SF
2026{
2027 my $wrapper = DebugWrap->new(
2028 {
2029 cmds =>
2030 [
2031 '= quit q',
2032 '= foobar l',
2033 'foobar',
2034 'quit',
2035 ],
2036 prog => '../lib/perl5db/t/test-l-statement-1',
2037 }
2038 );
2039
2040 $wrapper->contents_like(
2041 qr/
2042 ^1==>\s+\$x\ =\ 1;\n
2043 2:\s+print\ "1\\n";\n
2044 3\s*\n
2045 4:\s+\$x\ =\ 2;\n
2046 5:\s+print\ "2\\n";\n
2047 /msx,
2048 'Test the = (command alias) command.',
2049 );
2050}
2051
12f1669f
SF
2052# Add a test for H (without arguments)
2053{
2054 my $wrapper = DebugWrap->new(
2055 {
2056 cmds =>
2057 [
2058 'm main',
2059 'q',
2060 ],
2061 prog => '../lib/perl5db/t/disable-breakpoints-1',
2062 }
2063 );
2064
2065 $wrapper->contents_like(qr#
2066 ^via\ UNIVERSAL:\ DOES$
2067 #msx,
2068 "Test m for main - 1",
2069 );
2070
2071 $wrapper->contents_like(qr#
2072 ^via\ UNIVERSAL:\ can$
2073 #msx,
2074 "Test m for main - 2",
2075 );
2076}
2077
635f2c9e 2078END {
4cfe45a1 2079 1 while unlink ($rc_filename, $out_fn);
635f2c9e 2080}