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