This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix for RT #118169
[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(115);
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 x with AutoTrace=1.
838 {
839     my $wrapper = DebugWrap->new(
840         {
841             cmds =>
842             [
843                 'n',
844                 'o AutoTrace=1',
845                 # So it may fail.
846                 q/x "failure"/,
847                 q/x \$x/,
848                 'q',
849             ],
850             prog => '../lib/perl5db/t/with-subroutine',
851         }
852     );
853
854     $wrapper->contents_like(
855         # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
856         qr/^0\s+SCALAR\([^\)]+\)\n\s+-> 'hello world'\n/ms,
857         "x after AutoTrace=1 command is working."
858     );
859 }
860
861 # Tests for "T" (stack trace).
862 {
863     my $prog_fn = '../lib/perl5db/t/rt-104168';
864     my $wrapper = DebugWrap->new(
865         {
866             prog => $prog_fn,
867             cmds =>
868             [
869                 'c baz',
870                 'T',
871                 'q',
872             ],
873         }
874     );
875     my $re_text = join('',
876         map {
877         sprintf(
878             "%s = %s\\(\\) called from file " .
879             "'" . quotemeta($prog_fn) . "' line %s\\n",
880             (map { quotemeta($_) } @$_)
881             )
882         }
883         (
884             ['.', 'main::baz', 14,],
885             ['.', 'main::bar', 9,],
886             ['.', 'main::foo', 6],
887         )
888     );
889     $wrapper->contents_like(
890         # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
891         qr/^$re_text/ms,
892         "T command test."
893     );
894 }
895
896 # Test for s.
897 {
898     my $wrapper = DebugWrap->new(
899         {
900             cmds =>
901             [
902                 'b 9',
903                 'c',
904                 's',
905                 q/print "X={$x};dummy={$dummy}\n";/,
906                 'q',
907             ],
908             prog => '../lib/perl5db/t/disable-breakpoints-1'
909         }
910     );
911
912     $wrapper->output_like(qr/
913         X=\{SecondVal\};dummy=\{1\}
914         /msx,
915         'test for s - single step',
916     );
917 }
918
919 {
920     my $wrapper = DebugWrap->new(
921         {
922             cmds =>
923             [
924                 'n',
925                 'n',
926                 'b . $exp > 200',
927                 'c',
928                 q/print "Exp={$exp}\n";/,
929                 'q',
930             ],
931             prog => '../lib/perl5db/t/break-on-dot'
932         }
933     );
934
935     $wrapper->output_like(qr/
936         Exp=\{256\}
937         /msx,
938         "'b .' is working correctly.");
939 }
940
941 {
942     my $prog_fn = '../lib/perl5db/t/rt-104168';
943     my $wrapper = DebugWrap->new(
944         {
945             cmds =>
946             [
947                 's',
948                 'q',
949             ],
950             prog => $prog_fn,
951         }
952     );
953
954     $wrapper->contents_like(
955         qr/
956         ^main::foo\([^\)\n]*\brt-104168:9\):[\ \t]*\n
957         ^9:\s*bar\(\);
958         /msx,
959         'Test for the s command.',
960     );
961 }
962
963 {
964     my $wrapper = DebugWrap->new(
965         {
966             cmds =>
967             [
968                 's uncalled_subroutine()',
969                 'c',
970                 'q',
971             ],
972
973             prog => '../lib/perl5db/t/uncalled-subroutine'}
974     );
975
976     $wrapper->output_like(
977         qr/<1,2,3,4,5>\n/,
978         'uncalled_subroutine was called after s EXPR()',
979         );
980 }
981
982 {
983     my $wrapper = DebugWrap->new(
984         {
985             cmds =>
986             [
987                 'n uncalled_subroutine()',
988                 'c',
989                 'q',
990             ],
991             prog => '../lib/perl5db/t/uncalled-subroutine',
992         }
993     );
994
995     $wrapper->output_like(
996         qr/<1,2,3,4,5>\n/,
997         'uncalled_subroutine was called after n EXPR()',
998         );
999 }
1000
1001 {
1002     my $wrapper = DebugWrap->new(
1003         {
1004             cmds =>
1005             [
1006                 'b fact',
1007                 'c',
1008                 'c',
1009                 'c',
1010                 'n',
1011                 'print "<$n>"',
1012                 'q',
1013             ],
1014             prog => '../lib/perl5db/t/fact',
1015         }
1016     );
1017
1018     $wrapper->output_like(
1019         qr/<3>/,
1020         'b subroutine works fine',
1021     );
1022 }
1023
1024 # Test for 'M' (module list).
1025 {
1026     my $wrapper = DebugWrap->new(
1027         {
1028             cmds =>
1029             [
1030                 'M',
1031                 'q',
1032             ],
1033             prog => '../lib/perl5db/t/load-modules'
1034         }
1035     );
1036
1037     $wrapper->contents_like(
1038         qr[Scalar/Util\.pm],
1039         'M (module list) works fine',
1040     );
1041 }
1042
1043 {
1044     my $wrapper = DebugWrap->new(
1045         {
1046             cmds =>
1047             [
1048                 'b 14',
1049                 'c',
1050                 '$flag = 1;',
1051                 'r',
1052                 'print "Var=$var\n";',
1053                 'q',
1054             ],
1055             prog => '../lib/perl5db/t/test-r-statement',
1056         }
1057     );
1058
1059     $wrapper->output_like(
1060         qr/
1061             ^Foo$
1062                 .*?
1063             ^Bar$
1064                 .*?
1065             ^Var=Test$
1066         /msx,
1067         'r statement is working properly.',
1068     );
1069 }
1070
1071 {
1072     my $wrapper = DebugWrap->new(
1073         {
1074             cmds =>
1075             [
1076                 'l',
1077                 'q',
1078             ],
1079             prog => '../lib/perl5db/t/test-l-statement-1',
1080         }
1081     );
1082
1083     $wrapper->contents_like(
1084         qr/
1085             ^1==>\s+\$x\ =\ 1;\n
1086             2:\s+print\ "1\\n";\n
1087             3\s*\n
1088             4:\s+\$x\ =\ 2;\n
1089             5:\s+print\ "2\\n";\n
1090         /msx,
1091         'l statement is working properly (test No. 1).',
1092     );
1093 }
1094
1095 {
1096     my $wrapper = DebugWrap->new(
1097         {
1098             cmds =>
1099             [
1100                 'l',
1101                 q/# After l 1/,
1102                 'l',
1103                 q/# After l 2/,
1104                 '-',
1105                 q/# After -/,
1106                 'q',
1107             ],
1108             prog => '../lib/perl5db/t/test-l-statement-1',
1109         }
1110     );
1111
1112     my $first_l_out = qr/
1113         1==>\s+\$x\ =\ 1;\n
1114         2:\s+print\ "1\\n";\n
1115         3\s*\n
1116         4:\s+\$x\ =\ 2;\n
1117         5:\s+print\ "2\\n";\n
1118         6\s*\n
1119         7:\s+\$x\ =\ 3;\n
1120         8:\s+print\ "3\\n";\n
1121         9\s*\n
1122         10:\s+\$x\ =\ 4;\n
1123     /msx;
1124
1125     my $second_l_out = qr/
1126         11:\s+print\ "4\\n";\n
1127         12\s*\n
1128         13:\s+\$x\ =\ 5;\n
1129         14:\s+print\ "5\\n";\n
1130         15\s*\n
1131         16:\s+\$x\ =\ 6;\n
1132         17:\s+print\ "6\\n";\n
1133         18\s*\n
1134         19:\s+\$x\ =\ 7;\n
1135         20:\s+print\ "7\\n";\n
1136     /msx;
1137     $wrapper->contents_like(
1138         qr/
1139             ^$first_l_out
1140             [^\n]*?DB<\d+>\ \#\ After\ l\ 1\n
1141             [\ \t]*\n
1142             [^\n]*?DB<\d+>\ l\s*\n
1143             $second_l_out
1144             [^\n]*?DB<\d+>\ \#\ After\ l\ 2\n
1145             [\ \t]*\n
1146             [^\n]*?DB<\d+>\ -\s*\n
1147             $first_l_out
1148             [^\n]*?DB<\d+>\ \#\ After\ -\n
1149         /msx,
1150         'l followed by l and then followed by -',
1151     );
1152 }
1153
1154 {
1155     my $wrapper = DebugWrap->new(
1156         {
1157             cmds =>
1158             [
1159                 'l fact',
1160                 'q',
1161             ],
1162             prog => '../lib/perl5db/t/test-l-statement-2',
1163         }
1164     );
1165
1166     my $first_l_out = qr/
1167         6\s+sub\ fact\ \{\n
1168         7:\s+my\ \$n\ =\ shift;\n
1169         8:\s+if\ \(\$n\ >\ 1\)\ \{\n
1170         9:\s+return\ \$n\ \*\ fact\(\$n\ -\ 1\);
1171     /msx;
1172
1173     $wrapper->contents_like(
1174         qr/
1175             DB<1>\s+l\ fact\n
1176             $first_l_out
1177         /msx,
1178         'l subroutine_name',
1179     );
1180 }
1181
1182 {
1183     my $wrapper = DebugWrap->new(
1184         {
1185             cmds =>
1186             [
1187                 'b fact',
1188                 'c',
1189                 # Repeat several times to avoid @typeahead problems.
1190                 '.',
1191                 '.',
1192                 '.',
1193                 '.',
1194                 'q',
1195             ],
1196             prog => '../lib/perl5db/t/test-l-statement-2',
1197         }
1198     );
1199
1200     my $line_out = qr /
1201         ^main::fact\([^\n]*?:7\):\n
1202         ^7:\s+my\ \$n\ =\ shift;\n
1203     /msx;
1204
1205     $wrapper->contents_like(
1206         qr/
1207             $line_out
1208             $line_out
1209         /msx,
1210         'Test the "." command',
1211     );
1212 }
1213
1214 # Testing that the f command works.
1215 {
1216     my $wrapper = DebugWrap->new(
1217         {
1218             cmds =>
1219             [
1220                 'f ../lib/perl5db/t/MyModule.pm',
1221                 'b 12',
1222                 'c',
1223                 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
1224                 'c',
1225                 'q',
1226             ],
1227             include_t => 1,
1228             prog => '../lib/perl5db/t/filename-line-breakpoint'
1229         }
1230     );
1231
1232     $wrapper->output_like(qr/
1233         ^Var=Bar$
1234             .*
1235         ^In\ MyModule\.$
1236             .*
1237         ^In\ Main\ File\.$
1238             .*
1239         /msx,
1240         "f command is working.",
1241     );
1242 }
1243
1244 # We broke the /pattern/ command because apparently the CORE::eval-s inside
1245 # lib/perl5db.pl cannot handle lexical variable properly. So we now fix this
1246 # bug.
1247 #
1248 # TODO :
1249 #
1250 # 1. Go over the rest of the "eval"s in lib/perl5db.t and see if they cause
1251 # problems.
1252 {
1253     my $wrapper = DebugWrap->new(
1254         {
1255             cmds =>
1256             [
1257                 '/for/',
1258                 'q',
1259             ],
1260             prog => '../lib/perl5db/t/eval-line-bug',
1261         }
1262     );
1263
1264     $wrapper->contents_like(
1265         qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1266         "/pat/ command is working and found a match.",
1267     );
1268 }
1269
1270 {
1271     my $wrapper = DebugWrap->new(
1272         {
1273             cmds =>
1274             [
1275                 'b 22',
1276                 'c',
1277                 '?for?',
1278                 'q',
1279             ],
1280             prog => '../lib/perl5db/t/eval-line-bug',
1281         }
1282     );
1283
1284     $wrapper->contents_like(
1285         qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1286         "?pat? command is working and found a match.",
1287     );
1288 }
1289
1290 # Test the L command.
1291 {
1292     my $wrapper = DebugWrap->new(
1293         {
1294             cmds =>
1295             [
1296                 'b 6',
1297                 'b 13 ($q == 5)',
1298                 'L',
1299                 'q',
1300             ],
1301             prog => '../lib/perl5db/t/eval-line-bug',
1302         }
1303     );
1304
1305     $wrapper->contents_like(
1306         qr#
1307         ^\S*?eval-line-bug:\n
1308         \s*6:\s*my\ \$i\ =\ 5;\n
1309         \s*break\ if\ \(1\)\n
1310         \s*13:\s*\$i\ \+=\ \$q;\n
1311         \s*break\ if\ \(\(\$q\ ==\ 5\)\)\n
1312         #msx,
1313         "L command is listing breakpoints",
1314     );
1315 }
1316
1317 # Test the L command for watch expressions.
1318 {
1319     my $wrapper = DebugWrap->new(
1320         {
1321             cmds =>
1322             [
1323                 'w (5+6)',
1324                 'L',
1325                 'q',
1326             ],
1327             prog => '../lib/perl5db/t/eval-line-bug',
1328         }
1329     );
1330
1331     $wrapper->contents_like(
1332         qr#
1333         ^Watch-expressions:\n
1334         \s*\(5\+6\)\n
1335         #msx,
1336         "L command is listing watch expressions",
1337     );
1338 }
1339
1340 {
1341     my $wrapper = DebugWrap->new(
1342         {
1343             cmds =>
1344             [
1345                 'w (5+6)',
1346                 'w (11*23)',
1347                 'W (5+6)',
1348                 'L',
1349                 'q',
1350             ],
1351             prog => '../lib/perl5db/t/eval-line-bug',
1352         }
1353     );
1354
1355     $wrapper->contents_like(
1356         qr#
1357         ^Watch-expressions:\n
1358         \s*\(11\*23\)\n
1359         ^auto\(
1360         #msx,
1361         "L command is not listing deleted watch expressions",
1362     );
1363 }
1364
1365 # Test the L command.
1366 {
1367     my $wrapper = DebugWrap->new(
1368         {
1369             cmds =>
1370             [
1371                 'b 6',
1372                 'a 13 print $i',
1373                 'L',
1374                 'q',
1375             ],
1376             prog => '../lib/perl5db/t/eval-line-bug',
1377         }
1378     );
1379
1380     $wrapper->contents_like(
1381         qr#
1382         ^\S*?eval-line-bug:\n
1383         \s*6:\s*my\ \$i\ =\ 5;\n
1384         \s*break\ if\ \(1\)\n
1385         \s*13:\s*\$i\ \+=\ \$q;\n
1386         \s*action:\s+print\ \$i\n
1387         #msx,
1388         "L command is listing actions and breakpoints",
1389     );
1390 }
1391
1392 {
1393     my $wrapper = DebugWrap->new(
1394         {
1395             cmds =>
1396             [
1397                 'S',
1398                 'q',
1399             ],
1400             prog =>  '../lib/perl5db/t/rt-104168',
1401         }
1402     );
1403
1404     $wrapper->contents_like(
1405         qr#
1406         ^main::bar\n
1407         main::baz\n
1408         main::foo\n
1409         #msx,
1410         "S command - 1",
1411     );
1412 }
1413
1414 {
1415     my $wrapper = DebugWrap->new(
1416         {
1417             cmds =>
1418             [
1419                 'S ^main::ba',
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         auto\(
1431         #msx,
1432         "S command with regex",
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_unlike(
1449         qr#
1450         ^main::ba
1451         #msx,
1452         "S command with negative regex",
1453     );
1454
1455     $wrapper->contents_like(
1456         qr#
1457         ^main::foo\n
1458         #msx,
1459         "S command with negative regex - what it still matches",
1460     );
1461 }
1462
1463 # Test the 'a' command.
1464 {
1465     my $wrapper = DebugWrap->new(
1466         {
1467             cmds =>
1468             [
1469                 'a 13 print "\nVar<Q>=$q\n"',
1470                 'c',
1471                 'q',
1472             ],
1473             prog => '../lib/perl5db/t/eval-line-bug',
1474         }
1475     );
1476
1477     $wrapper->output_like(qr#
1478         \nVar<Q>=1\n
1479         \nVar<Q>=2\n
1480         \nVar<Q>=3\n
1481         #msx,
1482         "a command is working",
1483     );
1484 }
1485
1486 # Test the 'a' command with no line number.
1487 {
1488     my $wrapper = DebugWrap->new(
1489         {
1490             cmds =>
1491             [
1492                 'n',
1493                 q/a print "Hello " . (3 * 4) . "\n";/,
1494                 'c',
1495                 'q',
1496             ],
1497             prog => '../lib/perl5db/t/test-a-statement-1',
1498         }
1499     );
1500
1501     $wrapper->output_like(qr#
1502         (?:^Hello\ 12\n.*?){4}
1503         #msx,
1504         "a command with no line number is working",
1505     );
1506 }
1507
1508 # Test the 'A' command
1509 {
1510     my $wrapper = DebugWrap->new(
1511         {
1512             cmds =>
1513             [
1514                 'a 13 print "\nVar<Q>=$q\n"',
1515                 'A 13',
1516                 'c',
1517                 'q',
1518             ],
1519             prog => '../lib/perl5db/t/eval-line-bug',
1520         }
1521     );
1522
1523     $wrapper->output_like(
1524         qr#\A\z#msx, # The empty string.
1525         "A command (for removing actions) is working",
1526     );
1527 }
1528
1529 # Test the 'A *' command
1530 {
1531     my $wrapper = DebugWrap->new(
1532         {
1533             cmds =>
1534             [
1535                 'a 6 print "\nFail!\n"',
1536                 'a 13 print "\nVar<Q>=$q\n"',
1537                 'A *',
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 all actions) is working",
1548     );
1549 }
1550
1551 {
1552     my $wrapper = DebugWrap->new(
1553         {
1554             cmds =>
1555             [
1556                 'n',
1557                 'w $foo',
1558                 'c',
1559                 'print "\nIDX=<$idx>\n"',
1560                 'q',
1561             ],
1562             prog => '../lib/perl5db/t/test-w-statement-1',
1563         }
1564     );
1565
1566
1567     $wrapper->contents_like(qr#
1568         \$foo\ changed:\n
1569         \s+old\ value:\s+'1'\n
1570         \s+new\ value:\s+'2'\n
1571         #msx,
1572         'w command - watchpoint changed',
1573     );
1574     $wrapper->output_like(qr#
1575         \nIDX=<20>\n
1576         #msx,
1577         "w command - correct output from IDX",
1578     );
1579 }
1580
1581 {
1582     my $wrapper = DebugWrap->new(
1583         {
1584             cmds =>
1585             [
1586                 'n',
1587                 'w $foo',
1588                 'W $foo',
1589                 'c',
1590                 'print "\nIDX=<$idx>\n"',
1591                 'q',
1592             ],
1593             prog => '../lib/perl5db/t/test-w-statement-1',
1594         }
1595     );
1596
1597     $wrapper->contents_unlike(qr#
1598         \$foo\ changed:
1599         #msx,
1600         'W command - watchpoint was deleted',
1601     );
1602
1603     $wrapper->output_like(qr#
1604         \nIDX=<>\n
1605         #msx,
1606         "W command - stopped at end.",
1607     );
1608 }
1609
1610 # Test the W * command.
1611 {
1612     my $wrapper = DebugWrap->new(
1613         {
1614             cmds =>
1615             [
1616                 'n',
1617                 'w $foo',
1618                 'w ($foo*$foo)',
1619                 'W *',
1620                 'c',
1621                 'print "\nIDX=<$idx>\n"',
1622                 'q',
1623             ],
1624             prog => '../lib/perl5db/t/test-w-statement-1',
1625         }
1626     );
1627
1628     $wrapper->contents_unlike(qr#
1629         \$foo\ changed:
1630         #msx,
1631         '"W *" command - watchpoint was deleted',
1632     );
1633
1634     $wrapper->output_like(qr#
1635         \nIDX=<>\n
1636         #msx,
1637         '"W *" command - stopped at end.',
1638     );
1639 }
1640
1641 # Test the 'o' command (without further arguments).
1642 {
1643     my $wrapper = DebugWrap->new(
1644         {
1645             cmds =>
1646             [
1647                 'o',
1648                 'q',
1649             ],
1650             prog => '../lib/perl5db/t/test-w-statement-1',
1651         }
1652     );
1653
1654     $wrapper->contents_like(qr#
1655         ^\s*warnLevel\ =\ '1'\n
1656         #msx,
1657         q#"o" command (without arguments) displays warnLevel#,
1658     );
1659
1660     $wrapper->contents_like(qr#
1661         ^\s*signalLevel\ =\ '1'\n
1662         #msx,
1663         q#"o" command (without arguments) displays signalLevel#,
1664     );
1665
1666     $wrapper->contents_like(qr#
1667         ^\s*dieLevel\ =\ '1'\n
1668         #msx,
1669         q#"o" command (without arguments) displays dieLevel#,
1670     );
1671
1672     $wrapper->contents_like(qr#
1673         ^\s*hashDepth\ =\ 'N/A'\n
1674         #msx,
1675         q#"o" command (without arguments) displays hashDepth#,
1676     );
1677 }
1678
1679 # Test the 'o' query command.
1680 {
1681     my $wrapper = DebugWrap->new(
1682         {
1683             cmds =>
1684             [
1685                 'o hashDepth? signalLevel?',
1686                 'q',
1687             ],
1688             prog => '../lib/perl5db/t/test-w-statement-1',
1689         }
1690     );
1691
1692     $wrapper->contents_unlike(qr#warnLevel#,
1693         q#"o" query command does not display warnLevel#,
1694     );
1695
1696     $wrapper->contents_like(qr#
1697         ^\s*signalLevel\ =\ '1'\n
1698         #msx,
1699         q#"o" query command displays signalLevel#,
1700     );
1701
1702     $wrapper->contents_unlike(qr#dieLevel#,
1703         q#"o" query command does not display dieLevel#,
1704     );
1705
1706     $wrapper->contents_like(qr#
1707         ^\s*hashDepth\ =\ 'N/A'\n
1708         #msx,
1709         q#"o" query command displays hashDepth#,
1710     );
1711 }
1712
1713 # Test the 'o' set command.
1714 {
1715     my $wrapper = DebugWrap->new(
1716         {
1717             cmds =>
1718             [
1719                 'o signalLevel=0',
1720                 'o',
1721                 'q',
1722             ],
1723             prog => '../lib/perl5db/t/test-w-statement-1',
1724         }
1725     );
1726
1727     $wrapper->contents_like(qr/
1728         ^\s*(signalLevel\ =\ '0'\n)
1729         .*?
1730         ^\s*\1
1731         /msx,
1732         q#o set command works#,
1733     );
1734
1735     $wrapper->contents_like(qr#
1736         ^\s*hashDepth\ =\ 'N/A'\n
1737         #msx,
1738         q#o set command - hashDepth#,
1739     );
1740 }
1741
1742 # Test the '<' and "< ?" commands.
1743 {
1744     my $wrapper = DebugWrap->new(
1745         {
1746             cmds =>
1747             [
1748                 q/< print "\nX=<$x>\n"/,
1749                 q/b 7/,
1750                 q/< ?/,
1751                 'c',
1752                 'q',
1753             ],
1754             prog => '../lib/perl5db/t/disable-breakpoints-1',
1755         }
1756     );
1757
1758     $wrapper->contents_like(qr/
1759         ^pre-perl\ commands:\n
1760         \s*<\ --\ print\ "\\nX=<\$x>\\n"\n
1761         /msx,
1762         q#Test < and < ? commands - contents.#,
1763     );
1764
1765     $wrapper->output_like(qr#
1766         ^X=<FirstVal>\n
1767         #msx,
1768         q#Test < and < ? commands - output.#,
1769     );
1770 }
1771
1772 # Test the '< *' command.
1773 {
1774     my $wrapper = DebugWrap->new(
1775         {
1776             cmds =>
1777             [
1778                 q/< print "\nX=<$x>\n"/,
1779                 q/b 7/,
1780                 q/< */,
1781                 'c',
1782                 'q',
1783             ],
1784             prog => '../lib/perl5db/t/disable-breakpoints-1',
1785         }
1786     );
1787
1788     $wrapper->output_unlike(qr/FirstVal/,
1789         q#Test the '< *' command.#,
1790     );
1791 }
1792
1793 # Test the '>' and "> ?" commands.
1794 {
1795     my $wrapper = DebugWrap->new(
1796         {
1797             cmds =>
1798             [
1799                 q/$::foo = 500;/,
1800                 q/> print "\nFOO=<$::foo>\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->contents_like(qr/
1811         ^post-perl\ commands:\n
1812         \s*>\ --\ print\ "\\nFOO=<\$::foo>\\n"\n
1813         /msx,
1814         q#Test > and > ? commands - contents.#,
1815     );
1816
1817     $wrapper->output_like(qr#
1818         ^FOO=<500>\n
1819         #msx,
1820         q#Test > and > ? commands - output.#,
1821     );
1822 }
1823
1824 # Test the '> *' command.
1825 {
1826     my $wrapper = DebugWrap->new(
1827         {
1828             cmds =>
1829             [
1830                 q/> print "\nFOO=<$::foo>\n"/,
1831                 q/b 7/,
1832                 q/> */,
1833                 'c',
1834                 'q',
1835             ],
1836             prog => '../lib/perl5db/t/disable-breakpoints-1',
1837         }
1838     );
1839
1840     $wrapper->output_unlike(qr/FOO=/,
1841         q#Test the '> *' command.#,
1842     );
1843 }
1844
1845 # Test the < and > commands together
1846 {
1847     my $wrapper = DebugWrap->new(
1848         {
1849             cmds =>
1850             [
1851                 q/$::lorem = 0;/,
1852                 q/< $::lorem += 10;/,
1853                 q/> print "\nLOREM=<$::lorem>\n"/,
1854                 q/b 7/,
1855                 q/b 5/,
1856                 'c',
1857                 'c',
1858                 'q',
1859             ],
1860             prog => '../lib/perl5db/t/disable-breakpoints-1',
1861         }
1862     );
1863
1864     $wrapper->output_like(qr#
1865         ^LOREM=<10>\n
1866         #msx,
1867         q#Test < and > commands. #,
1868     );
1869 }
1870
1871 # Test the { ? and { [command] commands.
1872 {
1873     my $wrapper = DebugWrap->new(
1874         {
1875             cmds =>
1876             [
1877                 '{ ?',
1878                 '{ l',
1879                 '{ ?',
1880                 q/b 5/,
1881                 q/c/,
1882                 q/q/,
1883             ],
1884             prog => '../lib/perl5db/t/disable-breakpoints-1',
1885         }
1886     );
1887
1888     $wrapper->contents_like(qr#
1889         ^No\ pre-debugger\ actions\.\n
1890         .*?
1891         ^pre-debugger\ commands:\n
1892         \s+\{\ --\ l\n
1893         .*?
1894         ^5==>b\s+\$x\ =\ "FirstVal";\n
1895         6\s*\n
1896         7:\s+\$dummy\+\+;\n
1897         8\s*\n
1898         9:\s+\$x\ =\ "SecondVal";\n
1899
1900         #msx,
1901         'Test the pre-prompt debugger commands',
1902     );
1903 }
1904
1905 # Test the { * command.
1906 {
1907     my $wrapper = DebugWrap->new(
1908         {
1909             cmds =>
1910             [
1911                 '{ q',
1912                 '{ *',
1913                 q/b 5/,
1914                 q/c/,
1915                 q/print (("One" x 5), "\n");/,
1916                 q/q/,
1917             ],
1918             prog => '../lib/perl5db/t/disable-breakpoints-1',
1919         }
1920     );
1921
1922     $wrapper->contents_like(qr#
1923         ^All\ \{\ actions\ cleared\.\n
1924         #msx,
1925         'Test the { * command',
1926     );
1927
1928     $wrapper->output_like(qr/OneOneOneOneOne/,
1929         '{ * test - output is OK.',
1930     );
1931 }
1932
1933 # Test the ! command.
1934 {
1935     my $wrapper = DebugWrap->new(
1936         {
1937             cmds =>
1938             [
1939                 'l 3-5',
1940                 '!',
1941                 'q',
1942             ],
1943             prog => '../lib/perl5db/t/disable-breakpoints-1',
1944         }
1945     );
1946
1947     $wrapper->contents_like(qr#
1948         (^3:\s+my\ \$dummy\ =\ 0;\n
1949         4\s*\n
1950         5:\s+\$x\ =\ "FirstVal";)\n
1951         .*?
1952         ^l\ 3-5\n
1953         \1
1954         #msx,
1955         'Test the ! command (along with l 3-5)',
1956     );
1957 }
1958
1959 # Test the ! -number command.
1960 {
1961     my $wrapper = DebugWrap->new(
1962         {
1963             cmds =>
1964             [
1965                 'l 3-5',
1966                 'l 2',
1967                 '! -1',
1968                 'q',
1969             ],
1970             prog => '../lib/perl5db/t/disable-breakpoints-1',
1971         }
1972     );
1973
1974     $wrapper->contents_like(qr#
1975         (^3:\s+my\ \$dummy\ =\ 0;\n
1976         4\s*\n
1977         5:\s+\$x\ =\ "FirstVal";)\n
1978         .*?
1979         ^2==\>\s+my\ \$x\ =\ "One";\n
1980         .*?
1981         ^l\ 3-5\n
1982         \1
1983         #msx,
1984         'Test the ! -n command (along with l)',
1985     );
1986 }
1987
1988 # Test the 'source' command.
1989 {
1990     my $wrapper = DebugWrap->new(
1991         {
1992             cmds =>
1993             [
1994                 'source ../lib/perl5db/t/source-cmd-test.perldb',
1995                 # If we have a 'q' here, then the typeahead will override the
1996                 # input, and so it won't be reached - solution:
1997                 # put a q inside the .perldb commands.
1998                 # ( This may be a bug or a misfeature. )
1999             ],
2000             prog => '../lib/perl5db/t/disable-breakpoints-1',
2001         }
2002     );
2003
2004     $wrapper->contents_like(qr#
2005         ^3:\s+my\ \$dummy\ =\ 0;\n
2006         4\s*\n
2007         5:\s+\$x\ =\ "FirstVal";\n
2008         6\s*\n
2009         7:\s+\$dummy\+\+;\n
2010         8\s*\n
2011         9:\s+\$x\ =\ "SecondVal";\n
2012         10\s*\n
2013         #msx,
2014         'Test the source command (along with l)',
2015     );
2016 }
2017
2018 # Test the 'source' command being traversed from withing typeahead.
2019 {
2020     my $wrapper = DebugWrap->new(
2021         {
2022             cmds =>
2023             [
2024                 'source ../lib/perl5db/t/source-cmd-test-no-q.perldb',
2025                 'q',
2026             ],
2027             prog => '../lib/perl5db/t/disable-breakpoints-1',
2028         }
2029     );
2030
2031     $wrapper->contents_like(qr#
2032         ^3:\s+my\ \$dummy\ =\ 0;\n
2033         4\s*\n
2034         5:\s+\$x\ =\ "FirstVal";\n
2035         6\s*\n
2036         7:\s+\$dummy\+\+;\n
2037         8\s*\n
2038         9:\s+\$x\ =\ "SecondVal";\n
2039         10\s*\n
2040         #msx,
2041         'Test the source command inside a typeahead',
2042     );
2043 }
2044
2045 # Test the 'H -number' command.
2046 {
2047     my $wrapper = DebugWrap->new(
2048         {
2049             cmds =>
2050             [
2051                 'l 1-10',
2052                 'l 5-10',
2053                 'x "Hello World"',
2054                 'l 1-5',
2055                 'b 3',
2056                 'x (20+4)',
2057                 'H -7',
2058                 'q',
2059             ],
2060             prog => '../lib/perl5db/t/disable-breakpoints-1',
2061         }
2062     );
2063
2064     $wrapper->contents_like(qr#
2065         ^\d+:\s+H\ -7\n
2066         \d+:\s+x\ \(20\+4\)\n
2067         \d+:\s+b\ 3\n
2068         \d+:\s+l\ 1-5\n
2069         \d+:\s+x\ "Hello\ World"\n
2070         \d+:\s+l\ 5-10\n
2071         \d+:\s+l\ 1-10\n
2072         #msx,
2073         'Test the H -num command',
2074     );
2075 }
2076
2077 # Add a test for H (without arguments)
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',
2090                 'q',
2091             ],
2092             prog => '../lib/perl5db/t/disable-breakpoints-1',
2093         }
2094     );
2095
2096     $wrapper->contents_like(qr#
2097         ^\d+:\s+x\ \(20\+4\)\n
2098         \d+:\s+b\ 3\n
2099         \d+:\s+l\ 1-5\n
2100         \d+:\s+x\ "Hello\ World"\n
2101         \d+:\s+l\ 5-10\n
2102         \d+:\s+l\ 1-10\n
2103         #msx,
2104         'Test the H command (without a number.)',
2105     );
2106 }
2107
2108 {
2109     my $wrapper = DebugWrap->new(
2110         {
2111             cmds =>
2112             [
2113                 '= quit q',
2114                 '= foobar l',
2115                 'foobar',
2116                 'quit',
2117             ],
2118             prog => '../lib/perl5db/t/test-l-statement-1',
2119         }
2120     );
2121
2122     $wrapper->contents_like(
2123         qr/
2124             ^1==>\s+\$x\ =\ 1;\n
2125             2:\s+print\ "1\\n";\n
2126             3\s*\n
2127             4:\s+\$x\ =\ 2;\n
2128             5:\s+print\ "2\\n";\n
2129         /msx,
2130         'Test the = (command alias) command.',
2131     );
2132 }
2133
2134 # Test the m statement.
2135 {
2136     my $wrapper = DebugWrap->new(
2137         {
2138             cmds =>
2139             [
2140                 'm main',
2141                 'q',
2142             ],
2143             prog => '../lib/perl5db/t/disable-breakpoints-1',
2144         }
2145     );
2146
2147     $wrapper->contents_like(qr#
2148         ^via\ UNIVERSAL:\ DOES$
2149         #msx,
2150         "Test m for main - 1",
2151     );
2152
2153     $wrapper->contents_like(qr#
2154         ^via\ UNIVERSAL:\ can$
2155         #msx,
2156         "Test m for main - 2",
2157     );
2158 }
2159
2160 # Test the m statement.
2161 {
2162     my $wrapper = DebugWrap->new(
2163         {
2164             cmds =>
2165             [
2166                 'b 41',
2167                 'c',
2168                 'm $obj',
2169                 'q',
2170             ],
2171             prog => '../lib/perl5db/t/test-m-statement-1',
2172         }
2173     );
2174
2175     $wrapper->contents_like(qr#^greet$#ms,
2176         "Test m for obj - 1",
2177     );
2178
2179     $wrapper->contents_like(qr#^via UNIVERSAL: can$#ms,
2180         "Test m for obj - 1",
2181     );
2182 }
2183
2184 # Test the M command.
2185 {
2186     my $wrapper = DebugWrap->new(
2187         {
2188             cmds =>
2189             [
2190                 'M',
2191                 'q',
2192             ],
2193             prog => '../lib/perl5db/t/test-m-statement-1',
2194         }
2195     );
2196
2197     $wrapper->contents_like(qr#
2198         ^'strict\.pm'\ =>\ '\d+\.\d+\ from
2199         #msx,
2200         "Test M",
2201     );
2202
2203 }
2204
2205 # Test the recallCommand option.
2206 {
2207     my $wrapper = DebugWrap->new(
2208         {
2209             cmds =>
2210             [
2211                 'o recallCommand=%',
2212                 'l 3-5',
2213                 'l 2',
2214                 '% -1',
2215                 'q',
2216             ],
2217             prog => '../lib/perl5db/t/disable-breakpoints-1',
2218         }
2219     );
2220
2221     $wrapper->contents_like(qr#
2222         (^3:\s+my\ \$dummy\ =\ 0;\n
2223         4\s*\n
2224         5:\s+\$x\ =\ "FirstVal";)\n
2225         .*?
2226         ^2==\>\s+my\ \$x\ =\ "One";\n
2227         .*?
2228         ^l\ 3-5\n
2229         \1
2230         #msx,
2231         'Test the o recallCommand option',
2232     );
2233 }
2234
2235 # Test the dieLevel option
2236 {
2237     my $wrapper = DebugWrap->new(
2238         {
2239             cmds =>
2240             [
2241                 q/o dieLevel='1'/,
2242                 q/c/,
2243                 'q',
2244             ],
2245             prog => '../lib/perl5db/t/test-dieLevel-option-1',
2246         }
2247     );
2248
2249     $wrapper->output_like(qr#
2250         ^This\ program\ dies\.\ at\ \S+\ line\ 18\.\n
2251         .*?
2252         ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
2253         \s+main::bar\(\)\ called\ at\ \S+\ line\ 7\n
2254         \s+main::foo\(\)\ called\ at\ \S+\ line\ 21\n
2255         #msx,
2256         'Test the o dieLevel option',
2257     );
2258 }
2259
2260 # Test the warnLevel option
2261 {
2262     my $wrapper = DebugWrap->new(
2263         {
2264             cmds =>
2265             [
2266                 q/o warnLevel='1'/,
2267                 q/c/,
2268                 'q',
2269             ],
2270             prog => '../lib/perl5db/t/test-warnLevel-option-1',
2271         }
2272     );
2273
2274     $wrapper->contents_like(qr#
2275         ^This\ is\ not\ a\ warning\.\ at\ \S+\ line\ 18\.\n
2276         .*?
2277         ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
2278         \s+main::bar\(\)\ called\ at\ \S+\ line\ 25\n
2279         \s+main::myfunc\(\)\ called\ at\ \S+\ line\ 28\n
2280         #msx,
2281         'Test the o warnLevel option',
2282     );
2283 }
2284
2285 # Test the t command
2286 {
2287     my $wrapper = DebugWrap->new(
2288         {
2289             cmds =>
2290             [
2291                 't',
2292                 'c',
2293                 'q',
2294             ],
2295             prog => '../lib/perl5db/t/disable-breakpoints-1',
2296         }
2297     );
2298
2299     $wrapper->contents_like(qr/
2300         ^main::\([^:]+:15\):\n
2301         15:\s+\$dummy\+\+;\n
2302         main::\([^:]+:17\):\n
2303         17:\s+\$x\ =\ "FourthVal";\n
2304         /msx,
2305         'Test the t command (without a number.)',
2306     );
2307 }
2308
2309 # Test the o AutoTrace command
2310 {
2311     my $wrapper = DebugWrap->new(
2312         {
2313             cmds =>
2314             [
2315                 'o AutoTrace',
2316                 'c',
2317                 'q',
2318             ],
2319             prog => '../lib/perl5db/t/disable-breakpoints-1',
2320         }
2321     );
2322
2323     $wrapper->contents_like(qr/
2324         ^main::\([^:]+:15\):\n
2325         15:\s+\$dummy\+\+;\n
2326         main::\([^:]+:17\):\n
2327         17:\s+\$x\ =\ "FourthVal";\n
2328         /msx,
2329         'Test the o AutoTrace command',
2330     );
2331 }
2332
2333 # Test the t command with function calls
2334 {
2335     my $wrapper = DebugWrap->new(
2336         {
2337             cmds =>
2338             [
2339                 't',
2340                 'b 18',
2341                 'c',
2342                 'x ["foo"]',
2343                 'x ["bar"]',
2344                 'q',
2345             ],
2346             prog => '../lib/perl5db/t/test-warnLevel-option-1',
2347         }
2348     );
2349
2350     $wrapper->contents_like(qr/
2351         ^main::\([^:]+:28\):\n
2352         28:\s+myfunc\(\);\n
2353         main::myfunc\([^:]+:25\):\n
2354         25:\s+bar\(\);\n
2355         /msx,
2356         'Test the t command with function calls.',
2357     );
2358 }
2359
2360 # Test the o AutoTrace command with function calls
2361 {
2362     my $wrapper = DebugWrap->new(
2363         {
2364             cmds =>
2365             [
2366                 'o AutoTrace',
2367                 'b 18',
2368                 'c',
2369                 'x ["foo"]',
2370                 'x ["bar"]',
2371                 'q',
2372             ],
2373             prog => '../lib/perl5db/t/test-warnLevel-option-1',
2374         }
2375     );
2376
2377     $wrapper->contents_like(qr/
2378         ^main::\([^:]+:28\):\n
2379         28:\s+myfunc\(\);\n
2380         main::myfunc\([^:]+:25\):\n
2381         25:\s+bar\(\);\n
2382         /msx,
2383         'Test the t command with function calls.',
2384     );
2385 }
2386
2387 # Test the final message.
2388 {
2389     my $wrapper = DebugWrap->new(
2390         {
2391             cmds =>
2392             [
2393                 'c',
2394                 'q',
2395             ],
2396             prog => '../lib/perl5db/t/test-warnLevel-option-1',
2397         }
2398     );
2399
2400     $wrapper->contents_like(qr/
2401         ^Debugged\ program\ terminated\.
2402         /msx,
2403         'Test the final "Debugged program terminated" message.',
2404     );
2405 }
2406
2407 # Test the o inhibit_exit=0 command
2408 {
2409     my $wrapper = DebugWrap->new(
2410         {
2411             cmds =>
2412             [
2413                 'o inhibit_exit=0',
2414                 'n',
2415                 'n',
2416                 'n',
2417                 'n',
2418                 'q',
2419             ],
2420             prog => '../lib/perl5db/t/test-warnLevel-option-1',
2421         }
2422     );
2423
2424     $wrapper->contents_unlike(qr/
2425         ^Debugged\ program\ terminated\.
2426         /msx,
2427         'Test the o inhibit_exit=0 command.',
2428     );
2429 }
2430
2431 # Test the o PrintRet=1 option
2432 {
2433     my $wrapper = DebugWrap->new(
2434         {
2435             cmds =>
2436             [
2437                 'o PrintRet=1',
2438                 'b 29',
2439                 'c',
2440                 q/$x = 's';/,
2441                 'b 10',
2442                 'c',
2443                 'r',
2444                 'q',
2445             ],
2446             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2447         }
2448     );
2449
2450     $wrapper->contents_like(
2451         qr/scalar context return from main::return_scalar: 20024/,
2452         "Test o PrintRet=1",
2453     );
2454 }
2455
2456 # Test the o PrintRet=0 option
2457 {
2458     my $wrapper = DebugWrap->new(
2459         {
2460             cmds =>
2461             [
2462                 'o PrintRet=0',
2463                 'b 29',
2464                 'c',
2465                 q/$x = 's';/,
2466                 'b 10',
2467                 'c',
2468                 'r',
2469                 'q',
2470             ],
2471             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2472         }
2473     );
2474
2475     $wrapper->contents_unlike(
2476         qr/scalar context/,
2477         "Test o PrintRet=0",
2478     );
2479 }
2480
2481 # Test the o PrintRet=1 option in list context
2482 {
2483     my $wrapper = DebugWrap->new(
2484         {
2485             cmds =>
2486             [
2487                 'o PrintRet=1',
2488                 'b 29',
2489                 'c',
2490                 q/$x = 'l';/,
2491                 'b 17',
2492                 'c',
2493                 'r',
2494                 'q',
2495             ],
2496             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2497         }
2498     );
2499
2500     $wrapper->contents_like(
2501         qr/list context return from main::return_list:\n0\s*'Foo'\n1\s*'Bar'\n2\s*'Baz'\n/,
2502         "Test o PrintRet=1 in list context",
2503     );
2504 }
2505
2506 # Test the o PrintRet=0 option in list context
2507 {
2508     my $wrapper = DebugWrap->new(
2509         {
2510             cmds =>
2511             [
2512                 'o PrintRet=0',
2513                 'b 29',
2514                 'c',
2515                 q/$x = 'l';/,
2516                 'b 17',
2517                 'c',
2518                 'r',
2519                 'q',
2520             ],
2521             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2522         }
2523     );
2524
2525     $wrapper->contents_unlike(
2526         qr/list context/,
2527         "Test o PrintRet=0 in list context",
2528     );
2529 }
2530
2531 # Test the o PrintRet=1 option in void context
2532 {
2533     my $wrapper = DebugWrap->new(
2534         {
2535             cmds =>
2536             [
2537                 'o PrintRet=1',
2538                 'b 29',
2539                 'c',
2540                 q/$x = 'v';/,
2541                 'b 24',
2542                 'c',
2543                 'r',
2544                 'q',
2545             ],
2546             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2547         }
2548     );
2549
2550     $wrapper->contents_like(
2551         qr/void context return from main::return_void/,
2552         "Test o PrintRet=1 in void context",
2553     );
2554 }
2555
2556 # Test the o PrintRet=1 option in void context
2557 {
2558     my $wrapper = DebugWrap->new(
2559         {
2560             cmds =>
2561             [
2562                 'o PrintRet=0',
2563                 'b 29',
2564                 'c',
2565                 q/$x = 'v';/,
2566                 'b 24',
2567                 'c',
2568                 'r',
2569                 'q',
2570             ],
2571             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2572         }
2573     );
2574
2575     $wrapper->contents_unlike(
2576         qr/void context/,
2577         "Test o PrintRet=0 in void context",
2578     );
2579 }
2580
2581 # Test the o frame option.
2582 {
2583     my $wrapper = DebugWrap->new(
2584         {
2585             cmds =>
2586             [
2587                 # This is to avoid getting the "Debugger program terminated"
2588                 # junk that interferes with the normal output.
2589                 'o inhibit_exit=0',
2590                 'b 10',
2591                 'c',
2592                 'o frame=255',
2593                 'c',
2594                 'q',
2595             ],
2596             prog => '../lib/perl5db/t/test-frame-option-1',
2597         }
2598     );
2599
2600     $wrapper->contents_like(
2601         qr/
2602             in\s*\.=main::my_other_func\(3,\ 1200\)\ from.*?
2603             out\s*\.=main::my_other_func\(3,\ 1200\)\ from
2604         /msx,
2605         "Test o PrintRet=0 in void context",
2606     );
2607 }
2608
2609 { # test t expr
2610     my $wrapper = DebugWrap->new(
2611         {
2612             cmds =>
2613             [
2614                 # This is to avoid getting the "Debugger program terminated"
2615                 # junk that interferes with the normal output.
2616                 'o inhibit_exit=0',
2617                 't fact(3)',
2618                 'q',
2619             ],
2620             prog => '../lib/perl5db/t/fact',
2621         }
2622     );
2623
2624     $wrapper->contents_like(
2625         qr/
2626             (?:^main::fact.*return\ \$n\ \*\ fact\(\$n\ -\ 1\);.*)
2627         /msx,
2628         "Test t expr",
2629     );
2630 }
2631
2632 # Test the w for lexical variables expression.
2633 {
2634     my $wrapper = DebugWrap->new(
2635         {
2636             cmds =>
2637             [
2638                 # This is to avoid getting the "Debugger program terminated"
2639                 # junk that interferes with the normal output.
2640                 'w $exp',
2641                 'n',
2642                 'n',
2643                 'n',
2644                 'n',
2645                 'q',
2646             ],
2647             prog => '../lib/perl5db/t/break-on-dot',
2648         }
2649     );
2650
2651     $wrapper->contents_like(
2652         qr/
2653 \s+old\ value:\s+'1'\n
2654 \s+new\ value:\s+'2'\n
2655         /msx,
2656         "Test w for lexical values.",
2657     );
2658 }
2659
2660 # Test the perldoc command
2661 # We don't actually run the program, but we need to provide one to the wrapper.
2662 SKIP:
2663 {
2664     $^O eq "linux"
2665         or skip "man errors aren't especially portable", 1;
2666     local $ENV{LANG} = "C";
2667     local $ENV{LC_MESSAGE} = "C";
2668     local $ENV{LC_ALL} = "C";
2669     my $wrapper = DebugWrap->new(
2670         {
2671             cmds =>
2672             [
2673                 'perldoc perlrules',
2674                 'q',
2675             ],
2676             prog => '../lib/perl5db/t/fact',
2677         }
2678     );
2679
2680     $wrapper->output_like(
2681         qr/No manual entry for perlrules/,
2682         'perldoc command works fine',
2683     );
2684 }
2685
2686 END {
2687     1 while unlink ($rc_filename, $out_fn);
2688 }