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