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
1 #!./perl -w
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = qw(../lib lib);
6 }
7
8 BEGIN { require "./test.pl"; }
9
10 # This test depends on t/lib/Devel/switchd*.pm.
11
12 plan(tests => 20);
13
14 my $r;
15
16 my $filename = tempfile();
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;
32     $| = 1; # Unbufferize.
33     $r = runperl(
34                  switches => [ '-Ilib', '-f', '-d:switchd' ],
35                  progfile => $filename,
36                  args => ['3'],
37                 );
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');
41     $r = runperl(
42                  switches => [ '-Ilib', '-f', '-d:switchd=a,42' ],
43                  progfile => $filename,
44                  args => ['4'],
45                 );
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');
49     $r = runperl(
50                  switches => [ '-Ilib', '-f', '-d:-switchd=a,42' ],
51                  progfile => $filename,
52                  args => ['4'],
53                 );
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');
57 }
58
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 );
72
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
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 );
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 );
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 );
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/,
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",
149 );
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 );
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 );
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
196  'Copy on write does not mangle ${"_<-e"}[0] [perl #118627]',
197 );
198
199 # PERL5DB with embedded newlines
200 {
201     local $ENV{PERL5DB} = "sub DB::DB{}\nwarn";
202     is(
203       runperl(
204        switches => [ '-Ilib', '-ld' ],
205        prog     => 'warn',
206        stderr   => 1
207       ),
208       "Warning: something's wrong.\n"
209      ."Warning: something's wrong at -e line 1.\n",
210      'PERL5DB with embedded newlines',
211     );
212 }
213
214 # test that DB::goto works
215 is(
216   runperl(
217    switches => [ '-Ilib', '-d:switchd_goto' ],
218    prog => 'sub baz { print qq|hello;\n| } sub foo { goto &baz } foo()',
219    stderr => 1,
220   ),
221   "goto<main::baz>;hello;\n",
222   "DB::goto"
223 );
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 );
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 );
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      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 );
278
279 # [perl #122771] -d conflicting with sort optimisations
280 is(
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 );
288
289 is(
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 );