Commit | Line | Data |
---|---|---|
af6d5e29 | 1 | #!./perl |
635f2c9e RGS |
2 | |
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
6 | require './test.pl'; | |
7 | } | |
8 | ||
9 | use strict; | |
10 | use warnings; | |
f63574b5 | 11 | use Config; |
635f2c9e RGS |
12 | |
13 | BEGIN { | |
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 | ||
e09195af | 31 | plan(14); |
635f2c9e | 32 | |
4cfe45a1 SF |
33 | my $rc_filename = '.perldb'; |
34 | ||
635f2c9e | 35 | sub 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 |
46 | sub _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 | ||
61 | my $out_fn = 'db.out'; | |
635f2c9e | 62 | |
4cfe45a1 | 63 | sub _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 | } | |
87 | EOF | |
88 | ); | |
89 | ||
90 | { | |
91 | local $ENV{PERLDB_OPTS} = "ReadLine=0"; | |
92 | runperl(switches => [ '-d' ], progfile => $target); | |
93 | } | |
635f2c9e RGS |
94 | } |
95 | ||
4cfe45a1 | 96 | like(_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 | 112 | SKIP: { |
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 | 122 | SKIP: { |
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 | } |
145 | EOF | |
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 | ||
161 | sub afterinit { | |
162 | push(@DB::typeahead, | |
163 | 'm main->s1', | |
164 | 'q', | |
165 | ); | |
166 | } | |
167 | ||
168 | EOF | |
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 | ||
180 | sub 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 | } | |
190 | EOF | |
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 | ||
228 | sub 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 | } | |
238 | EOF | |
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 | |
e09195af SF |
249 | # Testing that we can disable a breakpoint at a numeric line. |
250 | { | |
251 | rc(<<'EOF'); | |
252 | &parse_options("NonStop=0 TTY=db.out LineInfo=db.out"); | |
253 | ||
254 | sub afterinit { | |
255 | push (@DB::typeahead, | |
256 | 'b 7', | |
257 | 'b 11', | |
258 | 'disable 7', | |
259 | 'c', | |
260 | q/print "X={$x}\n";/, | |
261 | 'c', | |
262 | 'q', | |
263 | ); | |
264 | ||
265 | } | |
266 | EOF | |
267 | ||
268 | my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-1'); + | |
269 | like($output, qr/ | |
270 | X=\{SecondVal\} | |
271 | /msx, | |
272 | "Can set breakpoint in a line."); | |
273 | } | |
274 | ||
275 | # Testing that we can re-enable a breakpoint at a numeric line. | |
276 | { | |
277 | rc(<<'EOF'); | |
278 | &parse_options("NonStop=0 TTY=db.out LineInfo=db.out"); | |
279 | ||
280 | sub afterinit { | |
281 | push (@DB::typeahead, | |
282 | 'b 8', | |
283 | 'b 24', | |
284 | 'disable 24', | |
285 | 'c', | |
286 | 'enable 24', | |
287 | 'c', | |
288 | q/print "X={$x}\n";/, | |
289 | 'c', | |
290 | 'q', | |
291 | ); | |
b7bfa855 | 292 | |
e09195af SF |
293 | } |
294 | EOF | |
295 | ||
296 | my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-2'); | |
297 | like($output, qr/ | |
298 | X=\{SecondValOneHundred\} | |
299 | /msx, | |
300 | "Can set breakpoint in a line."); | |
301 | } | |
635f2c9e RGS |
302 | # clean up. |
303 | ||
e09195af SF |
304 | # Disable and enable for breakpoints on outer files. |
305 | { | |
306 | rc(<<'EOF'); | |
307 | &parse_options("NonStop=0 TTY=db.out LineInfo=db.out"); | |
308 | ||
309 | sub afterinit { | |
310 | push (@DB::typeahead, | |
311 | 'b 10', | |
312 | 'b ../lib/perl5db/t/EnableModule.pm:14', | |
313 | 'disable ../lib/perl5db/t/EnableModule.pm:14', | |
314 | 'c', | |
315 | 'enable ../lib/perl5db/t/EnableModule.pm:14', | |
316 | 'c', | |
317 | q/print "X={$x}\n";/, | |
318 | 'c', | |
319 | 'q', | |
320 | ); | |
321 | ||
322 | } | |
323 | EOF | |
324 | ||
325 | my $output = runperl(switches => [ '-d', '-I', '../lib/perl5db/t', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-3'); + | |
326 | like($output, qr/ | |
327 | X=\{SecondValTwoHundred\} | |
328 | /msx, | |
329 | "Can set breakpoint in a line."); | |
330 | } | |
635f2c9e | 331 | END { |
4cfe45a1 | 332 | 1 while unlink ($rc_filename, $out_fn); |
635f2c9e | 333 | } |