Commit | Line | Data |
---|---|---|
d7aa4417 JH |
1 | #!./perl -w |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = qw(../lib lib); | |
177ee6a3 | 6 | require "./test.pl"; |
d7aa4417 JH |
7 | } |
8 | ||
be1cc451 | 9 | # This test depends on t/lib/Devel/switchd*.pm. |
964b4e64 | 10 | |
8d28fc8f | 11 | plan(tests => 21); |
d7aa4417 JH |
12 | |
13 | my $r; | |
d7aa4417 | 14 | |
2d90ac95 | 15 | my $filename = tempfile(); |
d7aa4417 JH |
16 | SKIP: { |
17 | open my $f, ">$filename" | |
18 | or skip( "Can't write temp file $filename: $!" ); | |
19 | print $f <<'__SWDTEST__'; | |
20 | package Bar; | |
21 | sub bar { $_[0] * $_[0] } | |
22 | package Foo; | |
23 | sub foo { | |
24 | my $s; | |
25 | $s += Bar::bar($_) for 1..$_[0]; | |
26 | } | |
27 | package main; | |
28 | Foo::foo(3); | |
29 | __SWDTEST__ | |
30 | close $f; | |
d7aa4417 JH |
31 | $| = 1; # Unbufferize. |
32 | $r = runperl( | |
e30fbb82 | 33 | switches => [ '-Ilib', '-f', '-d:switchd' ], |
d7aa4417 | 34 | progfile => $filename, |
964b4e64 JH |
35 | args => ['3'], |
36 | ); | |
6e31dd88 JK |
37 | like($r, |
38 | qr/^sub<Devel::switchd::import>;import<Devel::switchd>;DB<main,$::tempfile_regexp,9>;sub<Foo::foo>;DB<Foo,$::tempfile_regexp,5>;DB<Foo,$::tempfile_regexp,6>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;$/, | |
39 | 'Got debugging output: 1'); | |
964b4e64 | 40 | $r = runperl( |
e30fbb82 | 41 | switches => [ '-Ilib', '-f', '-d:switchd=a,42' ], |
964b4e64 JH |
42 | progfile => $filename, |
43 | args => ['4'], | |
d7aa4417 | 44 | ); |
6e31dd88 JK |
45 | like($r, |
46 | qr/^sub<Devel::switchd::import>;import<Devel::switchd a 42>;DB<main,$::tempfile_regexp,9>;sub<Foo::foo>;DB<Foo,$::tempfile_regexp,5>;DB<Foo,$::tempfile_regexp,6>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;$/, | |
47 | 'Got debugging output: 2'); | |
b19934fb NC |
48 | $r = runperl( |
49 | switches => [ '-Ilib', '-f', '-d:-switchd=a,42' ], | |
50 | progfile => $filename, | |
51 | args => ['4'], | |
52 | ); | |
6e31dd88 JK |
53 | like($r, |
54 | qr/^sub<Devel::switchd::unimport>;unimport<Devel::switchd a 42>;DB<main,$::tempfile_regexp,9>;sub<Foo::foo>;DB<Foo,$::tempfile_regexp,5>;DB<Foo,$::tempfile_regexp,6>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;sub<Bar::bar>;DB<Bar,$::tempfile_regexp,2>;$/, | |
55 | 'Got debugging output: 3'); | |
d7aa4417 JH |
56 | } |
57 | ||
5a9a79a4 FC |
58 | # [perl #71806] |
59 | cmp_ok( | |
60 | runperl( # less is useful for something :-) | |
61 | switches => [ '"-Mless ++INC->{q-Devel/_.pm-}"' ], | |
62 | progs => [ | |
63 | '#!perl -d:_', | |
64 | 'sub DB::DB{} print scalar @{q/_</.__FILE__}', | |
65 | ], | |
66 | ), | |
67 | '>', | |
68 | 0, | |
69 | 'The debugger can see the lines of the main program under #!perl -d', | |
70 | ); | |
be1cc451 | 71 | |
7f1c3e8c FC |
72 | like |
73 | runperl( | |
74 | switches => [ '"-Mless ++INC->{q-Devel/_.pm-}"' ], | |
75 | progs => [ | |
76 | '#!perl -d:_', | |
77 | 'sub DB::DB{} print line=>__LINE__', | |
78 | ], | |
79 | ), | |
80 | qr/line2/, | |
81 | '#!perl -d:whatever does not throw line numbers off'; | |
82 | ||
be1cc451 FC |
83 | # [perl #48332] |
84 | like( | |
85 | runperl( | |
86 | switches => [ '-Ilib', '-d:switchd_empty' ], | |
87 | progs => [ | |
88 | 'sub foo { print qq _1\n_ }', | |
89 | '*old_foo = \&foo;', | |
90 | '*foo = sub { print qq _2\n_ };', | |
91 | 'old_foo(); foo();', | |
92 | ], | |
93 | ), | |
94 | qr "1\r?\n2\r?\n", | |
95 | 'Subroutine redefinition works in the debugger [perl #48332]', | |
96 | ); | |
a7999c08 FC |
97 | |
98 | # [rt.cpan.org #69862] | |
99 | like( | |
100 | runperl( | |
101 | switches => [ '-Ilib', '-d:switchd_empty' ], | |
102 | progs => [ | |
103 | 'sub DB::sub { goto &$DB::sub }', | |
104 | 'sub foo { print qq _1\n_ }', | |
105 | 'sub bar { print qq _2\n_ }', | |
106 | 'delete $::{foo}; eval { foo() };', | |
107 | 'my $bar = *bar; undef *bar; eval { &$bar };', | |
108 | ], | |
109 | ), | |
110 | qr "1\r?\n2\r?\n", | |
111 | 'Subroutines no longer found under their names can be called', | |
112 | ); | |
7d8b4ed3 FC |
113 | |
114 | # [rt.cpan.org #69862] | |
115 | like( | |
116 | runperl( | |
117 | switches => [ '-Ilib', '-d:switchd_empty' ], | |
118 | progs => [ | |
119 | 'sub DB::sub { goto &$DB::sub }', | |
120 | 'sub foo { goto &bar::baz; }', | |
121 | 'sub bar::baz { print qq _ok\n_ }', | |
122 | 'delete $::{bar::::};', | |
123 | 'foo();', | |
124 | ], | |
125 | ), | |
126 | qr "ok\r?\n", | |
127 | 'No crash when calling orphaned subroutine via goto &', | |
128 | ); | |
432d4561 JL |
129 | |
130 | # test when DB::DB is seen but not defined [perl #114990] | |
131 | like( | |
132 | runperl( | |
133 | switches => [ '-Ilib', '-d:nodb' ], | |
134 | prog => [ '1' ], | |
135 | stderr => 1, | |
136 | ), | |
137 | qr/^No DB::DB routine defined/, | |
c2cb6f77 FC |
138 | "No crash when *DB::DB exists but not &DB::DB", |
139 | ); | |
140 | like( | |
141 | runperl( | |
142 | switches => [ '-Ilib' ], | |
143 | prog => 'sub DB::DB; BEGIN { $^P = 0x22; } for(0..9){ warn }', | |
144 | stderr => 1, | |
145 | ), | |
146 | qr/^No DB::DB routine defined/, | |
147 | "No crash when &DB::DB exists but isn't actually defined", | |
432d4561 | 148 | ); |
8cece913 FC |
149 | # or seen and defined later |
150 | is( | |
151 | runperl( | |
152 | switches => [ '-Ilib', '-d:nodb' ], # nodb.pm contains *DB::DB...if 0 | |
153 | prog => 'warn; sub DB::DB { print qq-ok\n-; exit }', | |
154 | stderr => 1, | |
155 | ), | |
156 | "ok\n", | |
157 | "DB::DB works after '*DB::DB if 0'", | |
158 | ); | |
9d976ff5 FC |
159 | |
160 | # [perl #115742] Recursive DB::DB clobbering its own pad | |
161 | like( | |
162 | runperl( | |
163 | switches => [ '-Ilib' ], | |
164 | progs => [ split "\n", <<'=' | |
165 | BEGIN { | |
166 | $^P = 0x22; | |
167 | } | |
168 | package DB; | |
169 | sub DB { | |
170 | my $x = 42; | |
171 | return if $__++; | |
172 | $^D |= 1 << 30; # allow recursive calls | |
173 | main::foo(); | |
174 | print $x//q-u-, qq-\n-; | |
175 | } | |
176 | package main; | |
177 | chop; | |
178 | sub foo { chop; } | |
179 | = | |
180 | ], | |
181 | stderr => 1, | |
182 | ), | |
183 | qr/42/, | |
184 | "Recursive DB::DB does not clobber its own pad", | |
185 | ); | |
4e917a04 FC |
186 | |
187 | # [perl #118627] | |
188 | like( | |
189 | runperl( | |
190 | switches => [ '-Ilib', '-d:switchd_empty' ], | |
191 | prog => 'print @{q|_<-e|}', | |
192 | ), | |
193 | qr "use Devel::switchd_empty;(?:BEGIN|\r?\nprint)", | |
194 | # miniperl tacks a BEGIN block on to the same line | |
7b6fb0b8 | 195 | 'Copy on write does not mangle ${"_<-e"}[0] [perl #118627]', |
4e917a04 | 196 | ); |
fdc18556 FC |
197 | |
198 | # PERL5DB with embedded newlines | |
199 | { | |
7f1c3e8c FC |
200 | local $ENV{PERL5DB} = "sub DB::DB{}\nwarn"; |
201 | is( | |
fdc18556 FC |
202 | runperl( |
203 | switches => [ '-Ilib', '-ld' ], | |
7f1c3e8c | 204 | prog => 'warn', |
fdc18556 FC |
205 | stderr => 1 |
206 | ), | |
7f1c3e8c FC |
207 | "Warning: something's wrong.\n" |
208 | ."Warning: something's wrong at -e line 1.\n", | |
fdc18556 FC |
209 | 'PERL5DB with embedded newlines', |
210 | ); | |
211 | } | |
261cbad1 TC |
212 | |
213 | # test that DB::goto works | |
214 | is( | |
215 | runperl( | |
216 | switches => [ '-Ilib', '-d:switchd_goto' ], | |
cb7db709 | 217 | prog => 'sub baz { print qq|hello;\n| } sub foo { goto &baz } foo()', |
261cbad1 TC |
218 | stderr => 1, |
219 | ), | |
cb7db709 | 220 | "goto<main::baz>;hello;\n", |
261cbad1 TC |
221 | "DB::goto" |
222 | ); | |
07b605e5 FC |
223 | |
224 | # Test that %DB::lsub is not vivified | |
225 | is( | |
226 | runperl( | |
227 | switches => [ '-Ilib', '-d:switchd_empty' ], | |
228 | progs => ['sub DB::sub {} sub foo : lvalue {} foo();', | |
229 | 'print qq-ok\n- unless defined *DB::lsub{HASH}'], | |
230 | ), | |
231 | "ok\n", | |
232 | "%DB::lsub is not vivified" | |
233 | ); | |
43e4250a FC |
234 | |
235 | # Test setting of breakpoints without *DB::dbline aliased | |
236 | is( | |
237 | runperl( | |
238 | switches => [ '-Ilib', '-d:nodb' ], | |
239 | progs => [ split "\n", | |
240 | 'sub DB::DB { | |
241 | $DB::single = 0, return if $DB::single; print qq[ok\n]; exit | |
242 | } | |
243 | ${q(_<).__FILE__}{6} = 1; # set a breakpoint | |
244 | sub foo { | |
245 | die; # line 6 | |
246 | } | |
247 | foo(); | |
248 | ' | |
249 | ], | |
250 | stderr => 1 | |
251 | ), | |
252 | "ok\n", | |
253 | "setting breakpoints without *DB::dbline aliased" | |
254 | ); | |
90a04aed FC |
255 | |
256 | # [perl #121255] | |
257 | # Check that utf8 caches are flushed when $DB::sub is set | |
258 | is( | |
259 | runperl( | |
260 | switches => [ '-Ilib', '-d:switchd_empty' ], | |
261 | progs => [ split "\n", | |
262 | 'sub DB::sub{length($DB::sub); goto &$DB::sub} | |
263 | ${^UTF8CACHE}=-1; | |
264 | ||
265 | eval qq|sub oo\x{25f} { 42 } | |
266 | sub ooooo\x{25f} { oo\x{25f}() } | |
267 | ooooo\x{25f}()| | |
268 | || $@, | |
269 | qq|\n|; | |
270 | ' | |
271 | ], | |
272 | stderr => 1 | |
273 | ), | |
274 | "42\n", | |
275 | 'UTF8 length caches on $DB::sub are flushed' | |
276 | ); | |
4c627877 FC |
277 | |
278 | # [perl #122771] -d conflicting with sort optimisations | |
279 | is( | |
280 | runperl( | |
281 | switches => [ '-Ilib', '-d:switchd_empty' ], | |
282 | prog => 'BEGIN { $^P &= ~0x4 } sort { $$b <=> $$a } (); print qq-42\n-', | |
283 | ), | |
284 | "42\n", | |
285 | '-d does not conflict with sort optimisations' | |
286 | ); | |
2c2d7daa | 287 | |
177ee6a3 JH |
288 | SKIP: { |
289 | skip_if_miniperl("under miniperl", 1); | |
2c2d7daa TC |
290 | is( |
291 | runperl( | |
292 | switches => [ '-Ilib', '-d:switchd_empty' ], | |
293 | progs => [ split "\n", | |
294 | 'use bignum; | |
295 | $DB::single=2; | |
296 | print qq/debugged\n/; | |
297 | ' | |
298 | ], | |
299 | stderr => 1 | |
300 | ), | |
301 | "debugged\n", | |
302 | "\$DB::single set to overload" | |
303 | ); | |
177ee6a3 | 304 | } |
8d28fc8f MH |
305 | |
306 | # [perl #123748] | |
307 | # | |
308 | # On some platforms, it's possible that calls to getenv() will | |
309 | # return a pointer to statically allocated data that may be | |
310 | # overwritten by subsequent calls to getenv/putenv/setenv/unsetenv. | |
311 | # | |
312 | # In perl.c, s = PerlEnv_GetEnv("PERL5OPT") is called, and | |
313 | # then moreswitches(s), which, if -d:switchd_empty is given, | |
314 | # will call my_setenv("PERL5DB", "use Devel::switchd_empty"), | |
315 | # and then return to continue parsing s. | |
a60c8fb1 MH |
316 | # |
317 | # This may need -Accflags="-DPERL_USE_SAFE_PUTENV" to fail on | |
318 | # affected systems. | |
8d28fc8f MH |
319 | { |
320 | local $ENV{PERL5OPT} = '-d:switchd_empty'; | |
321 | ||
322 | like( | |
323 | runperl( | |
7f8f1c26 | 324 | switches => [ '-Ilib' ], prog => 'print q(hi)', |
8d28fc8f MH |
325 | ), |
326 | qr/hi/, | |
327 | 'putenv does not interfere with PERL5OPT parsing', | |
328 | ); | |
329 | } |