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