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