This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #122445] use magic on $DB::single etc to avoid overload issues
[perl5.git] / t / run / switchd.t
CommitLineData
d7aa4417
JH
1#!./perl -w
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = qw(../lib lib);
6}
7
768fd157 8BEGIN { require "./test.pl"; }
d7aa4417 9
be1cc451 10# This test depends on t/lib/Devel/switchd*.pm.
964b4e64 11
2c2d7daa 12plan(tests => 20);
d7aa4417
JH
13
14my $r;
d7aa4417 15
2d90ac95 16my $filename = tempfile();
d7aa4417
JH
17SKIP: {
18 open my $f, ">$filename"
19 or skip( "Can't write temp file $filename: $!" );
20 print $f <<'__SWDTEST__';
21package Bar;
22sub bar { $_[0] * $_[0] }
23package Foo;
24sub foo {
25 my $s;
26 $s += Bar::bar($_) for 1..$_[0];
27}
28package main;
29Foo::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,
39qr/^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,
47qr/^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,
55qr/^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]
60cmp_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
73like
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]
85like(
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]
100like(
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]
116like(
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]
132like(
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);
141like(
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
151is(
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
162like(
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]
189like(
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
215is(
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
226is(
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
237is(
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
259is(
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 print
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);
4c627877
FC
278
279# [perl #122771] -d conflicting with sort optimisations
280is(
281 runperl(
282 switches => [ '-Ilib', '-d:switchd_empty' ],
283 prog => 'BEGIN { $^P &= ~0x4 } sort { $$b <=> $$a } (); print qq-42\n-',
284 ),
285 "42\n",
286 '-d does not conflict with sort optimisations'
287);
2c2d7daa 288
2c2d7daa
TC
289is(
290 runperl(
291 switches => [ '-Ilib', '-d:switchd_empty' ],
292 progs => [ split "\n",
293 'use bignum;
294 $DB::single=2;
295 print qq/debugged\n/;
296 '
297 ],
298 stderr => 1
299 ),
300 "debugged\n",
301 "\$DB::single set to overload"
302);