This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Extract _calc_threads_wrapper.
[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
ada05bfe 31plan(79);
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# Test [perl #61222]
69{
221d5972 70 local $ENV{PERLDB_OPTS};
7eedc5ec 71 rc(
4cfe45a1 72 <<'EOF',
7eedc5ec 73 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
7eedc5ec 74
7eedc5ec 75 sub afterinit {
4cfe45a1 76 push(@DB::typeahead,
7eedc5ec
B
77 'm Pie',
78 'q',
79 );
4cfe45a1
SF
80 }
81EOF
7eedc5ec
B
82 );
83
84 my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-61222');
4cfe45a1 85 unlike(_out_contents(), qr/INCORRECT/, "[perl #61222]");
7eedc5ec
B
86}
87
88
89
90# Test for Proxy constants
91{
92 rc(
4cfe45a1 93 <<'EOF',
7eedc5ec 94
4cfe45a1
SF
95&parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out");
96
97sub afterinit {
98 push(@DB::typeahead,
99 'm main->s1',
100 'q',
101 );
102}
103
104EOF
7eedc5ec
B
105 );
106
107 my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
108 is($output, "", "proxy constant subroutines");
109}
110
b7bfa855
B
111# [perl #66110] Call a subroutine inside a regex
112{
113 local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
114 my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
115 like($output, "All tests successful.", "[perl #66110]");
116}
117
611272bb
PS
118# [perl 104168] level option for tracing
119{
120 rc(<<'EOF');
121&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
122
123sub afterinit {
124 push (@DB::typeahead,
125 't 2',
126 'c',
127 'q',
128 );
129
130}
131EOF
132
133 my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-104168');
5e2fff4a 134 my $contents = _out_contents();
611272bb
PS
135 like($contents, qr/level 2/, "[perl #104168]");
136 unlike($contents, qr/baz/, "[perl #104168]");
137}
138
07004ebb
DM
139# taint tests
140
141{
142 local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
143 my $output = runperl(switches => [ '-d', '-T' ], stderr => 1,
4cfe45a1 144 progfile => '../lib/perl5db/t/taint');
314655b3 145 chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
07004ebb
DM
146 is($output, '[$^X][done]', "taint");
147}
148
5e2fff4a
SF
149package DebugWrap;
150
151sub new {
152 my $class = shift;
153
154 my $self = bless {}, $class;
155
156 $self->_init(@_);
157
158 return $self;
159}
160
161sub _cmds {
162 my $self = shift;
163
164 if (@_) {
165 $self->{_cmds} = shift;
166 }
167
168 return $self->{_cmds};
169}
170
171sub _prog {
172 my $self = shift;
173
174 if (@_) {
175 $self->{_prog} = shift;
176 }
177
178 return $self->{_prog};
179}
180
181sub _output {
182 my $self = shift;
183
184 if (@_) {
185 $self->{_output} = shift;
186 }
187
188 return $self->{_output};
189}
190
191sub _include_t
2211a10b 192{
5e2fff4a 193 my $self = shift;
2211a10b 194
5e2fff4a
SF
195 if (@_)
196 {
197 $self->{_include_t} = shift;
198 }
2211a10b 199
5e2fff4a 200 return $self->{_include_t};
2211a10b 201}
2211a10b 202
e931e533
SF
203sub _stderr_val
204{
205 my $self = shift;
206
207 if (@_)
208 {
209 $self->{_stderr_val} = shift;
210 }
211
212 return $self->{_stderr_val};
213}
214
215sub field
216{
217 my $self = shift;
218
219 if (@_)
220 {
221 $self->{field} = shift;
222 }
223
224 return $self->{field};
225}
b16615d5
SF
226
227sub _switches
228{
229 my $self = shift;
230
231 if (@_)
232 {
233 $self->{_switches} = shift;
234 }
235
236 return $self->{_switches};
237}
238
5e2fff4a
SF
239sub _contents
240{
241 my $self = shift;
2211a10b 242
5e2fff4a
SF
243 if (@_)
244 {
245 $self->{_contents} = shift;
246 }
247
248 return $self->{_contents};
2211a10b
SF
249}
250
5e2fff4a
SF
251sub _init
252{
253 my ($self, $args) = @_;
4cfe45a1 254
5e2fff4a
SF
255 my $cmds = $args->{cmds};
256
257 if (ref($cmds) ne 'ARRAY') {
258 die "cmds must be an array of commands.";
259 }
260
261 $self->_cmds($cmds);
262
263 my $prog = $args->{prog};
264
265 if (ref($prog) ne '' or !defined($prog)) {
266 die "prog should be a path to a program file.";
267 }
268
269 $self->_prog($prog);
270
271 $self->_include_t($args->{include_t} ? 1 : 0);
272
e931e533
SF
273 $self->_stderr_val(exists($args->{stderr}) ? $args->{stderr} : 1);
274
b16615d5
SF
275 if (exists($args->{switches}))
276 {
277 $self->_switches($args->{switches});
278 }
279
5e2fff4a
SF
280 $self->_run();
281
282 return;
283}
284
285sub _quote
e09195af 286{
5e2fff4a 287 my ($self, $str) = @_;
e09195af 288
5e2fff4a
SF
289 $str =~ s/(["\@\$\\])/\\$1/g;
290 $str =~ s/\n/\\n/g;
291 $str =~ s/\r/\\r/g;
292
293 return qq{"$str"};
294}
295
296sub _run {
297 my $self = shift;
298
299 my $rc = qq{&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");\n};
300
301 $rc .= join('',
302 map { "$_\n"}
303 (q#sub afterinit {#,
304 q#push (@DB::typeahead,#,
305 (map { $self->_quote($_) . "," } @{$self->_cmds()}),
306 q#);#,
307 q#}#,
308 )
e09195af
SF
309 );
310
5e2fff4a
SF
311 # I guess two objects like that cannot be used at the same time.
312 # Oh well.
313 ::rc($rc);
314
315 my $output =
316 ::runperl(
317 switches =>
318 [
b16615d5 319 ($self->_switches ? (@{$self->_switches()}) : ('-d')),
5e2fff4a
SF
320 ($self->_include_t ? ('-I', '../lib/perl5db/t') : ())
321 ],
e931e533
SF
322 (defined($self->_stderr_val())
323 ? (stderr => $self->_stderr_val())
324 : ()
325 ),
5e2fff4a
SF
326 progfile => $self->_prog()
327 );
328
329 $self->_output($output);
330
331 $self->_contents(::_out_contents());
332
333 return;
e09195af 334}
e09195af 335
5e2fff4a
SF
336sub output_like {
337 my ($self, $re, $msg) = @_;
338
339 local $::Level = $::Level + 1;
340 ::like($self->_output(), $re, $msg);
341}
342
72d7d80d
SF
343sub output_unlike {
344 my ($self, $re, $msg) = @_;
345
346 local $::Level = $::Level + 1;
347 ::unlike($self->_output(), $re, $msg);
348}
349
5e2fff4a
SF
350sub contents_like {
351 my ($self, $re, $msg) = @_;
352
353 local $::Level = $::Level + 1;
354 ::like($self->_contents(), $re, $msg);
355}
356
72d7d80d
SF
357sub contents_unlike {
358 my ($self, $re, $msg) = @_;
359
360 local $::Level = $::Level + 1;
361 ::unlike($self->_contents(), $re, $msg);
362}
363
5e2fff4a
SF
364package main;
365
708dd780
SF
366{
367 local $ENV{PERLDB_OPTS} = "ReadLine=0";
368 my $target = '../lib/perl5db/t/eval-line-bug';
369 my $wrapper = DebugWrap->new(
370 {
371 cmds =>
372 [
373 'b 23',
374 'n',
375 'n',
376 'n',
377 'c', # line 23
378 'n',
379 "p \@{'main::_<$target'}",
380 'q',
381 ],
382 prog => $target,
383 }
384 );
385 $wrapper->contents_like(
386 qr/sub factorial/,
387 'The ${main::_<filename} variable in the debugger was not destroyed',
388 );
389}
390
7cdb20ca 391sub _calc_new_var_wrapper
b2e270a3 392{
e931e533
SF
393 my $args = shift;
394
395 my $extra_opts = delete($args->{extra_opts});
5c976af9
SF
396 $extra_opts ||= '';
397 local $ENV{PERLDB_OPTS} = "ReadLine=0" . $extra_opts;
398 return DebugWrap->new(
b2e270a3
SF
399 {
400 cmds =>
401 [
402 'b 23',
e931e533 403 'c',
b2e270a3
SF
404 '$new_var = "Foo"',
405 'x "new_var = <$new_var>\\n"',
406 'q',
407 ],
e931e533
SF
408 prog => delete($args->{prog}),
409 %$args,
b2e270a3
SF
410 }
411 );
5c976af9 412}
b2e270a3 413
12cb1cd2
SF
414sub _calc_threads_wrapper
415{
416 my $args = shift;
417
418 return _calc_new_var_wrapper(
419 {
420 switches => [ '-dt', ],
421 stderr => 1,
422 %$args
423 }
424 );
425}
426
5c976af9 427{
7cdb20ca 428 _calc_new_var_wrapper({ prog => '../lib/perl5db/t/eval-line-bug'})
5c976af9
SF
429 ->contents_like(
430 qr/new_var = <Foo>/,
431 "no strict 'vars' in evaluated lines.",
432 );
b2e270a3 433}
5c976af9 434
e931e533 435{
7cdb20ca 436 _calc_new_var_wrapper(
e931e533
SF
437 {
438 prog => '../lib/perl5db/t/lvalue-bug',
439 stderr => undef(),
440 },
441 )->output_like(
442 qr/foo is defined/,
443 'lvalue subs work in the debugger',
444 );
445}
446
8ebd940c 447{
7cdb20ca 448 _calc_new_var_wrapper(
8ebd940c
SF
449 {
450 prog => '../lib/perl5db/t/symbol-table-bug',
451 extra_opts => "NonStop=1",
452 stderr => undef(),
453 }
454 )->output_like(
455 qr/Undefined symbols 0/,
456 'there are no undefined values in the symbol table',
457 );
458}
459
b16615d5
SF
460SKIP:
461{
462 if ( $Config{usethreads} ) {
463 skip('This perl has threads, skipping non-threaded debugger tests');
464 }
465 else {
466 my $error = 'This Perl not built to support threads';
12cb1cd2 467 _calc_threads_wrapper(
b16615d5
SF
468 {
469 prog => '../lib/perl5db/t/eval-line-bug',
b16615d5
SF
470 }
471 )->output_like(
472 qr/\Q$error\E/,
473 'Perl debugger correctly complains that it was not built with threads',
474 );
475 }
476}
477
a9879eb8
SF
478SKIP:
479{
480 if ( $Config{usethreads} ) {
12cb1cd2 481 _calc_threads_wrapper(
a9879eb8
SF
482 {
483 prog => '../lib/perl5db/t/symbol-table-bug',
a9879eb8
SF
484 }
485 )->output_like(
486 qr/Undefined symbols 0/,
487 'there are no undefined values in the symbol table when running with thread support',
488 );
489 }
490 else {
491 skip("This perl is not threaded, skipping threaded debugger tests");
492 }
493}
494
5e2fff4a
SF
495# Testing that we can set a line in the middle of the file.
496{
497 my $wrapper = DebugWrap->new(
498 {
499 cmds =>
500 [
501 'b ../lib/perl5db/t/MyModule.pm:12',
502 'c',
503 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
504 'c',
505 'q',
506 ],
507 include_t => 1,
508 prog => '../lib/perl5db/t/filename-line-breakpoint'
509 }
510 );
511
512 $wrapper->output_like(qr/
513 ^Var=Bar$
514 .*
515 ^In\ MyModule\.$
516 .*
517 ^In\ Main\ File\.$
518 .*
e09195af 519 /msx,
5e2fff4a 520 "Can set breakpoint in a line in the middle of the file.");
e09195af
SF
521}
522
5e2fff4a 523# Testing that we can set a breakpoint
e09195af 524{
5e2fff4a
SF
525 my $wrapper = DebugWrap->new(
526 {
527 prog => '../lib/perl5db/t/breakpoint-bug',
528 cmds =>
529 [
530 'b 6',
531 'c',
532 q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/,
533 'c',
534 'q',
535 ],
536 },
537 );
e09195af 538
5e2fff4a
SF
539 $wrapper->output_like(
540 qr/X=\{Two\}/msx,
541 "Can set breakpoint in a line."
542 );
543}
544
545# Testing that we can disable a breakpoint at a numeric line.
546{
547 my $wrapper = DebugWrap->new(
548 {
549 prog => '../lib/perl5db/t/disable-breakpoints-1',
550 cmds =>
551 [
552 'b 7',
553 'b 11',
554 'disable 7',
555 'c',
556 q/print "X={$x}\n";/,
557 'c',
558 'q',
559 ],
560 }
e09195af 561 );
b7bfa855 562
5e2fff4a
SF
563 $wrapper->output_like(qr/X=\{SecondVal\}/ms,
564 "Can set breakpoint in a line.");
e09195af 565}
e09195af 566
5e2fff4a
SF
567# Testing that we can re-enable a breakpoint at a numeric line.
568{
569 my $wrapper = DebugWrap->new(
570 {
571 prog => '../lib/perl5db/t/disable-breakpoints-2',
572 cmds =>
573 [
574 'b 8',
575 'b 24',
576 'disable 24',
577 'c',
578 'enable 24',
579 'c',
580 q/print "X={$x}\n";/,
581 'c',
582 'q',
583 ],
584 },
585 );
586
587 $wrapper->output_like(
588 qr/
e09195af
SF
589 X=\{SecondValOneHundred\}
590 /msx,
5e2fff4a
SF
591 "Can set breakpoint in a line."
592 );
e09195af 593}
635f2c9e
RGS
594# clean up.
595
e09195af
SF
596# Disable and enable for breakpoints on outer files.
597{
5e2fff4a
SF
598 my $wrapper = DebugWrap->new(
599 {
600 cmds =>
601 [
602 'b 10',
603 'b ../lib/perl5db/t/EnableModule.pm:14',
604 'disable ../lib/perl5db/t/EnableModule.pm:14',
605 'c',
606 'enable ../lib/perl5db/t/EnableModule.pm:14',
607 'c',
608 q/print "X={$x}\n";/,
609 'c',
610 'q',
611 ],
612 prog => '../lib/perl5db/t/disable-breakpoints-3',
613 include_t => 1,
614 }
e09195af
SF
615 );
616
5e2fff4a 617 $wrapper->output_like(qr/
e09195af
SF
618 X=\{SecondValTwoHundred\}
619 /msx,
620 "Can set breakpoint in a line.");
621}
bdba49ad
SF
622
623# Testing that the prompt with the information appears.
624{
5e2fff4a
SF
625 my $wrapper = DebugWrap->new(
626 {
627 cmds => ['q'],
628 prog => '../lib/perl5db/t/disable-breakpoints-1',
629 }
bdba49ad
SF
630 );
631
5e2fff4a 632 $wrapper->contents_like(qr/
bdba49ad
SF
633 ^main::\([^\)]*\bdisable-breakpoints-1:2\):\n
634 2:\s+my\ \$x\ =\ "One";\n
635 /msx,
636 "Prompt should display the first line of code.");
637}
638
639# Testing that R (restart) and "B *" work.
640{
5e2fff4a
SF
641 my $wrapper = DebugWrap->new(
642 {
643 cmds =>
644 [
645 'b 13',
646 'c',
647 'B *',
648 'b 9',
649 'R',
650 'c',
651 q/print "X={$x};dummy={$dummy}\n";/,
652 'q',
653 ],
654 prog => '../lib/perl5db/t/disable-breakpoints-1',
655 }
bdba49ad
SF
656 );
657
5e2fff4a 658 $wrapper->output_like(qr/
bdba49ad
SF
659 X=\{FirstVal\};dummy=\{1\}
660 /msx,
661 "Restart and delete all breakpoints work properly.");
662}
663
5d5d9ea3 664{
5e2fff4a
SF
665 my $wrapper = DebugWrap->new(
666 {
667 cmds =>
668 [
669 'c 15',
670 q/print "X={$x}\n";/,
671 'c',
672 'q',
673 ],
674 prog => '../lib/perl5db/t/disable-breakpoints-1',
675 }
5d5d9ea3
SF
676 );
677
5e2fff4a 678 $wrapper->output_like(qr/
5d5d9ea3
SF
679 X=\{ThirdVal\}
680 /msx,
681 "'c line_num' is working properly.");
682}
683
5343a617 684{
5e2fff4a
SF
685 my $wrapper = DebugWrap->new(
686 {
687 cmds =>
688 [
689 'n',
690 'n',
691 'b . $exp > 200',
692 'c',
693 q/print "Exp={$exp}\n";/,
694 'q',
695 ],
696 prog => '../lib/perl5db/t/break-on-dot',
697 }
5343a617 698 );
5343a617 699
5e2fff4a 700 $wrapper->output_like(qr/
5343a617
SF
701 Exp=\{256\}
702 /msx,
703 "'b .' is working correctly.");
704}
705
8dc67a69
SF
706# Testing that the prompt with the information appears inside a subroutine call.
707# See https://rt.perl.org/rt3/Ticket/Display.html?id=104820
708{
5e2fff4a
SF
709 my $wrapper = DebugWrap->new(
710 {
711 cmds =>
712 [
713 'c back',
714 'q',
715 ],
716 prog => '../lib/perl5db/t/with-subroutine',
717 }
8dc67a69 718 );
8dc67a69 719
5e2fff4a 720 $wrapper->contents_like(
8dc67a69
SF
721 qr/
722 ^main::back\([^\)\n]*\bwith-subroutine:15\):[\ \t]*\n
723 ^15:\s*print\ "hello\ back\\n";
724 /msx,
725 "Prompt should display the line of code inside a subroutine.");
726}
727
984e0ec4
SF
728# Checking that the p command works.
729{
5e2fff4a
SF
730 my $wrapper = DebugWrap->new(
731 {
732 cmds =>
733 [
734 'p "<<<" . (4*6) . ">>>"',
735 'q',
736 ],
737 prog => '../lib/perl5db/t/with-subroutine',
738 }
984e0ec4
SF
739 );
740
5e2fff4a 741 $wrapper->contents_like(
984e0ec4
SF
742 qr/<<<24>>>/,
743 "p command works.");
744}
745
9f810cd7
SF
746# Tests for x.
747{
5e2fff4a
SF
748 my $wrapper = DebugWrap->new(
749 {
750 cmds =>
751 [
752 q/x {500 => 600}/,
753 'q',
754 ],
755 prog => '../lib/perl5db/t/with-subroutine',
756 }
9f810cd7
SF
757 );
758
5e2fff4a 759 $wrapper->contents_like(
9f810cd7
SF
760 # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
761 qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/ms,
762 "x command test."
763 );
764}
765
5bc17875
SF
766# Tests for "T" (stack trace).
767{
5bc17875 768 my $prog_fn = '../lib/perl5db/t/rt-104168';
5e2fff4a
SF
769 my $wrapper = DebugWrap->new(
770 {
771 prog => $prog_fn,
772 cmds =>
773 [
774 'c baz',
775 'T',
776 'q',
777 ],
778 }
779 );
5bc17875
SF
780 my $re_text = join('',
781 map {
782 sprintf(
783 "%s = %s\\(\\) called from file " .
784 "'" . quotemeta($prog_fn) . "' line %s\\n",
785 (map { quotemeta($_) } @$_)
786 )
2c247e84 787 }
5bc17875
SF
788 (
789 ['.', 'main::baz', 14,],
790 ['.', 'main::bar', 9,],
2c247e84 791 ['.', 'main::foo', 6],
5bc17875
SF
792 )
793 );
5e2fff4a 794 $wrapper->contents_like(
5bc17875
SF
795 # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
796 qr/^$re_text/ms,
797 "T command test."
798 );
799}
8fe891f1
SF
800
801# Test for s.
802{
5e2fff4a
SF
803 my $wrapper = DebugWrap->new(
804 {
805 cmds =>
806 [
807 'b 9',
808 'c',
809 's',
810 q/print "X={$x};dummy={$dummy}\n";/,
811 'q',
812 ],
813 prog => '../lib/perl5db/t/disable-breakpoints-1'
814 }
8fe891f1
SF
815 );
816
5e2fff4a 817 $wrapper->output_like(qr/
8fe891f1
SF
818 X=\{SecondVal\};dummy=\{1\}
819 /msx,
820 'test for s - single step',
821 );
822}
823
65ab0314 824{
5e2fff4a
SF
825 my $wrapper = DebugWrap->new(
826 {
827 cmds =>
828 [
829 'n',
830 'n',
831 'b . $exp > 200',
832 'c',
833 q/print "Exp={$exp}\n";/,
834 'q',
835 ],
836 prog => '../lib/perl5db/t/break-on-dot'
837 }
65ab0314
SF
838 );
839
5e2fff4a 840 $wrapper->output_like(qr/
65ab0314
SF
841 Exp=\{256\}
842 /msx,
843 "'b .' is working correctly.");
844}
845
846{
65ab0314 847 my $prog_fn = '../lib/perl5db/t/rt-104168';
5e2fff4a
SF
848 my $wrapper = DebugWrap->new(
849 {
850 cmds =>
851 [
852 's',
853 'q',
854 ],
855 prog => $prog_fn,
856 }
857 );
65ab0314 858
5e2fff4a 859 $wrapper->contents_like(
65ab0314
SF
860 qr/
861 ^main::foo\([^\)\n]*\brt-104168:9\):[\ \t]*\n
862 ^9:\s*bar\(\);
863 /msx,
864 'Test for the s command.',
865 );
866}
867
5d83cde2 868{
5e2fff4a
SF
869 my $wrapper = DebugWrap->new(
870 {
871 cmds =>
872 [
873 's uncalled_subroutine()',
874 'c',
875 'q',
876 ],
5d83cde2 877
5e2fff4a 878 prog => '../lib/perl5db/t/uncalled-subroutine'}
5d83cde2
SF
879 );
880
5e2fff4a 881 $wrapper->output_like(
5d83cde2
SF
882 qr/<1,2,3,4,5>\n/,
883 'uncalled_subroutine was called after s EXPR()',
884 );
5d83cde2
SF
885}
886
d7b8b95b 887{
5e2fff4a
SF
888 my $wrapper = DebugWrap->new(
889 {
890 cmds =>
891 [
892 'n uncalled_subroutine()',
893 'c',
894 'q',
895 ],
896 prog => '../lib/perl5db/t/uncalled-subroutine',
897 }
d7b8b95b
SF
898 );
899
5e2fff4a 900 $wrapper->output_like(
d7b8b95b
SF
901 qr/<1,2,3,4,5>\n/,
902 'uncalled_subroutine was called after n EXPR()',
903 );
d7b8b95b
SF
904}
905
ea7bdd87
VP
906{
907 my $wrapper = DebugWrap->new(
908 {
909 cmds =>
910 [
911 'b fact',
912 'c',
913 'c',
914 'c',
915 'n',
916 'print "<$n>"',
917 'q',
918 ],
919 prog => '../lib/perl5db/t/fact',
920 }
921 );
922
923 $wrapper->output_like(
924 qr/<3>/,
925 'b subroutine works fine',
926 );
927}
928
f311474d
VP
929# Test for 'M' (module list).
930{
931 my $wrapper = DebugWrap->new(
932 {
933 cmds =>
934 [
935 'M',
936 'q',
937 ],
938 prog => '../lib/perl5db/t/load-modules'
939 }
940 );
941
942 $wrapper->contents_like(
943 qr[Scalar/Util\.pm],
944 'M (module list) works fine',
945 );
946}
947
55783941
SF
948{
949 my $wrapper = DebugWrap->new(
950 {
951 cmds =>
952 [
953 'b 14',
954 'c',
955 '$flag = 1;',
956 'r',
957 'print "Var=$var\n";',
958 'q',
959 ],
960 prog => '../lib/perl5db/t/test-r-statement',
961 }
962 );
963
964 $wrapper->output_like(
965 qr/
966 ^Foo$
967 .*?
968 ^Bar$
969 .*?
970 ^Var=Test$
971 /msx,
972 'r statement is working properly.',
973 );
974}
975
976{
977 my $wrapper = DebugWrap->new(
978 {
979 cmds =>
980 [
981 'l',
982 'q',
983 ],
984 prog => '../lib/perl5db/t/test-l-statement-1',
985 }
986 );
987
988 $wrapper->contents_like(
989 qr/
990 ^1==>\s+\$x\ =\ 1;\n
991 2:\s+print\ "1\\n";\n
992 3\s*\n
993 4:\s+\$x\ =\ 2;\n
994 5:\s+print\ "2\\n";\n
995 /msx,
996 'l statement is working properly (test No. 1).',
997 );
998}
999
2c247e84
SF
1000{
1001 my $wrapper = DebugWrap->new(
1002 {
1003 cmds =>
1004 [
1005 'l',
1006 q/# After l 1/,
1007 'l',
1008 q/# After l 2/,
1009 '-',
1010 q/# After -/,
1011 'q',
1012 ],
1013 prog => '../lib/perl5db/t/test-l-statement-1',
1014 }
1015 );
1016
1017 my $first_l_out = qr/
1018 1==>\s+\$x\ =\ 1;\n
1019 2:\s+print\ "1\\n";\n
1020 3\s*\n
1021 4:\s+\$x\ =\ 2;\n
1022 5:\s+print\ "2\\n";\n
1023 6\s*\n
1024 7:\s+\$x\ =\ 3;\n
1025 8:\s+print\ "3\\n";\n
1026 9\s*\n
1027 10:\s+\$x\ =\ 4;\n
1028 /msx;
1029
1030 my $second_l_out = qr/
1031 11:\s+print\ "4\\n";\n
1032 12\s*\n
1033 13:\s+\$x\ =\ 5;\n
1034 14:\s+print\ "5\\n";\n
1035 15\s*\n
1036 16:\s+\$x\ =\ 6;\n
1037 17:\s+print\ "6\\n";\n
1038 18\s*\n
1039 19:\s+\$x\ =\ 7;\n
1040 20:\s+print\ "7\\n";\n
1041 /msx;
1042 $wrapper->contents_like(
1043 qr/
1044 ^$first_l_out
1045 [^\n]*?DB<\d+>\ \#\ After\ l\ 1\n
1046 [\ \t]*\n
1047 [^\n]*?DB<\d+>\ l\s*\n
1048 $second_l_out
1049 [^\n]*?DB<\d+>\ \#\ After\ l\ 2\n
1050 [\ \t]*\n
1051 [^\n]*?DB<\d+>\ -\s*\n
1052 $first_l_out
1053 [^\n]*?DB<\d+>\ \#\ After\ -\n
1054 /msx,
1055 'l followed by l and then followed by -',
1056 );
1057}
1058
1059{
1060 my $wrapper = DebugWrap->new(
1061 {
1062 cmds =>
1063 [
1064 'l fact',
1065 'q',
1066 ],
1067 prog => '../lib/perl5db/t/test-l-statement-2',
1068 }
1069 );
1070
1071 my $first_l_out = qr/
1072 6\s+sub\ fact\ \{\n
1073 7:\s+my\ \$n\ =\ shift;\n
1074 8:\s+if\ \(\$n\ >\ 1\)\ \{\n
1075 9:\s+return\ \$n\ \*\ fact\(\$n\ -\ 1\);
1076 /msx;
1077
1078 $wrapper->contents_like(
1079 qr/
1080 DB<1>\s+l\ fact\n
1081 $first_l_out
1082 /msx,
1083 'l subroutine_name',
1084 );
1085}
1086
1087{
1088 my $wrapper = DebugWrap->new(
1089 {
1090 cmds =>
1091 [
1092 'b fact',
1093 'c',
1094 # Repeat several times to avoid @typeahead problems.
1095 '.',
1096 '.',
1097 '.',
1098 '.',
1099 'q',
1100 ],
1101 prog => '../lib/perl5db/t/test-l-statement-2',
1102 }
1103 );
1104
1105 my $line_out = qr /
1106 ^main::fact\([^\n]*?:7\):\n
1107 ^7:\s+my\ \$n\ =\ shift;\n
1108 /msx;
1109
1110 $wrapper->contents_like(
1111 qr/
1112 $line_out
1113 $line_out
1114 /msx,
1115 'Test the "." command',
1116 );
1117}
1118
1119# Testing that the f command works.
1120{
1121 my $wrapper = DebugWrap->new(
1122 {
1123 cmds =>
1124 [
1125 'f ../lib/perl5db/t/MyModule.pm',
1126 'b 12',
1127 'c',
1128 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
1129 'c',
1130 'q',
1131 ],
1132 include_t => 1,
1133 prog => '../lib/perl5db/t/filename-line-breakpoint'
1134 }
1135 );
1136
1137 $wrapper->output_like(qr/
1138 ^Var=Bar$
1139 .*
1140 ^In\ MyModule\.$
1141 .*
1142 ^In\ Main\ File\.$
1143 .*
1144 /msx,
1145 "f command is working.",
1146 );
1147}
1148
1149# We broke the /pattern/ command because apparently the CORE::eval-s inside
1150# lib/perl5db.pl cannot handle lexical variable properly. So we now fix this
1151# bug.
1152#
1153# TODO :
1154#
1155# 1. Go over the rest of the "eval"s in lib/perl5db.t and see if they cause
1156# problems.
1157{
1158 my $wrapper = DebugWrap->new(
1159 {
1160 cmds =>
1161 [
1162 '/for/',
1163 'q',
1164 ],
1165 prog => '../lib/perl5db/t/eval-line-bug',
1166 }
1167 );
1168
1169 $wrapper->contents_like(
1170 qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1171 "/pat/ command is working and found a match.",
1172 );
1173}
1174
1175{
1176 my $wrapper = DebugWrap->new(
1177 {
1178 cmds =>
1179 [
1180 'b 22',
1181 'c',
1182 '?for?',
1183 'q',
1184 ],
1185 prog => '../lib/perl5db/t/eval-line-bug',
1186 }
1187 );
1188
1189 $wrapper->contents_like(
1190 qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1191 "?pat? command is working and found a match.",
1192 );
1193}
1194
72d7d80d
SF
1195# Test the L command.
1196{
1197 my $wrapper = DebugWrap->new(
1198 {
1199 cmds =>
1200 [
1201 'b 6',
1202 'b 13 ($q == 5)',
1203 'L',
1204 'q',
1205 ],
1206 prog => '../lib/perl5db/t/eval-line-bug',
1207 }
1208 );
1209
1210 $wrapper->contents_like(
1211 qr#
1212 ^\S*?eval-line-bug:\n
1213 \s*6:\s*my\ \$i\ =\ 5;\n
1214 \s*break\ if\ \(1\)\n
1215 \s*13:\s*\$i\ \+=\ \$q;\n
1216 \s*break\ if\ \(\(\$q\ ==\ 5\)\)\n
1217 #msx,
1218 "L command is listing breakpoints",
1219 );
1220}
1221
1222# Test the L command for watch expressions.
1223{
1224 my $wrapper = DebugWrap->new(
1225 {
1226 cmds =>
1227 [
1228 'w (5+6)',
1229 'L',
1230 'q',
1231 ],
1232 prog => '../lib/perl5db/t/eval-line-bug',
1233 }
1234 );
1235
1236 $wrapper->contents_like(
1237 qr#
1238 ^Watch-expressions:\n
1239 \s*\(5\+6\)\n
1240 #msx,
1241 "L command is listing watch expressions",
1242 );
1243}
1244
1245{
1246 my $wrapper = DebugWrap->new(
1247 {
1248 cmds =>
1249 [
1250 'w (5+6)',
1251 'w (11*23)',
1252 'W (5+6)',
1253 'L',
1254 'q',
1255 ],
1256 prog => '../lib/perl5db/t/eval-line-bug',
1257 }
1258 );
1259
1260 $wrapper->contents_like(
1261 qr#
1262 ^Watch-expressions:\n
1263 \s*\(11\*23\)\n
1264 ^auto\(
1265 #msx,
1266 "L command is not listing deleted watch expressions",
1267 );
1268}
1269
1270# Test the L command.
1271{
1272 my $wrapper = DebugWrap->new(
1273 {
1274 cmds =>
1275 [
1276 'b 6',
1277 'a 13 print $i',
1278 'L',
1279 'q',
1280 ],
1281 prog => '../lib/perl5db/t/eval-line-bug',
1282 }
1283 );
1284
1285 $wrapper->contents_like(
1286 qr#
1287 ^\S*?eval-line-bug:\n
1288 \s*6:\s*my\ \$i\ =\ 5;\n
1289 \s*break\ if\ \(1\)\n
1290 \s*13:\s*\$i\ \+=\ \$q;\n
1291 \s*action:\s+print\ \$i\n
1292 #msx,
1293 "L command is listing actions and breakpoints",
1294 );
1295}
1296
1297{
1298 my $wrapper = DebugWrap->new(
1299 {
1300 cmds =>
1301 [
1302 'S',
1303 'q',
1304 ],
1305 prog => '../lib/perl5db/t/rt-104168',
1306 }
1307 );
1308
1309 $wrapper->contents_like(
1310 qr#
1311 ^main::bar\n
1312 main::baz\n
1313 main::foo\n
1314 #msx,
1315 "S command - 1",
1316 );
1317}
1318
1319{
1320 my $wrapper = DebugWrap->new(
1321 {
1322 cmds =>
1323 [
1324 'S ^main::ba',
1325 'q',
1326 ],
1327 prog => '../lib/perl5db/t/rt-104168',
1328 }
1329 );
1330
1331 $wrapper->contents_like(
1332 qr#
1333 ^main::bar\n
1334 main::baz\n
1335 auto\(
1336 #msx,
1337 "S command with regex",
1338 );
1339}
1340
1341{
1342 my $wrapper = DebugWrap->new(
1343 {
1344 cmds =>
1345 [
1346 'S !^main::ba',
1347 'q',
1348 ],
1349 prog => '../lib/perl5db/t/rt-104168',
1350 }
1351 );
1352
1353 $wrapper->contents_unlike(
1354 qr#
1355 ^main::ba
1356 #msx,
1357 "S command with negative regex",
1358 );
1359
1360 $wrapper->contents_like(
1361 qr#
1362 ^main::foo\n
1363 #msx,
1364 "S command with negative regex - what it still matches",
1365 );
1366}
1367
1368# Test the a command.
1369{
1370 my $wrapper = DebugWrap->new(
1371 {
1372 cmds =>
1373 [
1374 'a 13 print "\nVar<Q>=$q\n"',
1375 'c',
1376 'q',
1377 ],
1378 prog => '../lib/perl5db/t/eval-line-bug',
1379 }
1380 );
1381
1382 $wrapper->output_like(qr#
1383 \nVar<Q>=1\n
1384 \nVar<Q>=2\n
1385 \nVar<Q>=3\n
1386 #msx,
1387 "a command is working",
1388 );
1389}
1390
1391# Test the 'A' command
1392{
1393 my $wrapper = DebugWrap->new(
1394 {
1395 cmds =>
1396 [
1397 'a 13 print "\nVar<Q>=$q\n"',
1398 'A 13',
1399 'c',
1400 'q',
1401 ],
1402 prog => '../lib/perl5db/t/eval-line-bug',
1403 }
1404 );
1405
1406 $wrapper->output_like(
1407 qr#\A\z#msx, # The empty string.
1408 "A command (for removing actions) is working",
1409 );
1410}
1411
1412# Test the 'A *' command
1413{
1414 my $wrapper = DebugWrap->new(
1415 {
1416 cmds =>
1417 [
1418 'a 6 print "\nFail!\n"',
1419 'a 13 print "\nVar<Q>=$q\n"',
1420 'A *',
1421 'c',
1422 'q',
1423 ],
1424 prog => '../lib/perl5db/t/eval-line-bug',
1425 }
1426 );
1427
1428 $wrapper->output_like(
1429 qr#\A\z#msx, # The empty string.
1430 "'A *' command (for removing all actions) is working",
1431 );
1432}
1433
1434{
1435 my $wrapper = DebugWrap->new(
1436 {
1437 cmds =>
1438 [
1439 'n',
1440 'w $foo',
1441 'c',
1442 'print "\nIDX=<$idx>\n"',
1443 'q',
1444 ],
1445 prog => '../lib/perl5db/t/test-w-statement-1',
1446 }
1447 );
1448
1449
1450 $wrapper->contents_like(qr#
1451 \$foo\ changed:\n
1452 \s+old\ value:\s+'1'\n
1453 \s+new\ value:\s+'2'\n
1454 #msx,
1455 'w command - watchpoint changed',
1456 );
1457 $wrapper->output_like(qr#
1458 \nIDX=<20>\n
1459 #msx,
1460 "w command - correct output from IDX",
1461 );
1462}
1463
1464{
1465 my $wrapper = DebugWrap->new(
1466 {
1467 cmds =>
1468 [
1469 'n',
1470 'w $foo',
1471 'W $foo',
1472 'c',
1473 'print "\nIDX=<$idx>\n"',
1474 'q',
1475 ],
1476 prog => '../lib/perl5db/t/test-w-statement-1',
1477 }
1478 );
1479
1480 $wrapper->contents_unlike(qr#
1481 \$foo\ changed:
1482 #msx,
1483 'W command - watchpoint was deleted',
1484 );
1485
1486 $wrapper->output_like(qr#
1487 \nIDX=<>\n
1488 #msx,
1489 "W command - stopped at end.",
1490 );
1491}
1492
1493# Test the W * command.
1494{
1495 my $wrapper = DebugWrap->new(
1496 {
1497 cmds =>
1498 [
1499 'n',
1500 'w $foo',
1501 'w ($foo*$foo)',
1502 'W *',
1503 'c',
1504 'print "\nIDX=<$idx>\n"',
1505 'q',
1506 ],
1507 prog => '../lib/perl5db/t/test-w-statement-1',
1508 }
1509 );
1510
1511 $wrapper->contents_unlike(qr#
1512 \$foo\ changed:
1513 #msx,
1514 '"W *" command - watchpoint was deleted',
1515 );
1516
1517 $wrapper->output_like(qr#
1518 \nIDX=<>\n
1519 #msx,
1520 '"W *" command - stopped at end.',
1521 );
1522}
1523
1524# Test the 'o' command (without further arguments).
1525{
1526 my $wrapper = DebugWrap->new(
1527 {
1528 cmds =>
1529 [
1530 'o',
1531 'q',
1532 ],
1533 prog => '../lib/perl5db/t/test-w-statement-1',
1534 }
1535 );
1536
1537 $wrapper->contents_like(qr#
1538 ^\s*warnLevel\ =\ '1'\n
1539 #msx,
1540 q#"o" command (without arguments) displays warnLevel#,
1541 );
1542
1543 $wrapper->contents_like(qr#
1544 ^\s*signalLevel\ =\ '1'\n
1545 #msx,
1546 q#"o" command (without arguments) displays signalLevel#,
1547 );
1548
1549 $wrapper->contents_like(qr#
1550 ^\s*dieLevel\ =\ '1'\n
1551 #msx,
1552 q#"o" command (without arguments) displays dieLevel#,
1553 );
1554
1555 $wrapper->contents_like(qr#
1556 ^\s*hashDepth\ =\ 'N/A'\n
1557 #msx,
1558 q#"o" command (without arguments) displays hashDepth#,
1559 );
1560}
1561
1562# Test the 'o' query command.
1563{
1564 my $wrapper = DebugWrap->new(
1565 {
1566 cmds =>
1567 [
1568 'o hashDepth? signalLevel?',
1569 'q',
1570 ],
1571 prog => '../lib/perl5db/t/test-w-statement-1',
1572 }
1573 );
1574
1575 $wrapper->contents_unlike(qr#warnLevel#,
1576 q#"o" query command does not display warnLevel#,
1577 );
1578
1579 $wrapper->contents_like(qr#
1580 ^\s*signalLevel\ =\ '1'\n
1581 #msx,
1582 q#"o" query command displays signalLevel#,
1583 );
1584
1585 $wrapper->contents_unlike(qr#dieLevel#,
1586 q#"o" query command does not display dieLevel#,
1587 );
1588
1589 $wrapper->contents_like(qr#
1590 ^\s*hashDepth\ =\ 'N/A'\n
1591 #msx,
1592 q#"o" query command displays hashDepth#,
1593 );
1594}
1595
1596# Test the 'o' set command.
1597{
1598 my $wrapper = DebugWrap->new(
1599 {
1600 cmds =>
1601 [
1602 'o signalLevel=0',
1603 'o',
1604 'q',
1605 ],
1606 prog => '../lib/perl5db/t/test-w-statement-1',
1607 }
1608 );
1609
1610 $wrapper->contents_like(qr/
1611 ^\s*(signalLevel\ =\ '0'\n)
1612 .*?
1613 ^\s*\1
1614 /msx,
1615 q#o set command works#,
1616 );
1617
1618 $wrapper->contents_like(qr#
1619 ^\s*hashDepth\ =\ 'N/A'\n
1620 #msx,
1621 q#o set command - hashDepth#,
1622 );
1623}
1624
1625# Test the '<' and "< ?" commands.
1626{
1627 my $wrapper = DebugWrap->new(
1628 {
1629 cmds =>
1630 [
1631 q/< print "\nX=<$x>\n"/,
1632 q/b 7/,
1633 q/< ?/,
1634 'c',
1635 'q',
1636 ],
1637 prog => '../lib/perl5db/t/disable-breakpoints-1',
1638 }
1639 );
1640
1641 $wrapper->contents_like(qr/
1642 ^pre-perl\ commands:\n
1643 \s*<\ --\ print\ "\\nX=<\$x>\\n"\n
1644 /msx,
1645 q#Test < and < ? commands - contents.#,
1646 );
1647
1648 $wrapper->output_like(qr#
1649 ^X=<FirstVal>\n
1650 #msx,
1651 q#Test < and < ? commands - output.#,
1652 );
1653}
1654
1655# Test the '< *' command.
1656{
1657 my $wrapper = DebugWrap->new(
1658 {
1659 cmds =>
1660 [
1661 q/< print "\nX=<$x>\n"/,
1662 q/b 7/,
1663 q/< */,
1664 'c',
1665 'q',
1666 ],
1667 prog => '../lib/perl5db/t/disable-breakpoints-1',
1668 }
1669 );
1670
1671 $wrapper->output_unlike(qr/FirstVal/,
1672 q#Test the '< *' command.#,
1673 );
1674}
1675
1676# Test the '>' and "> ?" commands.
1677{
1678 my $wrapper = DebugWrap->new(
1679 {
1680 cmds =>
1681 [
1682 q/$::foo = 500;/,
1683 q/> print "\nFOO=<$::foo>\n"/,
1684 q/b 7/,
1685 q/> ?/,
1686 'c',
1687 'q',
1688 ],
1689 prog => '../lib/perl5db/t/disable-breakpoints-1',
1690 }
1691 );
1692
1693 $wrapper->contents_like(qr/
1694 ^post-perl\ commands:\n
1695 \s*>\ --\ print\ "\\nFOO=<\$::foo>\\n"\n
1696 /msx,
1697 q#Test > and > ? commands - contents.#,
1698 );
1699
1700 $wrapper->output_like(qr#
1701 ^FOO=<500>\n
1702 #msx,
1703 q#Test > and > ? commands - output.#,
1704 );
1705}
1706
1707# Test the '> *' command.
1708{
1709 my $wrapper = DebugWrap->new(
1710 {
1711 cmds =>
1712 [
1713 q/> print "\nFOO=<$::foo>\n"/,
1714 q/b 7/,
1715 q/> */,
1716 'c',
1717 'q',
1718 ],
1719 prog => '../lib/perl5db/t/disable-breakpoints-1',
1720 }
1721 );
1722
1723 $wrapper->output_unlike(qr/FOO=/,
1724 q#Test the '> *' command.#,
1725 );
1726}
1727
be1dfd82
SF
1728# Test the < and > commands together
1729{
1730 my $wrapper = DebugWrap->new(
1731 {
1732 cmds =>
1733 [
1734 q/$::lorem = 0;/,
1735 q/< $::lorem += 10;/,
1736 q/> print "\nLOREM=<$::lorem>\n"/,
1737 q/b 7/,
1738 q/b 5/,
1739 'c',
1740 'c',
1741 'q',
1742 ],
1743 prog => '../lib/perl5db/t/disable-breakpoints-1',
1744 }
1745 );
1746
1747 $wrapper->output_like(qr#
1748 ^LOREM=<10>\n
1749 #msx,
1750 q#Test < and > commands. #,
1751 );
1752}
1753
95418017
SF
1754# Test the { ? and { [command] commands.
1755{
1756 my $wrapper = DebugWrap->new(
1757 {
1758 cmds =>
1759 [
1e121f70
SF
1760 '{ ?',
1761 '{ l',
1762 '{ ?',
95418017
SF
1763 q/b 5/,
1764 q/c/,
1765 q/q/,
1766 ],
1767 prog => '../lib/perl5db/t/disable-breakpoints-1',
1768 }
1769 );
1770
1771 $wrapper->contents_like(qr#
1772 ^No\ pre-debugger\ actions\.\n
1773 .*?
1774 ^pre-debugger\ commands:\n
1775 \s+\{\ --\ l\n
1776 .*?
1777 ^5==>b\s+\$x\ =\ "FirstVal";\n
1778 6\s*\n
1779 7:\s+\$dummy\+\+;\n
1780 8\s*\n
1781 9:\s+\$x\ =\ "SecondVal";\n
1782
1783 #msx,
1784 'Test the pre-prompt debugger commands',
1785 );
1786}
1787
3743412c
SF
1788# Test the { * command.
1789{
1790 my $wrapper = DebugWrap->new(
1791 {
1792 cmds =>
1793 [
1794 '{ q',
1795 '{ *',
1796 q/b 5/,
1797 q/c/,
1798 q/print (("One" x 5), "\n");/,
1799 q/q/,
1800 ],
1801 prog => '../lib/perl5db/t/disable-breakpoints-1',
1802 }
1803 );
1804
1805 $wrapper->contents_like(qr#
1806 ^All\ \{\ actions\ cleared\.\n
1807 #msx,
1808 'Test the { * command',
1809 );
1810
1811 $wrapper->output_like(qr/OneOneOneOneOne/,
1812 '{ * test - output is OK.',
1813 );
1814}
1815
1896f514
SF
1816# Test the ! command.
1817{
1818 my $wrapper = DebugWrap->new(
1819 {
1820 cmds =>
1821 [
1822 'l 3-5',
1823 '!',
1824 'q',
1825 ],
1826 prog => '../lib/perl5db/t/disable-breakpoints-1',
1827 }
1828 );
1829
1830 $wrapper->contents_like(qr#
1831 (^3:\s+my\ \$dummy\ =\ 0;\n
1832 4\s*\n
1833 5:\s+\$x\ =\ "FirstVal";)\n
1834 .*?
1835 ^l\ 3-5\n
1836 \1
1837 #msx,
1838 'Test the ! command (along with l 3-5)',
1839 );
1840}
1841
ada05bfe
SF
1842# Test the ! -number command.
1843{
1844 my $wrapper = DebugWrap->new(
1845 {
1846 cmds =>
1847 [
1848 'l 3-5',
1849 'l 2',
1850 '! -1',
1851 'q',
1852 ],
1853 prog => '../lib/perl5db/t/disable-breakpoints-1',
1854 }
1855 );
1856
1857 $wrapper->contents_like(qr#
1858 (^3:\s+my\ \$dummy\ =\ 0;\n
1859 4\s*\n
1860 5:\s+\$x\ =\ "FirstVal";)\n
1861 .*?
1862 ^2==\>\s+my\ \$x\ =\ "One";\n
1863 .*?
1864 ^l\ 3-5\n
1865 \1
1866 #msx,
1867 'Test the ! -n command (along with l)',
1868 );
1869}
1870
635f2c9e 1871END {
4cfe45a1 1872 1 while unlink ($rc_filename, $out_fn);
635f2c9e 1873}