Mention sv_gets as the Perl-ish fgets-ish API.
[perl.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     $ENV{PERL_RL} = 'Perl'; # Suppress system Term::ReadLine::Gnu
30 }
31
32 plan(120);
33
34 my $rc_filename = '.perldb';
35
36 sub rc {
37     open my $rc_fh, '>', $rc_filename
38         or die $!;
39     print {$rc_fh} @_;
40     close ($rc_fh);
41
42     # overly permissive perms gives "Must not source insecure rcfile"
43     # and hangs at the DB(1> prompt
44     chmod 0644, $rc_filename;
45 }
46
47 sub _slurp
48 {
49     my $filename = shift;
50
51     open my $in, '<', $filename
52         or die "Cannot open '$filename' for slurping - $!";
53
54     local $/;
55     my $contents = <$in>;
56
57     close($in);
58
59     return $contents;
60 }
61
62 my $out_fn = 'db.out';
63
64 sub _out_contents
65 {
66     return _slurp($out_fn);
67 }
68
69
70 # Test for Proxy constants
71 {
72     rc(
73         <<'EOF',
74
75 &parse_options("NonStop=0 ReadLine=0 TTY=db.out");
76
77 sub afterinit {
78     push(@DB::typeahead,
79         'm main->s1',
80         'q',
81     );
82 }
83
84 EOF
85     );
86
87     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
88     is($output, "", "proxy constant subroutines");
89 }
90
91 # [perl #66110] Call a subroutine inside a regex
92 {
93     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
94     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
95     like($output, qr/\bAll tests successful\.$/, "[perl #66110]");
96 }
97 # [ perl #116769] Frame=2
98 {
99     local $ENV{PERLDB_OPTS} = "frame=2 nonstop";
100     my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' );
101     is( $?, 0, '[perl #116769] frame=2 does not crash debugger, exit == 0' );
102     is( $output, "success\n" , '[perl #116769] code is run' );
103 }
104 # [ perl #116771] autotrace
105 {
106     local $ENV{PERLDB_OPTS} = "autotrace nonstop";
107     my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' );
108     is( $?, 0, '[perl #116771] autotrace does not crash debugger, exit == 0' );
109     is( $output, "success\n" , '[perl #116771] code is run' );
110 }
111 # [ perl #41461] Frame=2 noTTY
112 {
113     local $ENV{PERLDB_OPTS} = "frame=2 noTTY nonstop";
114     rc('');
115     my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' );
116     is( $?, 0, '[perl #41461] frame=2 noTTY does not crash debugger, exit == 0' );
117     is( $output, "success\n" , '[perl #41461] code is run' );
118 }
119
120 package DebugWrap;
121
122 sub new {
123     my $class = shift;
124
125     my $self = bless {}, $class;
126
127     $self->_init(@_);
128
129     return $self;
130 }
131
132 sub _cmds {
133     my $self = shift;
134
135     if (@_) {
136         $self->{_cmds} = shift;
137     }
138
139     return $self->{_cmds};
140 }
141
142 sub _prog {
143     my $self = shift;
144
145     if (@_) {
146         $self->{_prog} = shift;
147     }
148
149     return $self->{_prog};
150 }
151
152 sub _output {
153     my $self = shift;
154
155     if (@_) {
156         $self->{_output} = shift;
157     }
158
159     return $self->{_output};
160 }
161
162 sub _include_t
163 {
164     my $self = shift;
165
166     if (@_)
167     {
168         $self->{_include_t} = shift;
169     }
170
171     return $self->{_include_t};
172 }
173
174 sub _stderr_val
175 {
176     my $self = shift;
177
178     if (@_)
179     {
180         $self->{_stderr_val} = shift;
181     }
182
183     return $self->{_stderr_val};
184 }
185
186 sub field
187 {
188     my $self = shift;
189
190     if (@_)
191     {
192         $self->{field} = shift;
193     }
194
195     return $self->{field};
196 }
197
198 sub _switches
199 {
200     my $self = shift;
201
202     if (@_)
203     {
204         $self->{_switches} = shift;
205     }
206
207     return $self->{_switches};
208 }
209
210 sub _contents
211 {
212     my $self = shift;
213
214     if (@_)
215     {
216         $self->{_contents} = shift;
217     }
218
219     return $self->{_contents};
220 }
221
222 sub _init
223 {
224     my ($self, $args) = @_;
225
226     my $cmds = $args->{cmds};
227
228     if (ref($cmds) ne 'ARRAY') {
229         die "cmds must be an array of commands.";
230     }
231
232     $self->_cmds($cmds);
233
234     my $prog = $args->{prog};
235
236     if (ref($prog) ne '' or !defined($prog)) {
237         die "prog should be a path to a program file.";
238     }
239
240     $self->_prog($prog);
241
242     $self->_include_t($args->{include_t} ? 1 : 0);
243
244     $self->_stderr_val(exists($args->{stderr}) ? $args->{stderr} : 1);
245
246     if (exists($args->{switches}))
247     {
248         $self->_switches($args->{switches});
249     }
250
251     $self->_run();
252
253     return;
254 }
255
256 sub _quote
257 {
258     my ($self, $str) = @_;
259
260     $str =~ s/(["\@\$\\])/\\$1/g;
261     $str =~ s/\n/\\n/g;
262     $str =~ s/\r/\\r/g;
263
264     return qq{"$str"};
265 }
266
267 sub _run {
268     my $self = shift;
269
270     my $rc = qq{&parse_options("NonStop=0 TTY=db.out");\n};
271
272     $rc .= join('',
273         map { "$_\n"}
274         (q#sub afterinit {#,
275          q#push (@DB::typeahead,#,
276          (map { $self->_quote($_) . "," } @{$self->_cmds()}),
277          q#);#,
278          q#}#,
279         )
280     );
281
282     # I guess two objects like that cannot be used at the same time.
283     # Oh well.
284     ::rc($rc);
285
286     my $output =
287         ::runperl(
288             switches =>
289             [
290                 ($self->_switches ? (@{$self->_switches()}) : ('-d')),
291                 ($self->_include_t ? ('-I', '../lib/perl5db/t') : ())
292             ],
293             (defined($self->_stderr_val())
294                 ? (stderr => $self->_stderr_val())
295                 : ()
296             ),
297             progfile => $self->_prog()
298         );
299
300     $self->_output($output);
301
302     $self->_contents(::_out_contents());
303
304     return;
305 }
306
307 sub get_output
308 {
309     return shift->_output();
310 }
311
312 sub output_like {
313     my ($self, $re, $msg) = @_;
314
315     local $::Level = $::Level + 1;
316     ::like($self->_output(), $re, $msg);
317 }
318
319 sub output_unlike {
320     my ($self, $re, $msg) = @_;
321
322     local $::Level = $::Level + 1;
323     ::unlike($self->_output(), $re, $msg);
324 }
325
326 sub contents_like {
327     my ($self, $re, $msg) = @_;
328
329     local $::Level = $::Level + 1;
330     ::like($self->_contents(), $re, $msg);
331 }
332
333 sub contents_unlike {
334     my ($self, $re, $msg) = @_;
335
336     local $::Level = $::Level + 1;
337     ::unlike($self->_contents(), $re, $msg);
338 }
339
340 package main;
341
342 {
343     local $ENV{PERLDB_OPTS} = "ReadLine=0";
344     my $target = '../lib/perl5db/t/eval-line-bug';
345     my $wrapper = DebugWrap->new(
346         {
347             cmds =>
348             [
349                 'b 23',
350                 'n',
351                 'n',
352                 'n',
353                 'c', # line 23
354                 'n',
355                 "p \@{'main::_<$target'}",
356                 'q',
357             ],
358             prog => $target,
359         }
360     );
361     $wrapper->contents_like(
362         qr/sub factorial/,
363         'The ${main::_<filename} variable in the debugger was not destroyed',
364     );
365 }
366
367 sub _calc_generic_wrapper
368 {
369     my $args = shift;
370
371     my $extra_opts = delete($args->{extra_opts});
372     $extra_opts ||= '';
373     local $ENV{PERLDB_OPTS} = "ReadLine=0" . $extra_opts;
374     return DebugWrap->new(
375         {
376             cmds => delete($args->{cmds}),
377             prog => delete($args->{prog}),
378             %$args,
379         }
380     );
381 }
382
383 sub _calc_new_var_wrapper
384 {
385     my ($args) = @_;
386     return _calc_generic_wrapper(
387         {
388             cmds =>
389             [
390                 'b 23',
391                 'c',
392                 '$new_var = "Foo"',
393                 'x "new_var = <$new_var>\\n"',
394                 'q',
395             ],
396             %$args,
397         }
398     );
399 }
400
401 sub _calc_threads_wrapper
402 {
403     my $args = shift;
404
405     return _calc_new_var_wrapper(
406         {
407             switches => [ '-dt', ],
408             stderr => 1,
409             %$args
410         }
411     );
412 }
413
414 {
415     _calc_new_var_wrapper({ prog => '../lib/perl5db/t/eval-line-bug'})
416         ->contents_like(
417             qr/new_var = <Foo>/,
418             "no strict 'vars' in evaluated lines.",
419         );
420 }
421
422 {
423     _calc_new_var_wrapper(
424         {
425             prog => '../lib/perl5db/t/lvalue-bug',
426             stderr => undef(),
427         },
428     )->output_like(
429             qr/foo is defined/,
430              'lvalue subs work in the debugger',
431          );
432 }
433
434 {
435     _calc_new_var_wrapper(
436         {
437             prog =>  '../lib/perl5db/t/symbol-table-bug',
438             extra_opts => "NonStop=1",
439             stderr => undef(),
440         }
441     )->output_like(
442         qr/Undefined symbols 0/,
443         'there are no undefined values in the symbol table',
444     );
445 }
446
447 SKIP:
448 {
449     if ( $Config{usethreads} ) {
450         skip('This perl has threads, skipping non-threaded debugger tests');
451     }
452     else {
453         my $error = 'This Perl not built to support threads';
454         _calc_threads_wrapper(
455             {
456                 prog => '../lib/perl5db/t/eval-line-bug',
457             }
458         )->output_like(
459             qr/\Q$error\E/,
460             'Perl debugger correctly complains that it was not built with threads',
461         );
462     }
463 }
464
465 SKIP:
466 {
467     if ( $Config{usethreads} ) {
468         _calc_threads_wrapper(
469             {
470                 prog =>  '../lib/perl5db/t/symbol-table-bug',
471             }
472         )->output_like(
473             qr/Undefined symbols 0/,
474             'there are no undefined values in the symbol table when running with thread support',
475         );
476     }
477     else {
478         skip("This perl is not threaded, skipping threaded debugger tests");
479     }
480 }
481
482 # Test [perl #61222]
483 {
484     local $ENV{PERLDB_OPTS};
485     my $wrapper = DebugWrap->new(
486         {
487             cmds =>
488             [
489                 'm Pie',
490                 'q',
491             ],
492             prog => '../lib/perl5db/t/rt-61222',
493         }
494     );
495
496     $wrapper->contents_unlike(qr/INCORRECT/, "[perl #61222]");
497 }
498
499 sub _calc_trace_wrapper
500 {
501     my ($args) = @_;
502
503     return _calc_generic_wrapper(
504         {
505             cmds =>
506             [
507                 't 2',
508                 'c',
509                 'q',
510             ],
511             %$args,
512         }
513     );
514 }
515
516 # [perl 104168] level option for tracing
517 {
518     my $wrapper = _calc_trace_wrapper({ prog =>  '../lib/perl5db/t/rt-104168' });
519     $wrapper->contents_like(qr/level 2/, "[perl #104168] - level 2 appears");
520     $wrapper->contents_unlike(qr/baz/, "[perl #104168] - no 'baz'");
521 }
522
523 # taint tests
524 {
525     my $wrapper = _calc_trace_wrapper(
526         {
527             prog => '../lib/perl5db/t/taint',
528             extra_opts => ' NonStop=1',
529             switches => [ '-d', '-T', ],
530         }
531     );
532
533     my $output = $wrapper->get_output();
534     chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
535     is($output, '[$^X][done]', "taint");
536 }
537
538 # Testing that we can set a line in the middle of the file.
539 {
540     my $wrapper = DebugWrap->new(
541         {
542             cmds =>
543             [
544                 'b ../lib/perl5db/t/MyModule.pm:12',
545                 'c',
546                 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
547                 'c',
548                 'q',
549             ],
550             include_t => 1,
551             prog => '../lib/perl5db/t/filename-line-breakpoint'
552         }
553     );
554
555     $wrapper->output_like(qr/
556         ^Var=Bar$
557             .*
558         ^In\ MyModule\.$
559             .*
560         ^In\ Main\ File\.$
561             .*
562         /msx,
563         "Can set breakpoint in a line in the middle of the file.");
564 }
565
566 # Testing that we can set a breakpoint
567 {
568     my $wrapper = DebugWrap->new(
569         {
570             prog => '../lib/perl5db/t/breakpoint-bug',
571             cmds =>
572             [
573                 'b 6',
574                 'c',
575                 q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/,
576                 'c',
577                 'q',
578             ],
579         },
580     );
581
582     $wrapper->output_like(
583         qr/X=\{Two\}/msx,
584         "Can set breakpoint in a line."
585     );
586 }
587
588 # Testing that we can disable a breakpoint at a numeric line.
589 {
590     my $wrapper = DebugWrap->new(
591         {
592             prog =>  '../lib/perl5db/t/disable-breakpoints-1',
593             cmds =>
594             [
595                 'b 7',
596                 'b 11',
597                 'disable 7',
598                 'c',
599                 q/print "X={$x}\n";/,
600                 'c',
601                 'q',
602             ],
603         }
604     );
605
606     $wrapper->output_like(qr/X=\{SecondVal\}/ms,
607         "Can set breakpoint in a line.");
608 }
609
610 # Testing that we can re-enable a breakpoint at a numeric line.
611 {
612     my $wrapper = DebugWrap->new(
613         {
614             prog =>  '../lib/perl5db/t/disable-breakpoints-2',
615             cmds =>
616             [
617                 'b 8',
618                 'b 24',
619                 'disable 24',
620                 'c',
621                 'enable 24',
622                 'c',
623                 q/print "X={$x}\n";/,
624                 'c',
625                 'q',
626             ],
627         },
628     );
629
630     $wrapper->output_like(
631         qr/
632         X=\{SecondValOneHundred\}
633         /msx,
634         "Can set breakpoint in a line."
635     );
636 }
637 # clean up.
638
639 # Disable and enable for breakpoints on outer files.
640 {
641     my $wrapper = DebugWrap->new(
642         {
643             cmds =>
644             [
645                 'b 10',
646                 'b ../lib/perl5db/t/EnableModule.pm:14',
647                 'disable ../lib/perl5db/t/EnableModule.pm:14',
648                 'c',
649                 'enable ../lib/perl5db/t/EnableModule.pm:14',
650                 'c',
651                 q/print "X={$x}\n";/,
652                 'c',
653                 'q',
654             ],
655             prog =>  '../lib/perl5db/t/disable-breakpoints-3',
656             include_t => 1,
657         }
658     );
659
660     $wrapper->output_like(qr/
661         X=\{SecondValTwoHundred\}
662         /msx,
663         "Can set breakpoint in a line.");
664 }
665
666 # Testing that the prompt with the information appears.
667 {
668     my $wrapper = DebugWrap->new(
669         {
670             cmds => ['q'],
671             prog => '../lib/perl5db/t/disable-breakpoints-1',
672         }
673     );
674
675     $wrapper->contents_like(qr/
676         ^main::\([^\)]*\bdisable-breakpoints-1:2\):\n
677         2:\s+my\ \$x\ =\ "One";\n
678         /msx,
679         "Prompt should display the first line of code.");
680 }
681
682 # Testing that R (restart) and "B *" work.
683 {
684     my $wrapper = DebugWrap->new(
685         {
686             cmds =>
687             [
688                 'b 13',
689                 'c',
690                 'B *',
691                 'b 9',
692                 'R',
693                 'c',
694                 q/print "X={$x};dummy={$dummy}\n";/,
695                 'q',
696             ],
697             prog =>  '../lib/perl5db/t/disable-breakpoints-1',
698         }
699     );
700
701     $wrapper->output_like(qr/
702         X=\{FirstVal\};dummy=\{1\}
703         /msx,
704         "Restart and delete all breakpoints work properly.");
705 }
706
707 {
708     my $wrapper = DebugWrap->new(
709         {
710             cmds =>
711             [
712                 'c 15',
713                 q/print "X={$x}\n";/,
714                 'c',
715                 'q',
716             ],
717             prog =>  '../lib/perl5db/t/disable-breakpoints-1',
718         }
719     );
720
721     $wrapper->output_like(qr/
722         X=\{ThirdVal\}
723         /msx,
724         "'c line_num' is working properly.");
725 }
726
727 {
728     my $wrapper = DebugWrap->new(
729         {
730             cmds =>
731             [
732                 'n',
733                 'n',
734                 'b . $exp > 200',
735                 'c',
736                 q/print "Exp={$exp}\n";/,
737                 'q',
738             ],
739             prog => '../lib/perl5db/t/break-on-dot',
740         }
741     );
742
743     $wrapper->output_like(qr/
744         Exp=\{256\}
745         /msx,
746         "'b .' is working correctly.");
747 }
748
749 # Testing that the prompt with the information appears inside a subroutine call.
750 # See https://rt.perl.org/rt3/Ticket/Display.html?id=104820
751 {
752     my $wrapper = DebugWrap->new(
753         {
754             cmds =>
755             [
756                 'c back',
757                 'q',
758             ],
759             prog => '../lib/perl5db/t/with-subroutine',
760         }
761     );
762
763     $wrapper->contents_like(
764         qr/
765         ^main::back\([^\)\n]*\bwith-subroutine:15\):[\ \t]*\n
766         ^15:\s*print\ "hello\ back\\n";
767         /msx,
768         "Prompt should display the line of code inside a subroutine.");
769 }
770
771 # Checking that the p command works.
772 {
773     my $wrapper = DebugWrap->new(
774         {
775             cmds =>
776             [
777                 'p "<<<" . (4*6) . ">>>"',
778                 'q',
779             ],
780             prog => '../lib/perl5db/t/with-subroutine',
781         }
782     );
783
784     $wrapper->contents_like(
785         qr/<<<24>>>/,
786         "p command works.");
787 }
788
789 # Tests for x.
790 {
791     my $wrapper = DebugWrap->new(
792         {
793             cmds =>
794             [
795                 q/x {500 => 600}/,
796                 'q',
797             ],
798             prog => '../lib/perl5db/t/with-subroutine',
799         }
800     );
801
802     $wrapper->contents_like(
803         # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
804         qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/ms,
805         "x command test."
806     );
807 }
808
809 # Tests for x with @_
810 {
811     my $wrapper = DebugWrap->new(
812         {
813             cmds =>
814             [
815                 'b 10',
816                 'c',
817                 'x @_',
818                 'q',
819             ],
820             prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc',
821         }
822     );
823
824     $wrapper->contents_like(
825         # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
826         qr/Arg1.*?Capsula.*GreekHumor.*Socrates/ms,
827         q/x command test with '@_'./,
828     );
829 }
830
831 # Tests for mutating @_
832 {
833     my $wrapper = DebugWrap->new(
834         {
835             cmds =>
836             [
837                 'b 10',
838                 'c',
839                 'shift(@_)',
840                 'print "\n\n\n(((" . join(",", @_) . ")))\n\n\n"',
841                 'q',
842             ],
843             prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc',
844         }
845     );
846
847     $wrapper->output_like(
848         qr/^\(\(\(Capsula,GreekHumor,Socrates\)\)\)$/ms,
849         q/Mutating '@_'./,
850     );
851 }
852
853 # Tests for x with AutoTrace=1.
854 {
855     my $wrapper = DebugWrap->new(
856         {
857             cmds =>
858             [
859                 'n',
860                 'o AutoTrace=1',
861                 # So it may fail.
862                 q/x "failure"/,
863                 q/x \$x/,
864                 'q',
865             ],
866             prog => '../lib/perl5db/t/with-subroutine',
867         }
868     );
869
870     $wrapper->contents_like(
871         # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
872         qr/^0\s+SCALAR\([^\)]+\)\n\s+-> 'hello world'\n/ms,
873         "x after AutoTrace=1 command is working."
874     );
875 }
876
877 # Tests for "T" (stack trace).
878 {
879     my $prog_fn = '../lib/perl5db/t/rt-104168';
880     my $wrapper = DebugWrap->new(
881         {
882             prog => $prog_fn,
883             cmds =>
884             [
885                 'c baz',
886                 'T',
887                 'q',
888             ],
889         }
890     );
891     my $re_text = join('',
892         map {
893         sprintf(
894             "%s = %s\\(\\) called from file " .
895             "'" . quotemeta($prog_fn) . "' line %s\\n",
896             (map { quotemeta($_) } @$_)
897             )
898         }
899         (
900             ['.', 'main::baz', 14,],
901             ['.', 'main::bar', 9,],
902             ['.', 'main::foo', 6],
903         )
904     );
905     $wrapper->contents_like(
906         # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
907         qr/^$re_text/ms,
908         "T command test."
909     );
910 }
911
912 # Test for s.
913 {
914     my $wrapper = DebugWrap->new(
915         {
916             cmds =>
917             [
918                 'b 9',
919                 'c',
920                 's',
921                 q/print "X={$x};dummy={$dummy}\n";/,
922                 'q',
923             ],
924             prog => '../lib/perl5db/t/disable-breakpoints-1'
925         }
926     );
927
928     $wrapper->output_like(qr/
929         X=\{SecondVal\};dummy=\{1\}
930         /msx,
931         'test for s - single step',
932     );
933 }
934
935 {
936     my $wrapper = DebugWrap->new(
937         {
938             cmds =>
939             [
940                 'n',
941                 'n',
942                 'b . $exp > 200',
943                 'c',
944                 q/print "Exp={$exp}\n";/,
945                 'q',
946             ],
947             prog => '../lib/perl5db/t/break-on-dot'
948         }
949     );
950
951     $wrapper->output_like(qr/
952         Exp=\{256\}
953         /msx,
954         "'b .' is working correctly.");
955 }
956
957 {
958     my $prog_fn = '../lib/perl5db/t/rt-104168';
959     my $wrapper = DebugWrap->new(
960         {
961             cmds =>
962             [
963                 's',
964                 'q',
965             ],
966             prog => $prog_fn,
967         }
968     );
969
970     $wrapper->contents_like(
971         qr/
972         ^main::foo\([^\)\n]*\brt-104168:9\):[\ \t]*\n
973         ^9:\s*bar\(\);
974         /msx,
975         'Test for the s command.',
976     );
977 }
978
979 {
980     my $wrapper = DebugWrap->new(
981         {
982             cmds =>
983             [
984                 's uncalled_subroutine()',
985                 'c',
986                 'q',
987             ],
988
989             prog => '../lib/perl5db/t/uncalled-subroutine'}
990     );
991
992     $wrapper->output_like(
993         qr/<1,2,3,4,5>\n/,
994         'uncalled_subroutine was called after s EXPR()',
995         );
996 }
997
998 {
999     my $wrapper = DebugWrap->new(
1000         {
1001             cmds =>
1002             [
1003                 'n uncalled_subroutine()',
1004                 'c',
1005                 'q',
1006             ],
1007             prog => '../lib/perl5db/t/uncalled-subroutine',
1008         }
1009     );
1010
1011     $wrapper->output_like(
1012         qr/<1,2,3,4,5>\n/,
1013         'uncalled_subroutine was called after n EXPR()',
1014         );
1015 }
1016
1017 {
1018     my $wrapper = DebugWrap->new(
1019         {
1020             cmds =>
1021             [
1022                 'b fact',
1023                 'c',
1024                 'c',
1025                 'c',
1026                 'n',
1027                 'print "<$n>"',
1028                 'q',
1029             ],
1030             prog => '../lib/perl5db/t/fact',
1031         }
1032     );
1033
1034     $wrapper->output_like(
1035         qr/<3>/,
1036         'b subroutine works fine',
1037     );
1038 }
1039
1040 # Test for n with lvalue subs
1041 DebugWrap->new({
1042     cmds =>
1043     [
1044         'n', 'print "<$x>\n"',
1045         'n', 'print "<$x>\n"',
1046         'q',
1047     ],
1048     prog => '../lib/perl5db/t/lsub-n',
1049 })->output_like(
1050     qr/<1>\n<11>\n/,
1051     'n steps over lvalue subs',
1052 );
1053
1054 # Test for 'M' (module list).
1055 {
1056     my $wrapper = DebugWrap->new(
1057         {
1058             cmds =>
1059             [
1060                 'M',
1061                 'q',
1062             ],
1063             prog => '../lib/perl5db/t/load-modules'
1064         }
1065     );
1066
1067     $wrapper->contents_like(
1068         qr[Scalar/Util\.pm],
1069         'M (module list) works fine',
1070     );
1071 }
1072
1073 {
1074     my $wrapper = DebugWrap->new(
1075         {
1076             cmds =>
1077             [
1078                 'b 14',
1079                 'c',
1080                 '$flag = 1;',
1081                 'r',
1082                 'print "Var=$var\n";',
1083                 'q',
1084             ],
1085             prog => '../lib/perl5db/t/test-r-statement',
1086         }
1087     );
1088
1089     $wrapper->output_like(
1090         qr/
1091             ^Foo$
1092                 .*?
1093             ^Bar$
1094                 .*?
1095             ^Var=Test$
1096         /msx,
1097         'r statement is working properly.',
1098     );
1099 }
1100
1101 {
1102     my $wrapper = DebugWrap->new(
1103         {
1104             cmds =>
1105             [
1106                 'l',
1107                 'q',
1108             ],
1109             prog => '../lib/perl5db/t/test-l-statement-1',
1110         }
1111     );
1112
1113     $wrapper->contents_like(
1114         qr/
1115             ^1==>\s+\$x\ =\ 1;\n
1116             2:\s+print\ "1\\n";\n
1117             3\s*\n
1118             4:\s+\$x\ =\ 2;\n
1119             5:\s+print\ "2\\n";\n
1120         /msx,
1121         'l statement is working properly (test No. 1).',
1122     );
1123 }
1124
1125 {
1126     my $wrapper = DebugWrap->new(
1127         {
1128             cmds =>
1129             [
1130                 'l',
1131                 q/# After l 1/,
1132                 'l',
1133                 q/# After l 2/,
1134                 '-',
1135                 q/# After -/,
1136                 'q',
1137             ],
1138             prog => '../lib/perl5db/t/test-l-statement-1',
1139         }
1140     );
1141
1142     my $first_l_out = qr/
1143         1==>\s+\$x\ =\ 1;\n
1144         2:\s+print\ "1\\n";\n
1145         3\s*\n
1146         4:\s+\$x\ =\ 2;\n
1147         5:\s+print\ "2\\n";\n
1148         6\s*\n
1149         7:\s+\$x\ =\ 3;\n
1150         8:\s+print\ "3\\n";\n
1151         9\s*\n
1152         10:\s+\$x\ =\ 4;\n
1153     /msx;
1154
1155     my $second_l_out = qr/
1156         11:\s+print\ "4\\n";\n
1157         12\s*\n
1158         13:\s+\$x\ =\ 5;\n
1159         14:\s+print\ "5\\n";\n
1160         15\s*\n
1161         16:\s+\$x\ =\ 6;\n
1162         17:\s+print\ "6\\n";\n
1163         18\s*\n
1164         19:\s+\$x\ =\ 7;\n
1165         20:\s+print\ "7\\n";\n
1166     /msx;
1167     $wrapper->contents_like(
1168         qr/
1169             ^$first_l_out
1170             [^\n]*?DB<\d+>\ \#\ After\ l\ 1\n
1171             [\ \t]*\n
1172             [^\n]*?DB<\d+>\ l\s*\n
1173             $second_l_out
1174             [^\n]*?DB<\d+>\ \#\ After\ l\ 2\n
1175             [\ \t]*\n
1176             [^\n]*?DB<\d+>\ -\s*\n
1177             $first_l_out
1178             [^\n]*?DB<\d+>\ \#\ After\ -\n
1179         /msx,
1180         'l followed by l and then followed by -',
1181     );
1182 }
1183
1184 {
1185     my $wrapper = DebugWrap->new(
1186         {
1187             cmds =>
1188             [
1189                 'l fact',
1190                 'q',
1191             ],
1192             prog => '../lib/perl5db/t/test-l-statement-2',
1193         }
1194     );
1195
1196     my $first_l_out = qr/
1197         6\s+sub\ fact\ \{\n
1198         7:\s+my\ \$n\ =\ shift;\n
1199         8:\s+if\ \(\$n\ >\ 1\)\ \{\n
1200         9:\s+return\ \$n\ \*\ fact\(\$n\ -\ 1\);
1201     /msx;
1202
1203     $wrapper->contents_like(
1204         qr/
1205             DB<1>\s+l\ fact\n
1206             $first_l_out
1207         /msx,
1208         'l subroutine_name',
1209     );
1210 }
1211
1212 {
1213     my $wrapper = DebugWrap->new(
1214         {
1215             cmds =>
1216             [
1217                 'b fact',
1218                 'c',
1219                 # Repeat several times to avoid @typeahead problems.
1220                 '.',
1221                 '.',
1222                 '.',
1223                 '.',
1224                 'q',
1225             ],
1226             prog => '../lib/perl5db/t/test-l-statement-2',
1227         }
1228     );
1229
1230     my $line_out = qr /
1231         ^main::fact\([^\n]*?:7\):\n
1232         ^7:\s+my\ \$n\ =\ shift;\n
1233     /msx;
1234
1235     $wrapper->contents_like(
1236         qr/
1237             $line_out
1238             auto\(-\d+\)\s+DB<\d+>\s+\.\n
1239             $line_out
1240         /msx,
1241         'Test the "." command',
1242     );
1243 }
1244
1245 # Testing that the f command works.
1246 {
1247     my $wrapper = DebugWrap->new(
1248         {
1249             cmds =>
1250             [
1251                 'f ../lib/perl5db/t/MyModule.pm',
1252                 'b 12',
1253                 'c',
1254                 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
1255                 'c',
1256                 'q',
1257             ],
1258             include_t => 1,
1259             prog => '../lib/perl5db/t/filename-line-breakpoint'
1260         }
1261     );
1262
1263     $wrapper->output_like(qr/
1264         ^Var=Bar$
1265             .*
1266         ^In\ MyModule\.$
1267             .*
1268         ^In\ Main\ File\.$
1269             .*
1270         /msx,
1271         "f command is working.",
1272     );
1273 }
1274
1275 # We broke the /pattern/ command because apparently the CORE::eval-s inside
1276 # lib/perl5db.pl cannot handle lexical variable properly. So we now fix this
1277 # bug.
1278 #
1279 # TODO :
1280 #
1281 # 1. Go over the rest of the "eval"s in lib/perl5db.t and see if they cause
1282 # problems.
1283 {
1284     my $wrapper = DebugWrap->new(
1285         {
1286             cmds =>
1287             [
1288                 '/for/',
1289                 'q',
1290             ],
1291             prog => '../lib/perl5db/t/eval-line-bug',
1292         }
1293     );
1294
1295     $wrapper->contents_like(
1296         qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1297         "/pat/ command is working and found a match.",
1298     );
1299 }
1300
1301 {
1302     my $wrapper = DebugWrap->new(
1303         {
1304             cmds =>
1305             [
1306                 'b 22',
1307                 'c',
1308                 '?for?',
1309                 'q',
1310             ],
1311             prog => '../lib/perl5db/t/eval-line-bug',
1312         }
1313     );
1314
1315     $wrapper->contents_like(
1316         qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1317         "?pat? command is working and found a match.",
1318     );
1319 }
1320
1321 # Test the L command.
1322 {
1323     my $wrapper = DebugWrap->new(
1324         {
1325             cmds =>
1326             [
1327                 'b 6',
1328                 'b 13 ($q == 5)',
1329                 'L',
1330                 'q',
1331             ],
1332             prog => '../lib/perl5db/t/eval-line-bug',
1333         }
1334     );
1335
1336     $wrapper->contents_like(
1337         qr#
1338         ^\S*?eval-line-bug:\n
1339         \s*6:\s*my\ \$i\ =\ 5;\n
1340         \s*break\ if\ \(1\)\n
1341         \s*13:\s*\$i\ \+=\ \$q;\n
1342         \s*break\ if\ \(\(\$q\ ==\ 5\)\)\n
1343         #msx,
1344         "L command is listing breakpoints",
1345     );
1346 }
1347
1348 # Test the L command for watch expressions.
1349 {
1350     my $wrapper = DebugWrap->new(
1351         {
1352             cmds =>
1353             [
1354                 'w (5+6)',
1355                 'L',
1356                 'q',
1357             ],
1358             prog => '../lib/perl5db/t/eval-line-bug',
1359         }
1360     );
1361
1362     $wrapper->contents_like(
1363         qr#
1364         ^Watch-expressions:\n
1365         \s*\(5\+6\)\n
1366         #msx,
1367         "L command is listing watch expressions",
1368     );
1369 }
1370
1371 {
1372     my $wrapper = DebugWrap->new(
1373         {
1374             cmds =>
1375             [
1376                 'w (5+6)',
1377                 'w (11*23)',
1378                 'W (5+6)',
1379                 'L',
1380                 'q',
1381             ],
1382             prog => '../lib/perl5db/t/eval-line-bug',
1383         }
1384     );
1385
1386     $wrapper->contents_like(
1387         qr#
1388         ^Watch-expressions:\n
1389         \s*\(11\*23\)\n
1390         ^auto\(
1391         #msx,
1392         "L command is not listing deleted watch expressions",
1393     );
1394 }
1395
1396 # Test the L command.
1397 {
1398     my $wrapper = DebugWrap->new(
1399         {
1400             cmds =>
1401             [
1402                 'b 6',
1403                 'a 13 print $i',
1404                 'L',
1405                 'q',
1406             ],
1407             prog => '../lib/perl5db/t/eval-line-bug',
1408         }
1409     );
1410
1411     $wrapper->contents_like(
1412         qr#
1413         ^\S*?eval-line-bug:\n
1414         \s*6:\s*my\ \$i\ =\ 5;\n
1415         \s*break\ if\ \(1\)\n
1416         \s*13:\s*\$i\ \+=\ \$q;\n
1417         \s*action:\s+print\ \$i\n
1418         #msx,
1419         "L command is listing actions and breakpoints",
1420     );
1421 }
1422
1423 {
1424     my $wrapper = DebugWrap->new(
1425         {
1426             cmds =>
1427             [
1428                 'S',
1429                 'q',
1430             ],
1431             prog =>  '../lib/perl5db/t/rt-104168',
1432         }
1433     );
1434
1435     $wrapper->contents_like(
1436         qr#
1437         ^main::bar\n
1438         main::baz\n
1439         main::foo\n
1440         #msx,
1441         "S command - 1",
1442     );
1443 }
1444
1445 {
1446     my $wrapper = DebugWrap->new(
1447         {
1448             cmds =>
1449             [
1450                 'S ^main::ba',
1451                 'q',
1452             ],
1453             prog =>  '../lib/perl5db/t/rt-104168',
1454         }
1455     );
1456
1457     $wrapper->contents_like(
1458         qr#
1459         ^main::bar\n
1460         main::baz\n
1461         auto\(
1462         #msx,
1463         "S command with regex",
1464     );
1465 }
1466
1467 {
1468     my $wrapper = DebugWrap->new(
1469         {
1470             cmds =>
1471             [
1472                 'S !^main::ba',
1473                 'q',
1474             ],
1475             prog =>  '../lib/perl5db/t/rt-104168',
1476         }
1477     );
1478
1479     $wrapper->contents_unlike(
1480         qr#
1481         ^main::ba
1482         #msx,
1483         "S command with negative regex",
1484     );
1485
1486     $wrapper->contents_like(
1487         qr#
1488         ^main::foo\n
1489         #msx,
1490         "S command with negative regex - what it still matches",
1491     );
1492 }
1493
1494 # Test the 'a' command.
1495 {
1496     my $wrapper = DebugWrap->new(
1497         {
1498             cmds =>
1499             [
1500                 'a 13 print "\nVar<Q>=$q\n"',
1501                 'c',
1502                 'q',
1503             ],
1504             prog => '../lib/perl5db/t/eval-line-bug',
1505         }
1506     );
1507
1508     my $nl = $^O eq 'VMS' ? "" : "\\\n";
1509     $wrapper->output_like(qr#
1510         \nVar<Q>=1$nl
1511         \nVar<Q>=2$nl
1512         \nVar<Q>=3
1513         #msx,
1514         "a command is working",
1515     );
1516 }
1517
1518 # Test the 'a' command with no line number.
1519 {
1520     my $wrapper = DebugWrap->new(
1521         {
1522             cmds =>
1523             [
1524                 'n',
1525                 q/a print "Hello " . (3 * 4) . "\n";/,
1526                 'c',
1527                 'q',
1528             ],
1529             prog => '../lib/perl5db/t/test-a-statement-1',
1530         }
1531     );
1532
1533     $wrapper->output_like(qr#
1534         (?:^Hello\ 12\n.*?){4}
1535         #msx,
1536         "a command with no line number is working",
1537     );
1538 }
1539
1540 # Test the 'A' command
1541 {
1542     my $wrapper = DebugWrap->new(
1543         {
1544             cmds =>
1545             [
1546                 'a 13 print "\nVar<Q>=$q\n"',
1547                 'A 13',
1548                 'c',
1549                 'q',
1550             ],
1551             prog => '../lib/perl5db/t/eval-line-bug',
1552         }
1553     );
1554
1555     $wrapper->output_like(
1556         qr#\A\z#msx, # The empty string.
1557         "A command (for removing actions) is working",
1558     );
1559 }
1560
1561 # Test the 'A *' command
1562 {
1563     my $wrapper = DebugWrap->new(
1564         {
1565             cmds =>
1566             [
1567                 'a 6 print "\nFail!\n"',
1568                 'a 13 print "\nVar<Q>=$q\n"',
1569                 'A *',
1570                 'c',
1571                 'q',
1572             ],
1573             prog => '../lib/perl5db/t/eval-line-bug',
1574         }
1575     );
1576
1577     $wrapper->output_like(
1578         qr#\A\z#msx, # The empty string.
1579         "'A *' command (for removing all actions) is working",
1580     );
1581 }
1582
1583 {
1584     my $wrapper = DebugWrap->new(
1585         {
1586             cmds =>
1587             [
1588                 'n',
1589                 'w $foo',
1590                 'c',
1591                 'print "\nIDX=<$idx>\n"',
1592                 'q',
1593             ],
1594             prog => '../lib/perl5db/t/test-w-statement-1',
1595         }
1596     );
1597
1598
1599     $wrapper->contents_like(qr#
1600         \$foo\ changed:\n
1601         \s+old\ value:\s+'1'\n
1602         \s+new\ value:\s+'2'\n
1603         #msx,
1604         'w command - watchpoint changed',
1605     );
1606     $wrapper->output_like(qr#
1607         \nIDX=<20>\n
1608         #msx,
1609         "w command - correct output from IDX",
1610     );
1611 }
1612
1613 {
1614     my $wrapper = DebugWrap->new(
1615         {
1616             cmds =>
1617             [
1618                 'n',
1619                 'w $foo',
1620                 'W $foo',
1621                 'c',
1622                 'print "\nIDX=<$idx>\n"',
1623                 'q',
1624             ],
1625             prog => '../lib/perl5db/t/test-w-statement-1',
1626         }
1627     );
1628
1629     $wrapper->contents_unlike(qr#
1630         \$foo\ changed:
1631         #msx,
1632         'W command - watchpoint was deleted',
1633     );
1634
1635     $wrapper->output_like(qr#
1636         \nIDX=<>\n
1637         #msx,
1638         "W command - stopped at end.",
1639     );
1640 }
1641
1642 # Test the W * command.
1643 {
1644     my $wrapper = DebugWrap->new(
1645         {
1646             cmds =>
1647             [
1648                 'n',
1649                 'w $foo',
1650                 'w ($foo*$foo)',
1651                 'W *',
1652                 'c',
1653                 'print "\nIDX=<$idx>\n"',
1654                 'q',
1655             ],
1656             prog => '../lib/perl5db/t/test-w-statement-1',
1657         }
1658     );
1659
1660     $wrapper->contents_unlike(qr#
1661         \$foo\ changed:
1662         #msx,
1663         '"W *" command - watchpoint was deleted',
1664     );
1665
1666     $wrapper->output_like(qr#
1667         \nIDX=<>\n
1668         #msx,
1669         '"W *" command - stopped at end.',
1670     );
1671 }
1672
1673 # Test the 'o' command (without further arguments).
1674 {
1675     my $wrapper = DebugWrap->new(
1676         {
1677             cmds =>
1678             [
1679                 'o',
1680                 'q',
1681             ],
1682             prog => '../lib/perl5db/t/test-w-statement-1',
1683         }
1684     );
1685
1686     $wrapper->contents_like(qr#
1687         ^\s*warnLevel\ =\ '1'\n
1688         #msx,
1689         q#"o" command (without arguments) displays warnLevel#,
1690     );
1691
1692     $wrapper->contents_like(qr#
1693         ^\s*signalLevel\ =\ '1'\n
1694         #msx,
1695         q#"o" command (without arguments) displays signalLevel#,
1696     );
1697
1698     $wrapper->contents_like(qr#
1699         ^\s*dieLevel\ =\ '1'\n
1700         #msx,
1701         q#"o" command (without arguments) displays dieLevel#,
1702     );
1703
1704     $wrapper->contents_like(qr#
1705         ^\s*hashDepth\ =\ 'N/A'\n
1706         #msx,
1707         q#"o" command (without arguments) displays hashDepth#,
1708     );
1709 }
1710
1711 # Test the 'o' query command.
1712 {
1713     my $wrapper = DebugWrap->new(
1714         {
1715             cmds =>
1716             [
1717                 'o hashDepth? signalLevel?',
1718                 'q',
1719             ],
1720             prog => '../lib/perl5db/t/test-w-statement-1',
1721         }
1722     );
1723
1724     $wrapper->contents_unlike(qr#warnLevel#,
1725         q#"o" query command does not display warnLevel#,
1726     );
1727
1728     $wrapper->contents_like(qr#
1729         ^\s*signalLevel\ =\ '1'\n
1730         #msx,
1731         q#"o" query command displays signalLevel#,
1732     );
1733
1734     $wrapper->contents_unlike(qr#dieLevel#,
1735         q#"o" query command does not display dieLevel#,
1736     );
1737
1738     $wrapper->contents_like(qr#
1739         ^\s*hashDepth\ =\ 'N/A'\n
1740         #msx,
1741         q#"o" query command displays hashDepth#,
1742     );
1743 }
1744
1745 # Test the 'o' set command.
1746 {
1747     my $wrapper = DebugWrap->new(
1748         {
1749             cmds =>
1750             [
1751                 'o signalLevel=0',
1752                 'o',
1753                 'q',
1754             ],
1755             prog => '../lib/perl5db/t/test-w-statement-1',
1756         }
1757     );
1758
1759     $wrapper->contents_like(qr/
1760         ^\s*(signalLevel\ =\ '0'\n)
1761         .*?
1762         ^\s*\1
1763         /msx,
1764         q#o set command works#,
1765     );
1766
1767     $wrapper->contents_like(qr#
1768         ^\s*hashDepth\ =\ 'N/A'\n
1769         #msx,
1770         q#o set command - hashDepth#,
1771     );
1772 }
1773
1774 # Test the '<' and "< ?" commands.
1775 {
1776     my $wrapper = DebugWrap->new(
1777         {
1778             cmds =>
1779             [
1780                 q/< print "\nX=<$x>\n"/,
1781                 q/b 7/,
1782                 q/< ?/,
1783                 'c',
1784                 'q',
1785             ],
1786             prog => '../lib/perl5db/t/disable-breakpoints-1',
1787         }
1788     );
1789
1790     $wrapper->contents_like(qr/
1791         ^pre-perl\ commands:\n
1792         \s*<\ --\ print\ "\\nX=<\$x>\\n"\n
1793         /msx,
1794         q#Test < and < ? commands - contents.#,
1795     );
1796
1797     $wrapper->output_like(qr#
1798         ^X=<FirstVal>\n
1799         #msx,
1800         q#Test < and < ? commands - output.#,
1801     );
1802 }
1803
1804 # Test the '< *' command.
1805 {
1806     my $wrapper = DebugWrap->new(
1807         {
1808             cmds =>
1809             [
1810                 q/< print "\nX=<$x>\n"/,
1811                 q/b 7/,
1812                 q/< */,
1813                 'c',
1814                 'q',
1815             ],
1816             prog => '../lib/perl5db/t/disable-breakpoints-1',
1817         }
1818     );
1819
1820     $wrapper->output_unlike(qr/FirstVal/,
1821         q#Test the '< *' command.#,
1822     );
1823 }
1824
1825 # Test the '>' and "> ?" commands.
1826 {
1827     my $wrapper = DebugWrap->new(
1828         {
1829             cmds =>
1830             [
1831                 q/$::foo = 500;/,
1832                 q/> print "\nFOO=<$::foo>\n"/,
1833                 q/b 7/,
1834                 q/> ?/,
1835                 'c',
1836                 'q',
1837             ],
1838             prog => '../lib/perl5db/t/disable-breakpoints-1',
1839         }
1840     );
1841
1842     $wrapper->contents_like(qr/
1843         ^post-perl\ commands:\n
1844         \s*>\ --\ print\ "\\nFOO=<\$::foo>\\n"\n
1845         /msx,
1846         q#Test > and > ? commands - contents.#,
1847     );
1848
1849     $wrapper->output_like(qr#
1850         ^FOO=<500>\n
1851         #msx,
1852         q#Test > and > ? commands - output.#,
1853     );
1854 }
1855
1856 # Test the '> *' command.
1857 {
1858     my $wrapper = DebugWrap->new(
1859         {
1860             cmds =>
1861             [
1862                 q/> print "\nFOO=<$::foo>\n"/,
1863                 q/b 7/,
1864                 q/> */,
1865                 'c',
1866                 'q',
1867             ],
1868             prog => '../lib/perl5db/t/disable-breakpoints-1',
1869         }
1870     );
1871
1872     $wrapper->output_unlike(qr/FOO=/,
1873         q#Test the '> *' command.#,
1874     );
1875 }
1876
1877 # Test the < and > commands together
1878 {
1879     my $wrapper = DebugWrap->new(
1880         {
1881             cmds =>
1882             [
1883                 q/$::lorem = 0;/,
1884                 q/< $::lorem += 10;/,
1885                 q/> print "\nLOREM=<$::lorem>\n"/,
1886                 q/b 7/,
1887                 q/b 5/,
1888                 'c',
1889                 'c',
1890                 'q',
1891             ],
1892             prog => '../lib/perl5db/t/disable-breakpoints-1',
1893         }
1894     );
1895
1896     $wrapper->output_like(qr#
1897         ^LOREM=<10>\n
1898         #msx,
1899         q#Test < and > commands. #,
1900     );
1901 }
1902
1903 # Test the { ? and { [command] commands.
1904 {
1905     my $wrapper = DebugWrap->new(
1906         {
1907             cmds =>
1908             [
1909                 '{ ?',
1910                 '{ l',
1911                 '{ ?',
1912                 q/b 5/,
1913                 q/c/,
1914                 q/q/,
1915             ],
1916             prog => '../lib/perl5db/t/disable-breakpoints-1',
1917         }
1918     );
1919
1920     $wrapper->contents_like(qr#
1921         ^No\ pre-debugger\ actions\.\n
1922         .*?
1923         ^pre-debugger\ commands:\n
1924         \s+\{\ --\ l\n
1925         .*?
1926         ^5==>b\s+\$x\ =\ "FirstVal";\n
1927         6\s*\n
1928         7:\s+\$dummy\+\+;\n
1929         8\s*\n
1930         9:\s+\$x\ =\ "SecondVal";\n
1931
1932         #msx,
1933         'Test the pre-prompt debugger commands',
1934     );
1935 }
1936
1937 # Test the { * command.
1938 {
1939     my $wrapper = DebugWrap->new(
1940         {
1941             cmds =>
1942             [
1943                 '{ q',
1944                 '{ *',
1945                 q/b 5/,
1946                 q/c/,
1947                 q/print (("One" x 5), "\n");/,
1948                 q/q/,
1949             ],
1950             prog => '../lib/perl5db/t/disable-breakpoints-1',
1951         }
1952     );
1953
1954     $wrapper->contents_like(qr#
1955         ^All\ \{\ actions\ cleared\.\n
1956         #msx,
1957         'Test the { * command',
1958     );
1959
1960     $wrapper->output_like(qr/OneOneOneOneOne/,
1961         '{ * test - output is OK.',
1962     );
1963 }
1964
1965 # Test the ! command.
1966 {
1967     my $wrapper = DebugWrap->new(
1968         {
1969             cmds =>
1970             [
1971                 'l 3-5',
1972                 '!',
1973                 'q',
1974             ],
1975             prog => '../lib/perl5db/t/disable-breakpoints-1',
1976         }
1977     );
1978
1979     $wrapper->contents_like(qr#
1980         (^3:\s+my\ \$dummy\ =\ 0;\n
1981         4\s*\n
1982         5:\s+\$x\ =\ "FirstVal";)\n
1983         .*?
1984         ^l\ 3-5\n
1985         \1
1986         #msx,
1987         'Test the ! command (along with l 3-5)',
1988     );
1989 }
1990
1991 # Test the ! -number command.
1992 {
1993     my $wrapper = DebugWrap->new(
1994         {
1995             cmds =>
1996             [
1997                 'l 3-5',
1998                 'l 2',
1999                 '! -1',
2000                 'q',
2001             ],
2002             prog => '../lib/perl5db/t/disable-breakpoints-1',
2003         }
2004     );
2005
2006     $wrapper->contents_like(qr#
2007         (^3:\s+my\ \$dummy\ =\ 0;\n
2008         4\s*\n
2009         5:\s+\$x\ =\ "FirstVal";)\n
2010         .*?
2011         ^2==\>\s+my\ \$x\ =\ "One";\n
2012         .*?
2013         ^l\ 3-5\n
2014         \1
2015         #msx,
2016         'Test the ! -n command (along with l)',
2017     );
2018 }
2019
2020 # Test the 'source' command.
2021 {
2022     my $wrapper = DebugWrap->new(
2023         {
2024             cmds =>
2025             [
2026                 'source ../lib/perl5db/t/source-cmd-test.perldb',
2027                 # If we have a 'q' here, then the typeahead will override the
2028                 # input, and so it won't be reached - solution:
2029                 # put a q inside the .perldb commands.
2030                 # ( This may be a bug or a misfeature. )
2031             ],
2032             prog => '../lib/perl5db/t/disable-breakpoints-1',
2033         }
2034     );
2035
2036     $wrapper->contents_like(qr#
2037         ^3:\s+my\ \$dummy\ =\ 0;\n
2038         4\s*\n
2039         5:\s+\$x\ =\ "FirstVal";\n
2040         6\s*\n
2041         7:\s+\$dummy\+\+;\n
2042         8\s*\n
2043         9:\s+\$x\ =\ "SecondVal";\n
2044         10\s*\n
2045         #msx,
2046         'Test the source command (along with l)',
2047     );
2048 }
2049
2050 # Test the 'source' command being traversed from withing typeahead.
2051 {
2052     my $wrapper = DebugWrap->new(
2053         {
2054             cmds =>
2055             [
2056                 'source ../lib/perl5db/t/source-cmd-test-no-q.perldb',
2057                 'q',
2058             ],
2059             prog => '../lib/perl5db/t/disable-breakpoints-1',
2060         }
2061     );
2062
2063     $wrapper->contents_like(qr#
2064         ^3:\s+my\ \$dummy\ =\ 0;\n
2065         4\s*\n
2066         5:\s+\$x\ =\ "FirstVal";\n
2067         6\s*\n
2068         7:\s+\$dummy\+\+;\n
2069         8\s*\n
2070         9:\s+\$x\ =\ "SecondVal";\n
2071         10\s*\n
2072         #msx,
2073         'Test the source command inside a typeahead',
2074     );
2075 }
2076
2077 # Test the 'H -number' command.
2078 {
2079     my $wrapper = DebugWrap->new(
2080         {
2081             cmds =>
2082             [
2083                 'l 1-10',
2084                 'l 5-10',
2085                 'x "Hello World"',
2086                 'l 1-5',
2087                 'b 3',
2088                 'x (20+4)',
2089                 'H -7',
2090                 'q',
2091             ],
2092             prog => '../lib/perl5db/t/disable-breakpoints-1',
2093         }
2094     );
2095
2096     $wrapper->contents_like(qr#
2097         ^\d+:\s+H\ -7\n
2098         \d+:\s+x\ \(20\+4\)\n
2099         \d+:\s+b\ 3\n
2100         \d+:\s+l\ 1-5\n
2101         \d+:\s+x\ "Hello\ World"\n
2102         \d+:\s+l\ 5-10\n
2103         \d+:\s+l\ 1-10\n
2104         #msx,
2105         'Test the H -num command',
2106     );
2107 }
2108
2109 # Add a test for H (without arguments)
2110 {
2111     my $wrapper = DebugWrap->new(
2112         {
2113             cmds =>
2114             [
2115                 'l 1-10',
2116                 'l 5-10',
2117                 'x "Hello World"',
2118                 'l 1-5',
2119                 'b 3',
2120                 'x (20+4)',
2121                 'H',
2122                 'q',
2123             ],
2124             prog => '../lib/perl5db/t/disable-breakpoints-1',
2125         }
2126     );
2127
2128     $wrapper->contents_like(qr#
2129         ^\d+:\s+x\ \(20\+4\)\n
2130         \d+:\s+b\ 3\n
2131         \d+:\s+l\ 1-5\n
2132         \d+:\s+x\ "Hello\ World"\n
2133         \d+:\s+l\ 5-10\n
2134         \d+:\s+l\ 1-10\n
2135         #msx,
2136         'Test the H command (without a number.)',
2137     );
2138 }
2139
2140 {
2141     my $wrapper = DebugWrap->new(
2142         {
2143             cmds =>
2144             [
2145                 '= quit q',
2146                 '= foobar l',
2147                 'foobar',
2148                 'quit',
2149             ],
2150             prog => '../lib/perl5db/t/test-l-statement-1',
2151         }
2152     );
2153
2154     $wrapper->contents_like(
2155         qr/
2156             ^1==>\s+\$x\ =\ 1;\n
2157             2:\s+print\ "1\\n";\n
2158             3\s*\n
2159             4:\s+\$x\ =\ 2;\n
2160             5:\s+print\ "2\\n";\n
2161         /msx,
2162         'Test the = (command alias) command.',
2163     );
2164 }
2165
2166 # Test the m statement.
2167 {
2168     my $wrapper = DebugWrap->new(
2169         {
2170             cmds =>
2171             [
2172                 'm main',
2173                 'q',
2174             ],
2175             prog => '../lib/perl5db/t/disable-breakpoints-1',
2176         }
2177     );
2178
2179     $wrapper->contents_like(qr#
2180         ^via\ UNIVERSAL:\ DOES$
2181         #msx,
2182         "Test m for main - 1",
2183     );
2184
2185     $wrapper->contents_like(qr#
2186         ^via\ UNIVERSAL:\ can$
2187         #msx,
2188         "Test m for main - 2",
2189     );
2190 }
2191
2192 # Test the m statement.
2193 {
2194     my $wrapper = DebugWrap->new(
2195         {
2196             cmds =>
2197             [
2198                 'b 41',
2199                 'c',
2200                 'm $obj',
2201                 'q',
2202             ],
2203             prog => '../lib/perl5db/t/test-m-statement-1',
2204         }
2205     );
2206
2207     $wrapper->contents_like(qr#^greet$#ms,
2208         "Test m for obj - 1",
2209     );
2210
2211     $wrapper->contents_like(qr#^via UNIVERSAL: can$#ms,
2212         "Test m for obj - 1",
2213     );
2214 }
2215
2216 # Test the M command.
2217 {
2218     my $wrapper = DebugWrap->new(
2219         {
2220             cmds =>
2221             [
2222                 'M',
2223                 'q',
2224             ],
2225             prog => '../lib/perl5db/t/test-m-statement-1',
2226         }
2227     );
2228
2229     $wrapper->contents_like(qr#
2230         ^'strict\.pm'\ =>\ '\d+\.\d+\ from
2231         #msx,
2232         "Test M",
2233     );
2234
2235 }
2236
2237 # Test the recallCommand option.
2238 {
2239     my $wrapper = DebugWrap->new(
2240         {
2241             cmds =>
2242             [
2243                 'o recallCommand=%',
2244                 'l 3-5',
2245                 'l 2',
2246                 '% -1',
2247                 'q',
2248             ],
2249             prog => '../lib/perl5db/t/disable-breakpoints-1',
2250         }
2251     );
2252
2253     $wrapper->contents_like(qr#
2254         (^3:\s+my\ \$dummy\ =\ 0;\n
2255         4\s*\n
2256         5:\s+\$x\ =\ "FirstVal";)\n
2257         .*?
2258         ^2==\>\s+my\ \$x\ =\ "One";\n
2259         .*?
2260         ^l\ 3-5\n
2261         \1
2262         #msx,
2263         'Test the o recallCommand option',
2264     );
2265 }
2266
2267 # Test the dieLevel option
2268 {
2269     my $wrapper = DebugWrap->new(
2270         {
2271             cmds =>
2272             [
2273                 q/o dieLevel='1'/,
2274                 q/c/,
2275                 'q',
2276             ],
2277             prog => '../lib/perl5db/t/test-dieLevel-option-1',
2278         }
2279     );
2280
2281     $wrapper->output_like(qr#
2282         ^This\ program\ dies\.\ at\ \S+\ line\ 18\N*\.\n
2283         .*?
2284         ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
2285         \s+main::bar\(\)\ called\ at\ \S+\ line\ 7\n
2286         \s+main::foo\(\)\ called\ at\ \S+\ line\ 21\n
2287         #msx,
2288         'Test the o dieLevel option',
2289     );
2290 }
2291
2292 # Test the warnLevel option
2293 {
2294     my $wrapper = DebugWrap->new(
2295         {
2296             cmds =>
2297             [
2298                 q/o warnLevel='1'/,
2299                 q/c/,
2300                 'q',
2301             ],
2302             prog => '../lib/perl5db/t/test-warnLevel-option-1',
2303         }
2304     );
2305
2306     $wrapper->contents_like(qr#
2307         ^This\ is\ not\ a\ warning\.\ at\ \S+\ line\ 18\N*\.\n
2308         .*?
2309         ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
2310         \s+main::bar\(\)\ called\ at\ \S+\ line\ 25\n
2311         \s+main::myfunc\(\)\ called\ at\ \S+\ line\ 28\n
2312         #msx,
2313         'Test the o warnLevel option',
2314     );
2315 }
2316
2317 # Test the t command
2318 {
2319     my $wrapper = DebugWrap->new(
2320         {
2321             cmds =>
2322             [
2323                 't',
2324                 'c',
2325                 'q',
2326             ],
2327             prog => '../lib/perl5db/t/disable-breakpoints-1',
2328         }
2329     );
2330
2331     $wrapper->contents_like(qr/
2332         ^main::\([^:]+:15\):\n
2333         15:\s+\$dummy\+\+;\n
2334         main::\([^:]+:17\):\n
2335         17:\s+\$x\ =\ "FourthVal";\n
2336         /msx,
2337         'Test the t command (without a number.)',
2338     );
2339 }
2340
2341 # Test the o AutoTrace command
2342 {
2343     my $wrapper = DebugWrap->new(
2344         {
2345             cmds =>
2346             [
2347                 'o AutoTrace',
2348                 'c',
2349                 'q',
2350             ],
2351             prog => '../lib/perl5db/t/disable-breakpoints-1',
2352         }
2353     );
2354
2355     $wrapper->contents_like(qr/
2356         ^main::\([^:]+:15\):\n
2357         15:\s+\$dummy\+\+;\n
2358         main::\([^:]+:17\):\n
2359         17:\s+\$x\ =\ "FourthVal";\n
2360         /msx,
2361         'Test the o AutoTrace command',
2362     );
2363 }
2364
2365 # Test the t command with function calls
2366 {
2367     my $wrapper = DebugWrap->new(
2368         {
2369             cmds =>
2370             [
2371                 't',
2372                 'b 18',
2373                 'c',
2374                 'x ["foo"]',
2375                 'x ["bar"]',
2376                 'q',
2377             ],
2378             prog => '../lib/perl5db/t/test-warnLevel-option-1',
2379         }
2380     );
2381
2382     $wrapper->contents_like(qr/
2383         ^main::\([^:]+:28\):\n
2384         28:\s+myfunc\(\);\n
2385         auto\(-\d+\)\s+DB<1>\s+t\n
2386         Trace\ =\ on\n
2387         auto\(-\d+\)\s+DB<1>\s+b\ 18\n
2388         auto\(-\d+\)\s+DB<2>\s+c\n
2389         main::myfunc\([^:]+:25\):\n
2390         25:\s+bar\(\);\n
2391         /msx,
2392         'Test the t command with function calls.',
2393     );
2394 }
2395
2396 # Test the o AutoTrace command with function calls
2397 {
2398     my $wrapper = DebugWrap->new(
2399         {
2400             cmds =>
2401             [
2402                 'o AutoTrace',
2403                 'b 18',
2404                 'c',
2405                 'x ["foo"]',
2406                 'x ["bar"]',
2407                 'q',
2408             ],
2409             prog => '../lib/perl5db/t/test-warnLevel-option-1',
2410         }
2411     );
2412
2413     $wrapper->contents_like(qr/
2414         ^main::\([^:]+:28\):\n
2415         28:\s+myfunc\(\);\n
2416         auto\(-\d+\)\s+DB<1>\s+o\ AutoTrace\n
2417         \s+AutoTrace\s+=\s+'1'\n
2418         auto\(-\d+\)\s+DB<2>\s+b\ 18\n
2419         auto\(-\d+\)\s+DB<3>\s+c\n
2420         main::myfunc\([^:]+:25\):\n
2421         25:\s+bar\(\);\n
2422         /msx,
2423         'Test the o AutoTrace command with function calls.',
2424     );
2425 }
2426
2427 # Test the final message.
2428 {
2429     my $wrapper = DebugWrap->new(
2430         {
2431             cmds =>
2432             [
2433                 'c',
2434                 'q',
2435             ],
2436             prog => '../lib/perl5db/t/test-warnLevel-option-1',
2437         }
2438     );
2439
2440     $wrapper->contents_like(qr/
2441         ^Debugged\ program\ terminated\.
2442         /msx,
2443         'Test the final "Debugged program terminated" message.',
2444     );
2445 }
2446
2447 # Test the o inhibit_exit=0 command
2448 {
2449     my $wrapper = DebugWrap->new(
2450         {
2451             cmds =>
2452             [
2453                 'o inhibit_exit=0',
2454                 'n',
2455                 'n',
2456                 'n',
2457                 'n',
2458                 'q',
2459             ],
2460             prog => '../lib/perl5db/t/test-warnLevel-option-1',
2461         }
2462     );
2463
2464     $wrapper->contents_unlike(qr/
2465         ^Debugged\ program\ terminated\.
2466         /msx,
2467         'Test the o inhibit_exit=0 command.',
2468     );
2469 }
2470
2471 # Test the o PrintRet=1 option
2472 {
2473     my $wrapper = DebugWrap->new(
2474         {
2475             cmds =>
2476             [
2477                 'o PrintRet=1',
2478                 'b 29',
2479                 'c',
2480                 q/$x = 's';/,
2481                 'b 10',
2482                 'c',
2483                 'r',
2484                 'q',
2485             ],
2486             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2487         }
2488     );
2489
2490     $wrapper->contents_like(
2491         qr/scalar context return from main::return_scalar: 20024/,
2492         "Test o PrintRet=1",
2493     );
2494 }
2495
2496 # Test the o PrintRet=0 option
2497 {
2498     my $wrapper = DebugWrap->new(
2499         {
2500             cmds =>
2501             [
2502                 'o PrintRet=0',
2503                 'b 29',
2504                 'c',
2505                 q/$x = 's';/,
2506                 'b 10',
2507                 'c',
2508                 'r',
2509                 'q',
2510             ],
2511             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2512         }
2513     );
2514
2515     $wrapper->contents_unlike(
2516         qr/scalar context/,
2517         "Test o PrintRet=0",
2518     );
2519 }
2520
2521 # Test the o PrintRet=1 option in list context
2522 {
2523     my $wrapper = DebugWrap->new(
2524         {
2525             cmds =>
2526             [
2527                 'o PrintRet=1',
2528                 'b 29',
2529                 'c',
2530                 q/$x = 'l';/,
2531                 'b 17',
2532                 'c',
2533                 'r',
2534                 'q',
2535             ],
2536             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2537         }
2538     );
2539
2540     $wrapper->contents_like(
2541         qr/list context return from main::return_list:\n0\s*'Foo'\n1\s*'Bar'\n2\s*'Baz'\n/,
2542         "Test o PrintRet=1 in list context",
2543     );
2544 }
2545
2546 # Test the o PrintRet=0 option in list context
2547 {
2548     my $wrapper = DebugWrap->new(
2549         {
2550             cmds =>
2551             [
2552                 'o PrintRet=0',
2553                 'b 29',
2554                 'c',
2555                 q/$x = 'l';/,
2556                 'b 17',
2557                 'c',
2558                 'r',
2559                 'q',
2560             ],
2561             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2562         }
2563     );
2564
2565     $wrapper->contents_unlike(
2566         qr/list context/,
2567         "Test o PrintRet=0 in list context",
2568     );
2569 }
2570
2571 # Test the o PrintRet=1 option in void context
2572 {
2573     my $wrapper = DebugWrap->new(
2574         {
2575             cmds =>
2576             [
2577                 'o PrintRet=1',
2578                 'b 29',
2579                 'c',
2580                 q/$x = 'v';/,
2581                 'b 24',
2582                 'c',
2583                 'r',
2584                 'q',
2585             ],
2586             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2587         }
2588     );
2589
2590     $wrapper->contents_like(
2591         qr/void context return from main::return_void/,
2592         "Test o PrintRet=1 in void context",
2593     );
2594 }
2595
2596 # Test the o PrintRet=1 option in void context
2597 {
2598     my $wrapper = DebugWrap->new(
2599         {
2600             cmds =>
2601             [
2602                 'o PrintRet=0',
2603                 'b 29',
2604                 'c',
2605                 q/$x = 'v';/,
2606                 'b 24',
2607                 'c',
2608                 'r',
2609                 'q',
2610             ],
2611             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2612         }
2613     );
2614
2615     $wrapper->contents_unlike(
2616         qr/void context/,
2617         "Test o PrintRet=0 in void context",
2618     );
2619 }
2620
2621 # Test the o frame option.
2622 {
2623     my $wrapper = DebugWrap->new(
2624         {
2625             cmds =>
2626             [
2627                 # This is to avoid getting the "Debugger program terminated"
2628                 # junk that interferes with the normal output.
2629                 'o inhibit_exit=0',
2630                 'b 10',
2631                 'c',
2632                 'o frame=255',
2633                 'c',
2634                 'q',
2635             ],
2636             prog => '../lib/perl5db/t/test-frame-option-1',
2637         }
2638     );
2639
2640     $wrapper->contents_like(
2641         qr/
2642             in\s*\.=main::my_other_func\(3,\ 1200\)\ from.*?
2643             out\s*\.=main::my_other_func\(3,\ 1200\)\ from
2644         /msx,
2645         "Test o PrintRet=0 in void context",
2646     );
2647 }
2648
2649 { # test t expr
2650     my $wrapper = DebugWrap->new(
2651         {
2652             cmds =>
2653             [
2654                 # This is to avoid getting the "Debugger program terminated"
2655                 # junk that interferes with the normal output.
2656                 'o inhibit_exit=0',
2657                 't fact(3)',
2658                 'q',
2659             ],
2660             prog => '../lib/perl5db/t/fact',
2661         }
2662     );
2663
2664     $wrapper->contents_like(
2665         qr/
2666             (?:^main::fact.*return\ \$n\ \*\ fact\(\$n\ -\ 1\);.*)
2667         /msx,
2668         "Test t expr",
2669     );
2670 }
2671
2672 # Test the w for lexical variables expression.
2673 {
2674     my $wrapper = DebugWrap->new(
2675         {
2676             cmds =>
2677             [
2678                 # This is to avoid getting the "Debugger program terminated"
2679                 # junk that interferes with the normal output.
2680                 'w $exp',
2681                 'n',
2682                 'n',
2683                 'n',
2684                 'n',
2685                 'q',
2686             ],
2687             prog => '../lib/perl5db/t/break-on-dot',
2688         }
2689     );
2690
2691     $wrapper->contents_like(
2692         qr/
2693 \s+old\ value:\s+'1'\n
2694 \s+new\ value:\s+'2'\n
2695         /msx,
2696         "Test w for lexical values.",
2697     );
2698 }
2699
2700 # perl 5 RT #121509 regression bug.
2701 # “perl debugger doesn't save starting dir to restart from”
2702 # Thanks to Linda Walsh for reporting it.
2703 {
2704     use File::Temp qw/tempdir/;
2705
2706     my $temp_dir = tempdir( CLEANUP => 1 );
2707
2708     local $ENV{__PERLDB_TEMP_DIR} = $temp_dir;
2709     my $wrapper = DebugWrap->new(
2710         {
2711             cmds =>
2712             [
2713                 # This is to avoid getting the "Debugger program terminated"
2714                 # junk that interferes with the normal output.
2715                 'b _after_chdir',
2716                 'c',
2717                 'R',
2718                 'b _finale',
2719                 'c',
2720                 'n',
2721                 'n',
2722                 'n',
2723                 'n',
2724                 'n',
2725                 'n',
2726                 'n',
2727                 'n',
2728                 'n',
2729                 'n',
2730                 'n',
2731                 'n',
2732                 'q',
2733             ],
2734             prog => '../lib/perl5db/t/rt-121509-restart-after-chdir',
2735         }
2736     );
2737
2738     $wrapper->output_like(
2739         qr/
2740 In\ _finale\ No\ 1
2741     .*?
2742 In\ _finale\ No\ 2
2743     .*?
2744 In\ _finale\ No\ 3
2745         /msx,
2746         "Test that the debugger chdirs to the initial directory after a restart.",
2747     );
2748 }
2749 # Test the perldoc command
2750 # We don't actually run the program, but we need to provide one to the wrapper.
2751 SKIP:
2752 {
2753     $^O eq "linux"
2754         or skip "man errors aren't especially portable", 1;
2755     -x '/usr/bin/man'
2756         or skip "man command seems to be missing", 1;
2757     local $ENV{LANG} = "C";
2758     local $ENV{LC_MESSAGES} = "C";
2759     local $ENV{LC_ALL} = "C";
2760     my $wrapper = DebugWrap->new(
2761         {
2762             cmds =>
2763             [
2764                 'perldoc perlrules',
2765                 'q',
2766             ],
2767             prog => '../lib/perl5db/t/fact',
2768         }
2769     );
2770
2771     $wrapper->output_like(
2772         qr/No manual entry for perlrules/,
2773         'perldoc command works fine',
2774     );
2775 }
2776
2777 END {
2778     1 while unlink ($rc_filename, $out_fn);
2779 }