This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove some set but unused variables
[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
2c247e84 31plan(40);
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
391sub contents_like {
392 my ($self, $re, $msg) = @_;
393
394 local $::Level = $::Level + 1;
395 ::like($self->_contents(), $re, $msg);
396}
397
398package main;
399
400# Testing that we can set a line in the middle of the file.
401{
402 my $wrapper = DebugWrap->new(
403 {
404 cmds =>
405 [
406 'b ../lib/perl5db/t/MyModule.pm:12',
407 'c',
408 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
409 'c',
410 'q',
411 ],
412 include_t => 1,
413 prog => '../lib/perl5db/t/filename-line-breakpoint'
414 }
415 );
416
417 $wrapper->output_like(qr/
418 ^Var=Bar$
419 .*
420 ^In\ MyModule\.$
421 .*
422 ^In\ Main\ File\.$
423 .*
e09195af 424 /msx,
5e2fff4a 425 "Can set breakpoint in a line in the middle of the file.");
e09195af
SF
426}
427
5e2fff4a 428# Testing that we can set a breakpoint
e09195af 429{
5e2fff4a
SF
430 my $wrapper = DebugWrap->new(
431 {
432 prog => '../lib/perl5db/t/breakpoint-bug',
433 cmds =>
434 [
435 'b 6',
436 'c',
437 q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/,
438 'c',
439 'q',
440 ],
441 },
442 );
e09195af 443
5e2fff4a
SF
444 $wrapper->output_like(
445 qr/X=\{Two\}/msx,
446 "Can set breakpoint in a line."
447 );
448}
449
450# Testing that we can disable a breakpoint at a numeric line.
451{
452 my $wrapper = DebugWrap->new(
453 {
454 prog => '../lib/perl5db/t/disable-breakpoints-1',
455 cmds =>
456 [
457 'b 7',
458 'b 11',
459 'disable 7',
460 'c',
461 q/print "X={$x}\n";/,
462 'c',
463 'q',
464 ],
465 }
e09195af 466 );
b7bfa855 467
5e2fff4a
SF
468 $wrapper->output_like(qr/X=\{SecondVal\}/ms,
469 "Can set breakpoint in a line.");
e09195af 470}
e09195af 471
5e2fff4a
SF
472# Testing that we can re-enable a breakpoint at a numeric line.
473{
474 my $wrapper = DebugWrap->new(
475 {
476 prog => '../lib/perl5db/t/disable-breakpoints-2',
477 cmds =>
478 [
479 'b 8',
480 'b 24',
481 'disable 24',
482 'c',
483 'enable 24',
484 'c',
485 q/print "X={$x}\n";/,
486 'c',
487 'q',
488 ],
489 },
490 );
491
492 $wrapper->output_like(
493 qr/
e09195af
SF
494 X=\{SecondValOneHundred\}
495 /msx,
5e2fff4a
SF
496 "Can set breakpoint in a line."
497 );
e09195af 498}
635f2c9e
RGS
499# clean up.
500
e09195af
SF
501# Disable and enable for breakpoints on outer files.
502{
5e2fff4a
SF
503 my $wrapper = DebugWrap->new(
504 {
505 cmds =>
506 [
507 'b 10',
508 'b ../lib/perl5db/t/EnableModule.pm:14',
509 'disable ../lib/perl5db/t/EnableModule.pm:14',
510 'c',
511 'enable ../lib/perl5db/t/EnableModule.pm:14',
512 'c',
513 q/print "X={$x}\n";/,
514 'c',
515 'q',
516 ],
517 prog => '../lib/perl5db/t/disable-breakpoints-3',
518 include_t => 1,
519 }
e09195af
SF
520 );
521
5e2fff4a 522 $wrapper->output_like(qr/
e09195af
SF
523 X=\{SecondValTwoHundred\}
524 /msx,
525 "Can set breakpoint in a line.");
526}
bdba49ad
SF
527
528# Testing that the prompt with the information appears.
529{
5e2fff4a
SF
530 my $wrapper = DebugWrap->new(
531 {
532 cmds => ['q'],
533 prog => '../lib/perl5db/t/disable-breakpoints-1',
534 }
bdba49ad
SF
535 );
536
5e2fff4a 537 $wrapper->contents_like(qr/
bdba49ad
SF
538 ^main::\([^\)]*\bdisable-breakpoints-1:2\):\n
539 2:\s+my\ \$x\ =\ "One";\n
540 /msx,
541 "Prompt should display the first line of code.");
542}
543
544# Testing that R (restart) and "B *" work.
545{
5e2fff4a
SF
546 my $wrapper = DebugWrap->new(
547 {
548 cmds =>
549 [
550 'b 13',
551 'c',
552 'B *',
553 'b 9',
554 'R',
555 'c',
556 q/print "X={$x};dummy={$dummy}\n";/,
557 'q',
558 ],
559 prog => '../lib/perl5db/t/disable-breakpoints-1',
560 }
bdba49ad
SF
561 );
562
5e2fff4a 563 $wrapper->output_like(qr/
bdba49ad
SF
564 X=\{FirstVal\};dummy=\{1\}
565 /msx,
566 "Restart and delete all breakpoints work properly.");
567}
568
5d5d9ea3 569{
5e2fff4a
SF
570 my $wrapper = DebugWrap->new(
571 {
572 cmds =>
573 [
574 'c 15',
575 q/print "X={$x}\n";/,
576 'c',
577 'q',
578 ],
579 prog => '../lib/perl5db/t/disable-breakpoints-1',
580 }
5d5d9ea3
SF
581 );
582
5e2fff4a 583 $wrapper->output_like(qr/
5d5d9ea3
SF
584 X=\{ThirdVal\}
585 /msx,
586 "'c line_num' is working properly.");
587}
588
5343a617 589{
5e2fff4a
SF
590 my $wrapper = DebugWrap->new(
591 {
592 cmds =>
593 [
594 'n',
595 'n',
596 'b . $exp > 200',
597 'c',
598 q/print "Exp={$exp}\n";/,
599 'q',
600 ],
601 prog => '../lib/perl5db/t/break-on-dot',
602 }
5343a617 603 );
5343a617 604
5e2fff4a 605 $wrapper->output_like(qr/
5343a617
SF
606 Exp=\{256\}
607 /msx,
608 "'b .' is working correctly.");
609}
610
8dc67a69
SF
611# Testing that the prompt with the information appears inside a subroutine call.
612# See https://rt.perl.org/rt3/Ticket/Display.html?id=104820
613{
5e2fff4a
SF
614 my $wrapper = DebugWrap->new(
615 {
616 cmds =>
617 [
618 'c back',
619 'q',
620 ],
621 prog => '../lib/perl5db/t/with-subroutine',
622 }
8dc67a69 623 );
8dc67a69 624
5e2fff4a 625 $wrapper->contents_like(
8dc67a69
SF
626 qr/
627 ^main::back\([^\)\n]*\bwith-subroutine:15\):[\ \t]*\n
628 ^15:\s*print\ "hello\ back\\n";
629 /msx,
630 "Prompt should display the line of code inside a subroutine.");
631}
632
984e0ec4
SF
633# Checking that the p command works.
634{
5e2fff4a
SF
635 my $wrapper = DebugWrap->new(
636 {
637 cmds =>
638 [
639 'p "<<<" . (4*6) . ">>>"',
640 'q',
641 ],
642 prog => '../lib/perl5db/t/with-subroutine',
643 }
984e0ec4
SF
644 );
645
5e2fff4a 646 $wrapper->contents_like(
984e0ec4
SF
647 qr/<<<24>>>/,
648 "p command works.");
649}
650
9f810cd7
SF
651# Tests for x.
652{
5e2fff4a
SF
653 my $wrapper = DebugWrap->new(
654 {
655 cmds =>
656 [
657 q/x {500 => 600}/,
658 'q',
659 ],
660 prog => '../lib/perl5db/t/with-subroutine',
661 }
9f810cd7
SF
662 );
663
5e2fff4a 664 $wrapper->contents_like(
9f810cd7
SF
665 # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
666 qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/ms,
667 "x command test."
668 );
669}
670
5bc17875
SF
671# Tests for "T" (stack trace).
672{
5bc17875 673 my $prog_fn = '../lib/perl5db/t/rt-104168';
5e2fff4a
SF
674 my $wrapper = DebugWrap->new(
675 {
676 prog => $prog_fn,
677 cmds =>
678 [
679 'c baz',
680 'T',
681 'q',
682 ],
683 }
684 );
5bc17875
SF
685 my $re_text = join('',
686 map {
687 sprintf(
688 "%s = %s\\(\\) called from file " .
689 "'" . quotemeta($prog_fn) . "' line %s\\n",
690 (map { quotemeta($_) } @$_)
691 )
2c247e84 692 }
5bc17875
SF
693 (
694 ['.', 'main::baz', 14,],
695 ['.', 'main::bar', 9,],
2c247e84 696 ['.', 'main::foo', 6],
5bc17875
SF
697 )
698 );
5e2fff4a 699 $wrapper->contents_like(
5bc17875
SF
700 # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
701 qr/^$re_text/ms,
702 "T command test."
703 );
704}
8fe891f1
SF
705
706# Test for s.
707{
5e2fff4a
SF
708 my $wrapper = DebugWrap->new(
709 {
710 cmds =>
711 [
712 'b 9',
713 'c',
714 's',
715 q/print "X={$x};dummy={$dummy}\n";/,
716 'q',
717 ],
718 prog => '../lib/perl5db/t/disable-breakpoints-1'
719 }
8fe891f1
SF
720 );
721
5e2fff4a 722 $wrapper->output_like(qr/
8fe891f1
SF
723 X=\{SecondVal\};dummy=\{1\}
724 /msx,
725 'test for s - single step',
726 );
727}
728
65ab0314 729{
5e2fff4a
SF
730 my $wrapper = DebugWrap->new(
731 {
732 cmds =>
733 [
734 'n',
735 'n',
736 'b . $exp > 200',
737 'c',
738 q/print "Exp={$exp}\n";/,
739 'q',
740 ],
741 prog => '../lib/perl5db/t/break-on-dot'
742 }
65ab0314
SF
743 );
744
5e2fff4a 745 $wrapper->output_like(qr/
65ab0314
SF
746 Exp=\{256\}
747 /msx,
748 "'b .' is working correctly.");
749}
750
751{
65ab0314 752 my $prog_fn = '../lib/perl5db/t/rt-104168';
5e2fff4a
SF
753 my $wrapper = DebugWrap->new(
754 {
755 cmds =>
756 [
757 's',
758 'q',
759 ],
760 prog => $prog_fn,
761 }
762 );
65ab0314 763
5e2fff4a 764 $wrapper->contents_like(
65ab0314
SF
765 qr/
766 ^main::foo\([^\)\n]*\brt-104168:9\):[\ \t]*\n
767 ^9:\s*bar\(\);
768 /msx,
769 'Test for the s command.',
770 );
771}
772
5d83cde2 773{
5e2fff4a
SF
774 my $wrapper = DebugWrap->new(
775 {
776 cmds =>
777 [
778 's uncalled_subroutine()',
779 'c',
780 'q',
781 ],
5d83cde2 782
5e2fff4a 783 prog => '../lib/perl5db/t/uncalled-subroutine'}
5d83cde2
SF
784 );
785
5e2fff4a 786 $wrapper->output_like(
5d83cde2
SF
787 qr/<1,2,3,4,5>\n/,
788 'uncalled_subroutine was called after s EXPR()',
789 );
5d83cde2
SF
790}
791
d7b8b95b 792{
5e2fff4a
SF
793 my $wrapper = DebugWrap->new(
794 {
795 cmds =>
796 [
797 'n uncalled_subroutine()',
798 'c',
799 'q',
800 ],
801 prog => '../lib/perl5db/t/uncalled-subroutine',
802 }
d7b8b95b
SF
803 );
804
5e2fff4a 805 $wrapper->output_like(
d7b8b95b
SF
806 qr/<1,2,3,4,5>\n/,
807 'uncalled_subroutine was called after n EXPR()',
808 );
d7b8b95b
SF
809}
810
ea7bdd87
VP
811{
812 my $wrapper = DebugWrap->new(
813 {
814 cmds =>
815 [
816 'b fact',
817 'c',
818 'c',
819 'c',
820 'n',
821 'print "<$n>"',
822 'q',
823 ],
824 prog => '../lib/perl5db/t/fact',
825 }
826 );
827
828 $wrapper->output_like(
829 qr/<3>/,
830 'b subroutine works fine',
831 );
832}
833
f311474d
VP
834# Test for 'M' (module list).
835{
836 my $wrapper = DebugWrap->new(
837 {
838 cmds =>
839 [
840 'M',
841 'q',
842 ],
843 prog => '../lib/perl5db/t/load-modules'
844 }
845 );
846
847 $wrapper->contents_like(
848 qr[Scalar/Util\.pm],
849 'M (module list) works fine',
850 );
851}
852
55783941
SF
853{
854 my $wrapper = DebugWrap->new(
855 {
856 cmds =>
857 [
858 'b 14',
859 'c',
860 '$flag = 1;',
861 'r',
862 'print "Var=$var\n";',
863 'q',
864 ],
865 prog => '../lib/perl5db/t/test-r-statement',
866 }
867 );
868
869 $wrapper->output_like(
870 qr/
871 ^Foo$
872 .*?
873 ^Bar$
874 .*?
875 ^Var=Test$
876 /msx,
877 'r statement is working properly.',
878 );
879}
880
881{
882 my $wrapper = DebugWrap->new(
883 {
884 cmds =>
885 [
886 'l',
887 'q',
888 ],
889 prog => '../lib/perl5db/t/test-l-statement-1',
890 }
891 );
892
893 $wrapper->contents_like(
894 qr/
895 ^1==>\s+\$x\ =\ 1;\n
896 2:\s+print\ "1\\n";\n
897 3\s*\n
898 4:\s+\$x\ =\ 2;\n
899 5:\s+print\ "2\\n";\n
900 /msx,
901 'l statement is working properly (test No. 1).',
902 );
903}
904
2c247e84
SF
905{
906 my $wrapper = DebugWrap->new(
907 {
908 cmds =>
909 [
910 'l',
911 q/# After l 1/,
912 'l',
913 q/# After l 2/,
914 '-',
915 q/# After -/,
916 'q',
917 ],
918 prog => '../lib/perl5db/t/test-l-statement-1',
919 }
920 );
921
922 my $first_l_out = qr/
923 1==>\s+\$x\ =\ 1;\n
924 2:\s+print\ "1\\n";\n
925 3\s*\n
926 4:\s+\$x\ =\ 2;\n
927 5:\s+print\ "2\\n";\n
928 6\s*\n
929 7:\s+\$x\ =\ 3;\n
930 8:\s+print\ "3\\n";\n
931 9\s*\n
932 10:\s+\$x\ =\ 4;\n
933 /msx;
934
935 my $second_l_out = qr/
936 11:\s+print\ "4\\n";\n
937 12\s*\n
938 13:\s+\$x\ =\ 5;\n
939 14:\s+print\ "5\\n";\n
940 15\s*\n
941 16:\s+\$x\ =\ 6;\n
942 17:\s+print\ "6\\n";\n
943 18\s*\n
944 19:\s+\$x\ =\ 7;\n
945 20:\s+print\ "7\\n";\n
946 /msx;
947 $wrapper->contents_like(
948 qr/
949 ^$first_l_out
950 [^\n]*?DB<\d+>\ \#\ After\ l\ 1\n
951 [\ \t]*\n
952 [^\n]*?DB<\d+>\ l\s*\n
953 $second_l_out
954 [^\n]*?DB<\d+>\ \#\ After\ l\ 2\n
955 [\ \t]*\n
956 [^\n]*?DB<\d+>\ -\s*\n
957 $first_l_out
958 [^\n]*?DB<\d+>\ \#\ After\ -\n
959 /msx,
960 'l followed by l and then followed by -',
961 );
962}
963
964{
965 my $wrapper = DebugWrap->new(
966 {
967 cmds =>
968 [
969 'l fact',
970 'q',
971 ],
972 prog => '../lib/perl5db/t/test-l-statement-2',
973 }
974 );
975
976 my $first_l_out = qr/
977 6\s+sub\ fact\ \{\n
978 7:\s+my\ \$n\ =\ shift;\n
979 8:\s+if\ \(\$n\ >\ 1\)\ \{\n
980 9:\s+return\ \$n\ \*\ fact\(\$n\ -\ 1\);
981 /msx;
982
983 $wrapper->contents_like(
984 qr/
985 DB<1>\s+l\ fact\n
986 $first_l_out
987 /msx,
988 'l subroutine_name',
989 );
990}
991
992{
993 my $wrapper = DebugWrap->new(
994 {
995 cmds =>
996 [
997 'b fact',
998 'c',
999 # Repeat several times to avoid @typeahead problems.
1000 '.',
1001 '.',
1002 '.',
1003 '.',
1004 'q',
1005 ],
1006 prog => '../lib/perl5db/t/test-l-statement-2',
1007 }
1008 );
1009
1010 my $line_out = qr /
1011 ^main::fact\([^\n]*?:7\):\n
1012 ^7:\s+my\ \$n\ =\ shift;\n
1013 /msx;
1014
1015 $wrapper->contents_like(
1016 qr/
1017 $line_out
1018 $line_out
1019 /msx,
1020 'Test the "." command',
1021 );
1022}
1023
1024# Testing that the f command works.
1025{
1026 my $wrapper = DebugWrap->new(
1027 {
1028 cmds =>
1029 [
1030 'f ../lib/perl5db/t/MyModule.pm',
1031 'b 12',
1032 'c',
1033 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
1034 'c',
1035 'q',
1036 ],
1037 include_t => 1,
1038 prog => '../lib/perl5db/t/filename-line-breakpoint'
1039 }
1040 );
1041
1042 $wrapper->output_like(qr/
1043 ^Var=Bar$
1044 .*
1045 ^In\ MyModule\.$
1046 .*
1047 ^In\ Main\ File\.$
1048 .*
1049 /msx,
1050 "f command is working.",
1051 );
1052}
1053
1054# We broke the /pattern/ command because apparently the CORE::eval-s inside
1055# lib/perl5db.pl cannot handle lexical variable properly. So we now fix this
1056# bug.
1057#
1058# TODO :
1059#
1060# 1. Go over the rest of the "eval"s in lib/perl5db.t and see if they cause
1061# problems.
1062{
1063 my $wrapper = DebugWrap->new(
1064 {
1065 cmds =>
1066 [
1067 '/for/',
1068 'q',
1069 ],
1070 prog => '../lib/perl5db/t/eval-line-bug',
1071 }
1072 );
1073
1074 $wrapper->contents_like(
1075 qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1076 "/pat/ command is working and found a match.",
1077 );
1078}
1079
1080{
1081 my $wrapper = DebugWrap->new(
1082 {
1083 cmds =>
1084 [
1085 'b 22',
1086 'c',
1087 '?for?',
1088 'q',
1089 ],
1090 prog => '../lib/perl5db/t/eval-line-bug',
1091 }
1092 );
1093
1094 $wrapper->contents_like(
1095 qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1096 "?pat? command is working and found a match.",
1097 );
1098}
1099
635f2c9e 1100END {
4cfe45a1 1101 1 while unlink ($rc_filename, $out_fn);
635f2c9e 1102}