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