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