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