1#!./perl -w 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = qw(../lib lib); 6} 7 8BEGIN { require "./test.pl"; } 9 10# This test depends on t/lib/Devel/switchd*.pm. 11 12plan(tests => 20); 13 14my $r; 15 16my $filename = tempfile(); 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; 32 $| = 1; # Unbufferize. 33 $r = runperl( 34 switches => [ '-Ilib', '-f', '-d:switchd' ], 35 progfile => $filename, 36 args => ['3'], 37 ); 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'); 41 $r = runperl( 42 switches => [ '-Ilib', '-f', '-d:switchd=a,42' ], 43 progfile => $filename, 44 args => ['4'], 45 ); 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'); 49 $r = runperl( 50 switches => [ '-Ilib', '-f', '-d:-switchd=a,42' ], 51 progfile => $filename, 52 args => ['4'], 53 ); 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'); 57} 58 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); 72 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 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); 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); 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); 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/, 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", 149); 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); 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); 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 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 215is( 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 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); 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); 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); 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); 288 289# [perl #123748] 290# 291# On some platforms, it's possible that calls to getenv() will 292# return a pointer to statically allocated data that may be 293# overwritten by subsequent calls to getenv/putenv/setenv/unsetenv. 294# 295# In perl.c, s = PerlEnv_GetEnv("PERL5OPT") is called, and 296# then moreswitches(s), which, if -d:switchd_empty is given, 297# will call my_setenv("PERL5DB", "use Devel::switchd_empty"), 298# and then return to continue parsing s. 299{ 300local $ENV{PERL5OPT} = '-d:switchd_empty'; 301 302like( 303 runperl( 304 switches => [ '-Ilib' ], prog => 'print q(hi)', 305 ), 306 qr/hi/, 307 'putenv does not interfere with PERL5OPT parsing', 308); 309} 310