1#!./perl -w 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = qw(../lib lib); 6 require "./test.pl"; 7} 8 9# This test depends on t/lib/Devel/switchd*.pm. 10 11plan(tests => 21); 12 13my $r; 14 15my $filename = tempfile(); 16SKIP: { 17 open my $f, ">$filename" 18 or skip( "Can't write temp file $filename: $!" ); 19 print $f <<'__SWDTEST__'; 20package Bar; 21sub bar { $_[0] * $_[0] } 22package Foo; 23sub foo { 24 my $s; 25 $s += Bar::bar($_) for 1..$_[0]; 26} 27package main; 28Foo::foo(3); 29__SWDTEST__ 30 close $f; 31 $| = 1; # Unbufferize. 32 $r = runperl( 33 switches => [ '-Ilib', '-f', '-d:switchd' ], 34 progfile => $filename, 35 args => ['3'], 36 ); 37 like($r, 38qr/^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'); 40 $r = runperl( 41 switches => [ '-Ilib', '-f', '-d:switchd=a,42' ], 42 progfile => $filename, 43 args => ['4'], 44 ); 45 like($r, 46qr/^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'); 48 $r = runperl( 49 switches => [ '-Ilib', '-f', '-d:-switchd=a,42' ], 50 progfile => $filename, 51 args => ['4'], 52 ); 53 like($r, 54qr/^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'); 56} 57 58# [perl #71806] 59cmp_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); 71 72like 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 83# [perl #48332] 84like( 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); 97 98# [rt.cpan.org #69862] 99like( 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); 113 114# [rt.cpan.org #69862] 115like( 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); 129 130# test when DB::DB is seen but not defined [perl #114990] 131like( 132 runperl( 133 switches => [ '-Ilib', '-d:nodb' ], 134 prog => [ '1' ], 135 stderr => 1, 136 ), 137 qr/^No DB::DB routine defined/, 138 "No crash when *DB::DB exists but not &DB::DB", 139); 140like( 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", 148); 149# or seen and defined later 150is( 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); 159 160# [perl #115742] Recursive DB::DB clobbering its own pad 161like( 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); 186 187# [perl #118627] 188like( 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 195 'Copy on write does not mangle ${"_<-e"}[0] [perl #118627]', 196); 197 198# PERL5DB with embedded newlines 199{ 200 local $ENV{PERL5DB} = "sub DB::DB{}\nwarn"; 201 is( 202 runperl( 203 switches => [ '-Ilib', '-ld' ], 204 prog => 'warn', 205 stderr => 1 206 ), 207 "Warning: something's wrong.\n" 208 ."Warning: something's wrong at -e line 1.\n", 209 'PERL5DB with embedded newlines', 210 ); 211} 212 213# test that DB::goto works 214is( 215 runperl( 216 switches => [ '-Ilib', '-d:switchd_goto' ], 217 prog => 'sub baz { print qq|hello;\n| } sub foo { goto &baz } foo()', 218 stderr => 1, 219 ), 220 "goto<main::baz>;hello;\n", 221 "DB::goto" 222); 223 224# Test that %DB::lsub is not vivified 225is( 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); 234 235# Test setting of breakpoints without *DB::dbline aliased 236is( 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); 255 256# [perl #121255] 257# Check that utf8 caches are flushed when $DB::sub is set 258is( 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 print 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); 277 278# [perl #122771] -d conflicting with sort optimisations 279is( 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); 287 288SKIP: { 289 skip_if_miniperl("under miniperl", 1); 290is( 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); 304} 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. 316# 317# This may need -Accflags="-DPERL_USE_SAFE_PUTENV" to fail on 318# affected systems. 319{ 320local $ENV{PERL5OPT} = '-d:switchd_empty'; 321 322like( 323 runperl( 324 switches => [ '-Ilib' ], prog => 'print q(hi)', 325 ), 326 qr/hi/, 327 'putenv does not interfere with PERL5OPT parsing', 328); 329} 330