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