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