This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix a skip count in base's t/fields.t
[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
076b743f 31plan(11);
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{
6fd69bbe 101 local $ENV{PERLDB_OPTS} = "ReadLine=0";
6fd69bbe
FR
102 my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/lvalue-bug');
103 like($output, qr/foo is defined/, 'lvalue subs work in the debugger');
104}
105
bc6438f2
DL
106{
107 local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
108 my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/symbol-table-bug');
109 like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table');
110}
111
9b76ae71 112SKIP: {
f63574b5 113 if ( $Config{usethreads} ) {
9c955c4d
DL
114 skip('This perl has threads, skipping non-threaded debugger tests');
115 } else {
116 my $error = 'This Perl not built to support threads';
53409900 117 my $output = runperl( switches => [ '-dt' ], stderr => 1 );
9c955c4d
DL
118 like($output, qr/$error/, 'Perl debugger correctly complains that it was not built with threads');
119 }
120
121}
9b76ae71 122SKIP: {
9c955c4d 123 if ( $Config{usethreads} ) {
f63574b5
DL
124 local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
125 my $output = runperl(switches => [ '-dt' ], progfile => '../lib/perl5db/t/symbol-table-bug');
126 like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table when running with thread support');
127 } else {
128 skip("This perl is not threaded, skipping threaded debugger tests");
129 }
7dcc656f
DL
130}
131
7eedc5ec
B
132
133# Test [perl #61222]
134{
135 rc(
4cfe45a1 136 <<'EOF',
7eedc5ec 137 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
7eedc5ec 138
7eedc5ec 139 sub afterinit {
4cfe45a1 140 push(@DB::typeahead,
7eedc5ec
B
141 'm Pie',
142 'q',
143 );
4cfe45a1
SF
144 }
145EOF
7eedc5ec
B
146 );
147
148 my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-61222');
4cfe45a1 149 unlike(_out_contents(), qr/INCORRECT/, "[perl #61222]");
7eedc5ec
B
150}
151
152
153
154# Test for Proxy constants
155{
156 rc(
4cfe45a1 157 <<'EOF',
7eedc5ec 158
4cfe45a1
SF
159&parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out");
160
161sub afterinit {
162 push(@DB::typeahead,
163 'm main->s1',
164 'q',
165 );
166}
167
168EOF
7eedc5ec
B
169 );
170
171 my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
172 is($output, "", "proxy constant subroutines");
173}
174
076b743f
SF
175# Testing that we can set a line in the middle of the file.
176{
177 rc(<<'EOF');
178&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
179
180sub afterinit {
181 push (@DB::typeahead,
182 'b ../lib/perl5db/t/MyModule.pm:12',
183 'c',
184 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
185 'c',
186 'q',
187 );
188
189}
190EOF
191
192 my $output = runperl(switches => [ '-d', '-I', '../lib/perl5db/t', ], stderr => 1, progfile => '../lib/perl5db/t/filename-line-breakpoint');
193
194 like($output, qr/
195 ^Var=Bar$
196 .*
197 ^In\ MyModule\.$
198 .*
199 ^In\ Main\ File\.$
200 .*
4cfe45a1 201 /msx,
076b743f
SF
202 "Can set breakpoint in a line in the middle of the file.");
203}
204
7eedc5ec 205
b7bfa855
B
206# [perl #66110] Call a subroutine inside a regex
207{
208 local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
209 my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
210 like($output, "All tests successful.", "[perl #66110]");
211}
212
07004ebb
DM
213# taint tests
214
215{
216 local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
217 my $output = runperl(switches => [ '-d', '-T' ], stderr => 1,
4cfe45a1 218 progfile => '../lib/perl5db/t/taint');
314655b3 219 chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
07004ebb
DM
220 is($output, '[$^X][done]', "taint");
221}
222
2211a10b
SF
223# Testing that we can set a breakpoint
224{
225 rc(<<'EOF');
226&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
227
228sub afterinit {
229 push (@DB::typeahead,
230 'b 6',
231 'c',
232 q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/,
233 'c',
234 'q',
235 );
236
237}
238EOF
239
240 my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/breakpoint-bug');
241
242 like($output, qr/
243 X=\{Two\}
244 /msx,
245 "Can set breakpoint in a line.");
246}
247
4cfe45a1 248
b7bfa855 249
635f2c9e
RGS
250# clean up.
251
252END {
4cfe45a1 253 1 while unlink ($rc_filename, $out_fn);
635f2c9e 254}