perl -d: test for 'T'.
[perl.git] / lib / perl5db.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7 }
8
9 use strict;
10 use warnings;
11 use Config;
12
13 BEGIN {
14     if (! -c "/dev/null") {
15         print "1..0 # Skip: no /dev/null\n";
16         exit 0;
17     }
18
19     my $dev_tty = '/dev/tty';
20     $dev_tty = 'TT:' if ($^O eq 'VMS');
21     if (! -c $dev_tty) {
22         print "1..0 # Skip: no $dev_tty\n";
23         exit 0;
24     }
25     if ($ENV{PERL5DB}) {
26         print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n";
27         exit 0;
28     }
29 }
30
31 plan(25);
32
33 my $rc_filename = '.perldb';
34
35 sub rc {
36     open my $rc_fh, '>', $rc_filename
37         or die $!;
38     print {$rc_fh} @_;
39     close ($rc_fh);
40
41     # overly permissive perms gives "Must not source insecure rcfile"
42     # and hangs at the DB(1> prompt
43     chmod 0644, $rc_filename;
44 }
45
46 sub _slurp
47 {
48     my $filename = shift;
49
50     open my $in, '<', $filename
51         or die "Cannot open '$filename' for slurping - $!";
52
53     local $/;
54     my $contents = <$in>;
55
56     close($in);
57
58     return $contents;
59 }
60
61 my $out_fn = 'db.out';
62
63 sub _out_contents
64 {
65     return _slurp($out_fn);
66 }
67
68 {
69     my $target = '../lib/perl5db/t/eval-line-bug';
70
71     rc(
72         <<"EOF",
73     &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
74
75     sub afterinit {
76         push(\@DB::typeahead,
77             'b 23',
78             'n',
79             'n',
80             'n',
81             'c', # line 23
82             'n',
83             "p \\\@{'main::_<$target'}",
84             'q',
85         );
86     }
87 EOF
88     );
89
90     {
91         local $ENV{PERLDB_OPTS} = "ReadLine=0";
92         runperl(switches => [ '-d' ], progfile => $target);
93     }
94 }
95
96 like(_out_contents(), qr/sub factorial/,
97     'The ${main::_<filename} variable in the debugger was not destroyed'
98 );
99
100 {
101     my $target = '../lib/perl5db/t/eval-line-bug';
102
103     rc(
104         <<"EOF",
105     &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
106
107     sub afterinit {
108         push(\@DB::typeahead,
109             'b 23',
110             'c',
111             '\$new_var = "Foo"',
112             'x "new_var = <\$new_var>\\n";',
113             'q',
114         );
115     }
116 EOF
117     );
118
119     {
120         local $ENV{PERLDB_OPTS} = "ReadLine=0";
121         runperl(switches => [ '-d' ], progfile => $target);
122     }
123 }
124
125 like(_out_contents(), qr/new_var = <Foo>/,
126     "no strict 'vars' in evaluated lines.",
127 );
128
129 {
130     local $ENV{PERLDB_OPTS} = "ReadLine=0";
131     my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/lvalue-bug');
132     like($output, qr/foo is defined/, 'lvalue subs work in the debugger');
133 }
134
135 {
136     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
137     my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/symbol-table-bug');
138     like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table');
139 }
140
141 SKIP: {
142     if ( $Config{usethreads} ) {
143         skip('This perl has threads, skipping non-threaded debugger tests');
144     } else {
145         my $error = 'This Perl not built to support threads';
146         my $output = runperl( switches => [ '-dt' ], stderr => 1 );
147         like($output, qr/$error/, 'Perl debugger correctly complains that it was not built with threads');
148     }
149
150 }
151 SKIP: {
152     if ( $Config{usethreads} ) {
153         local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
154         my $output = runperl(switches => [ '-dt' ], progfile => '../lib/perl5db/t/symbol-table-bug');
155         like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table when running with thread support');
156     } else {
157         skip("This perl is not threaded, skipping threaded debugger tests");
158     }
159 }
160
161
162 # Test [perl #61222]
163 {
164     rc(
165         <<'EOF',
166         &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
167
168         sub afterinit {
169             push(@DB::typeahead,
170                 'm Pie',
171                 'q',
172             );
173         }
174 EOF
175     );
176
177     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-61222');
178     unlike(_out_contents(), qr/INCORRECT/, "[perl #61222]");
179 }
180
181
182
183 # Test for Proxy constants
184 {
185     rc(
186         <<'EOF',
187
188 &parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out");
189
190 sub afterinit {
191     push(@DB::typeahead,
192         'm main->s1',
193         'q',
194     );
195 }
196
197 EOF
198     );
199
200     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
201     is($output, "", "proxy constant subroutines");
202 }
203
204 # Testing that we can set a line in the middle of the file.
205 {
206     rc(<<'EOF');
207 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
208
209 sub afterinit {
210     push (@DB::typeahead,
211     'b ../lib/perl5db/t/MyModule.pm:12',
212     'c',
213     q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
214     'c',
215     'q',
216     );
217
218 }
219 EOF
220
221     my $output = runperl(switches => [ '-d', '-I', '../lib/perl5db/t', ], stderr => 1, progfile => '../lib/perl5db/t/filename-line-breakpoint');
222
223     like($output, qr/
224         ^Var=Bar$
225             .*
226         ^In\ MyModule\.$
227             .*
228         ^In\ Main\ File\.$
229             .*
230         /msx,
231         "Can set breakpoint in a line in the middle of the file.");
232 }
233
234
235 # [perl #66110] Call a subroutine inside a regex
236 {
237     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
238     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
239     like($output, "All tests successful.", "[perl #66110]");
240 }
241
242 # [perl 104168] level option for tracing
243 {
244     rc(<<'EOF');
245 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
246
247 sub afterinit {
248     push (@DB::typeahead,
249     't 2',
250     'c',
251     'q',
252     );
253
254 }
255 EOF
256
257     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-104168');
258     my $contents;
259     {
260         local $/;
261         open I, "<", 'db.out' or die $!;
262         $contents = <I>;
263         close(I);
264     }
265     like($contents, qr/level 2/, "[perl #104168]");
266     unlike($contents, qr/baz/, "[perl #104168]");
267 }
268
269 # taint tests
270
271 {
272     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
273     my $output = runperl(switches => [ '-d', '-T' ], stderr => 1,
274         progfile => '../lib/perl5db/t/taint');
275     chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
276     is($output, '[$^X][done]', "taint");
277 }
278
279 # Testing that we can set a breakpoint
280 {
281     rc(<<'EOF');
282 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
283
284 sub afterinit {
285     push (@DB::typeahead,
286     'b 6',
287     'c',
288     q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/,
289     'c',
290     'q',
291     );
292
293 }
294 EOF
295
296     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/breakpoint-bug');
297
298     like($output, qr/
299         X=\{Two\}
300         /msx,
301         "Can set breakpoint in a line.");
302 }
303
304
305 # Testing that we can disable a breakpoint at a numeric line.
306 {
307     rc(<<'EOF');
308 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
309
310 sub afterinit {
311     push (@DB::typeahead,
312     'b 7',
313     'b 11',
314     'disable 7',
315     'c',
316     q/print "X={$x}\n";/,
317     'c',
318     'q',
319     );
320
321 }
322 EOF
323
324     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-1'); +
325     like($output, qr/
326         X=\{SecondVal\}
327         /msx,
328         "Can set breakpoint in a line.");
329 }
330
331 # Testing that we can re-enable a breakpoint at a numeric line.
332 {
333     rc(<<'EOF');
334 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
335
336 sub afterinit {
337     push (@DB::typeahead,
338     'b 8',
339     'b 24',
340     'disable 24',
341     'c',
342     'enable 24',
343     'c',
344     q/print "X={$x}\n";/,
345     'c',
346     'q',
347     );
348
349 }
350 EOF
351
352     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-2'); 
353     like($output, qr/
354         X=\{SecondValOneHundred\}
355         /msx,
356         "Can set breakpoint in a line.");
357 }
358 # clean up.
359
360 # Disable and enable for breakpoints on outer files.
361 {
362     rc(<<'EOF');
363 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
364
365 sub afterinit {
366     push (@DB::typeahead,
367     'b 10',
368     'b ../lib/perl5db/t/EnableModule.pm:14',
369     'disable ../lib/perl5db/t/EnableModule.pm:14',
370     'c',
371     'enable ../lib/perl5db/t/EnableModule.pm:14',
372     'c',
373     q/print "X={$x}\n";/,
374     'c',
375     'q',
376     );
377
378 }
379 EOF
380
381     my $output = runperl(switches => [ '-d', '-I', '../lib/perl5db/t', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-3'); +
382     like($output, qr/
383         X=\{SecondValTwoHundred\}
384         /msx,
385         "Can set breakpoint in a line.");
386 }
387
388 # Testing that the prompt with the information appears.
389 {
390     rc(<<'EOF');
391 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
392
393 sub afterinit {
394     push (@DB::typeahead,
395     'q',
396     );
397
398 }
399 EOF
400
401     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-1');
402
403     like(_out_contents(), qr/
404         ^main::\([^\)]*\bdisable-breakpoints-1:2\):\n
405         2:\s+my\ \$x\ =\ "One";\n
406         /msx,
407         "Prompt should display the first line of code.");
408 }
409
410 # Testing that R (restart) and "B *" work.
411 {
412     rc(<<'EOF');
413 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
414
415 sub afterinit {
416     push (@DB::typeahead,
417     'b 13',
418     'c',
419     'B *',
420     'b 9',
421     'R',
422     'c',
423     q/print "X={$x};dummy={$dummy}\n";/,
424     'q',
425     );
426
427 }
428 EOF
429
430     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-1');
431     like($output, qr/
432         X=\{FirstVal\};dummy=\{1\}
433         /msx,
434         "Restart and delete all breakpoints work properly.");
435 }
436
437 {
438     rc(<<'EOF');
439 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
440
441 sub afterinit {
442     push (@DB::typeahead,
443     'c 15',
444     q/print "X={$x}\n";/,
445     'c',
446     'q',
447     );
448
449 }
450 EOF
451
452     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-1'); +
453     like($output, qr/
454         X=\{ThirdVal\}
455         /msx,
456         "'c line_num' is working properly.");
457 }
458
459 {
460     rc(<<'EOF');
461 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
462
463 sub afterinit {
464     push (@DB::typeahead,
465     'n',
466     'n',
467     'b . $exp > 200',
468     'c',
469     q/print "Exp={$exp}\n";/,
470     'q',
471     );
472 }
473 EOF
474
475     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/break-on-dot'); +
476     like($output, qr/
477         Exp=\{256\}
478         /msx,
479         "'b .' is working correctly.");
480 }
481
482 # Testing that the prompt with the information appears inside a subroutine call.
483 # See https://rt.perl.org/rt3/Ticket/Display.html?id=104820
484 {
485     rc(<<'EOF');
486 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
487
488 sub afterinit {
489     push (@DB::typeahead,
490     'c back',
491     'q',
492     );
493 }
494 EOF
495     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/with-subroutine');
496
497     like(_out_contents(), 
498         qr/
499         ^main::back\([^\)\n]*\bwith-subroutine:15\):[\ \t]*\n
500         ^15:\s*print\ "hello\ back\\n";
501         /msx,
502         "Prompt should display the line of code inside a subroutine.");
503 }
504
505 # Checking that the p command works.
506 {
507     rc(<<'EOF');
508 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
509
510 sub afterinit {
511     push (@DB::typeahead,
512     'p "<<<" . (4*6) . ">>>"',
513     'q',
514     );
515
516 }
517 EOF
518
519     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/with-subroutine');
520
521     like(_out_contents(), 
522         qr/<<<24>>>/,
523         "p command works.");
524 }
525
526 # Tests for x.
527 {
528     rc(<<'EOF');
529 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
530
531 sub afterinit {
532     push (@DB::typeahead,
533     q/x {500 => 600}/,
534     'q',
535     );
536
537 }
538 EOF
539
540     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/with-subroutine');
541
542     like(_out_contents(), 
543         # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
544         qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/ms,
545         "x command test."
546     );
547 }
548
549 # Tests for "T" (stack trace).
550 {
551     rc(<<'EOF');
552 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
553
554 sub afterinit {
555     push (@DB::typeahead,
556     'c baz',
557     'T',
558     'q',
559     );
560
561 }
562 EOF
563
564     my $prog_fn = '../lib/perl5db/t/rt-104168';
565     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => $prog_fn,);
566
567     my $re_text = join('',
568         map {
569         sprintf(
570             "%s = %s\\(\\) called from file " .
571             "'" . quotemeta($prog_fn) . "' line %s\\n",
572             (map { quotemeta($_) } @$_)
573             )
574         } 
575         (
576             ['.', 'main::baz', 14,],
577             ['.', 'main::bar', 9,],
578             ['.', 'main::foo', 6]
579         )
580     );
581     like(_out_contents(), 
582         # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
583         qr/^$re_text/ms,
584         "T command test."
585     );
586 }
587 END {
588     1 while unlink ($rc_filename, $out_fn);
589 }