This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Bump several file copyright dates
[perl5.git] / lib / perl5db.t
CommitLineData
af6d5e29 1#!./perl
635f2c9e
RGS
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
6 require './test.pl';
7}
8
9use strict;
10use warnings;
f63574b5 11use Config;
635f2c9e
RGS
12
13BEGIN {
4cfe45a1
SF
14 if (! -c "/dev/null") {
15 print "1..0 # Skip: no /dev/null\n";
16 exit 0;
635f2c9e 17 }
4cfe45a1
SF
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;
9366364f 24 }
b091e0d1 25 if ($ENV{PERL5DB}) {
4cfe45a1
SF
26 print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n";
27 exit 0;
b091e0d1 28 }
635f2c9e
RGS
29}
30
d7b8b95b 31plan(30);
635f2c9e 32
4cfe45a1
SF
33my $rc_filename = '.perldb';
34
635f2c9e 35sub rc {
4cfe45a1
SF
36 open my $rc_fh, '>', $rc_filename
37 or die $!;
38 print {$rc_fh} @_;
39 close ($rc_fh);
40
3e5e55bd
DM
41 # overly permissive perms gives "Must not source insecure rcfile"
42 # and hangs at the DB(1> prompt
4cfe45a1 43 chmod 0644, $rc_filename;
635f2c9e
RGS
44}
45
4cfe45a1
SF
46sub _slurp
47{
48 my $filename = shift;
cd4eab35 49
4cfe45a1
SF
50 open my $in, '<', $filename
51 or die "Cannot open '$filename' for slurping - $!";
635f2c9e 52
4cfe45a1
SF
53 local $/;
54 my $contents = <$in>;
55
56 close($in);
57
58 return $contents;
59}
60
61my $out_fn = 'db.out';
635f2c9e 62
4cfe45a1 63sub _out_contents
c18cf8ce 64{
4cfe45a1 65 return _slurp($out_fn);
c18cf8ce 66}
635f2c9e 67
635f2c9e 68{
4cfe45a1
SF
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 }
87EOF
88 );
89
90 {
91 local $ENV{PERLDB_OPTS} = "ReadLine=0";
92 runperl(switches => [ '-d' ], progfile => $target);
93 }
635f2c9e
RGS
94}
95
4cfe45a1 96like(_out_contents(), qr/sub factorial/,
635f2c9e
RGS
97 'The ${main::_<filename} variable in the debugger was not destroyed'
98);
99
1ad62f64 100{
bdba49ad
SF
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 }
116EOF
117 );
118
119 {
120 local $ENV{PERLDB_OPTS} = "ReadLine=0";
121 runperl(switches => [ '-d' ], progfile => $target);
122 }
123}
124
125like(_out_contents(), qr/new_var = <Foo>/,
126 "no strict 'vars' in evaluated lines.",
127);
128
129{
6fd69bbe 130 local $ENV{PERLDB_OPTS} = "ReadLine=0";
6fd69bbe
FR
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
bc6438f2
DL
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
9b76ae71 141SKIP: {
f63574b5 142 if ( $Config{usethreads} ) {
9c955c4d
DL
143 skip('This perl has threads, skipping non-threaded debugger tests');
144 } else {
145 my $error = 'This Perl not built to support threads';
53409900 146 my $output = runperl( switches => [ '-dt' ], stderr => 1 );
9c955c4d
DL
147 like($output, qr/$error/, 'Perl debugger correctly complains that it was not built with threads');
148 }
149
150}
9b76ae71 151SKIP: {
9c955c4d 152 if ( $Config{usethreads} ) {
f63574b5
DL
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 }
7dcc656f
DL
159}
160
7eedc5ec
B
161
162# Test [perl #61222]
163{
164 rc(
4cfe45a1 165 <<'EOF',
7eedc5ec 166 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
7eedc5ec 167
7eedc5ec 168 sub afterinit {
4cfe45a1 169 push(@DB::typeahead,
7eedc5ec
B
170 'm Pie',
171 'q',
172 );
4cfe45a1
SF
173 }
174EOF
7eedc5ec
B
175 );
176
177 my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-61222');
4cfe45a1 178 unlike(_out_contents(), qr/INCORRECT/, "[perl #61222]");
7eedc5ec
B
179}
180
181
182
183# Test for Proxy constants
184{
185 rc(
4cfe45a1 186 <<'EOF',
7eedc5ec 187
4cfe45a1
SF
188&parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out");
189
190sub afterinit {
191 push(@DB::typeahead,
192 'm main->s1',
193 'q',
194 );
195}
196
197EOF
7eedc5ec
B
198 );
199
200 my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
201 is($output, "", "proxy constant subroutines");
202}
203
076b743f
SF
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
209sub 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}
219EOF
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 .*
4cfe45a1 230 /msx,
076b743f
SF
231 "Can set breakpoint in a line in the middle of the file.");
232}
233
7eedc5ec 234
b7bfa855
B
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
611272bb
PS
242# [perl 104168] level option for tracing
243{
244 rc(<<'EOF');
245&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
246
247sub afterinit {
248 push (@DB::typeahead,
249 't 2',
250 'c',
251 'q',
252 );
253
254}
255EOF
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
07004ebb
DM
269# taint tests
270
271{
272 local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
273 my $output = runperl(switches => [ '-d', '-T' ], stderr => 1,
4cfe45a1 274 progfile => '../lib/perl5db/t/taint');
314655b3 275 chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
07004ebb
DM
276 is($output, '[$^X][done]', "taint");
277}
278
2211a10b
SF
279# Testing that we can set a breakpoint
280{
281 rc(<<'EOF');
282&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
283
284sub 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}
294EOF
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
4cfe45a1 304
e09195af
SF
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
310sub 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}
322EOF
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
336sub 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 );
b7bfa855 348
e09195af
SF
349}
350EOF
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}
635f2c9e
RGS
358# clean up.
359
e09195af
SF
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
365sub 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}
379EOF
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}
bdba49ad
SF
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
393sub afterinit {
394 push (@DB::typeahead,
395 'q',
396 );
397
398}
399EOF
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
415sub 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}
428EOF
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
5d5d9ea3
SF
437{
438 rc(<<'EOF');
439&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
440
441sub afterinit {
442 push (@DB::typeahead,
443 'c 15',
444 q/print "X={$x}\n";/,
445 'c',
446 'q',
447 );
448
449}
450EOF
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
5343a617
SF
459{
460 rc(<<'EOF');
461&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
462
463sub afterinit {
464 push (@DB::typeahead,
465 'n',
466 'n',
467 'b . $exp > 200',
468 'c',
469 q/print "Exp={$exp}\n";/,
470 'q',
471 );
5343a617
SF
472}
473EOF
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
8dc67a69
SF
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
488sub afterinit {
489 push (@DB::typeahead,
490 'c back',
491 'q',
492 );
493}
494EOF
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
984e0ec4
SF
505# Checking that the p command works.
506{
507 rc(<<'EOF');
508&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
509
510sub afterinit {
511 push (@DB::typeahead,
512 'p "<<<" . (4*6) . ">>>"',
513 'q',
514 );
515
516}
517EOF
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
9f810cd7
SF
526# Tests for x.
527{
528 rc(<<'EOF');
529&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
530
531sub afterinit {
532 push (@DB::typeahead,
533 q/x {500 => 600}/,
534 'q',
535 );
536
537}
538EOF
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
5bc17875
SF
549# Tests for "T" (stack trace).
550{
551 rc(<<'EOF');
552&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
553
554sub afterinit {
555 push (@DB::typeahead,
556 'c baz',
557 'T',
558 'q',
559 );
560
561}
562EOF
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}
8fe891f1
SF
587
588# Test for s.
589{
590 rc(<<'EOF');
591&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
592
593sub afterinit {
594 push (@DB::typeahead,
595 'b 9',
596 'c',
597 's',
598 q/print "X={$x};dummy={$dummy}\n";/,
599 'q',
600 );
601
602}
603EOF
604
605 my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-1');
606 like($output, qr/
607 X=\{SecondVal\};dummy=\{1\}
608 /msx,
609 'test for s - single step',
610 );
611}
612
65ab0314
SF
613{
614 rc(<<'EOF');
615&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
616
617sub afterinit {
618 push (@DB::typeahead,
619 'n',
620 'n',
621 'b . $exp > 200',
622 'c',
623 q/print "Exp={$exp}\n";/,
624 'q',
625 );
626
627}
628EOF
629
630 my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/break-on-dot'); +
631 like($output, qr/
632 Exp=\{256\}
633 /msx,
634 "'b .' is working correctly.");
635}
636
637{
638 rc(<<'EOF');
639&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
640
641sub afterinit {
642 push (@DB::typeahead,
643 's',
644 'q',
645 );
646
647}
648EOF
649
650 my $prog_fn = '../lib/perl5db/t/rt-104168';
651 my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => $prog_fn,);
652
653 like(_out_contents(),
654 qr/
655 ^main::foo\([^\)\n]*\brt-104168:9\):[\ \t]*\n
656 ^9:\s*bar\(\);
657 /msx,
658 'Test for the s command.',
659 );
660}
661
5d83cde2
SF
662{
663 rc(<<'EOF');
664&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
665
666sub afterinit {
667 push (@DB::typeahead,
668 's uncalled_subroutine()',
669 'c',
670 'q',
671 );
672
673}
674EOF
675
676 my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/uncalled-subroutine');
677
678 like ($output,
679 qr/<1,2,3,4,5>\n/,
680 'uncalled_subroutine was called after s EXPR()',
681 );
682
683}
684
d7b8b95b
SF
685{
686 rc(<<'EOF');
687&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
688
689sub afterinit {
690 push (@DB::typeahead,
691 'n uncalled_subroutine()',
692 'c',
693 'q',
694 );
695
696}
697EOF
698
699 my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/uncalled-subroutine');
700
701 like ($output,
702 qr/<1,2,3,4,5>\n/,
703 'uncalled_subroutine was called after n EXPR()',
704 );
705
706}
707
635f2c9e 708END {
4cfe45a1 709 1 while unlink ($rc_filename, $out_fn);
635f2c9e 710}