| 1 | #!./perl -w |
| 2 | |
| 3 | BEGIN { |
| 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 | |
| 11 | plan(tests => 21); |
| 12 | |
| 13 | my $r; |
| 14 | |
| 15 | my $filename = tempfile(); |
| 16 | SKIP: { |
| 17 | open my $f, ">$filename" |
| 18 | or skip( "Can't write temp file $filename: $!" ); |
| 19 | print $f <<'__SWDTEST__'; |
| 20 | package Bar; |
| 21 | sub bar { $_[0] * $_[0] } |
| 22 | package Foo; |
| 23 | sub foo { |
| 24 | my $s; |
| 25 | $s += Bar::bar($_) for 1..$_[0]; |
| 26 | } |
| 27 | package main; |
| 28 | Foo::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, |
| 38 | 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>;$/, |
| 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, |
| 46 | 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>;$/, |
| 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, |
| 54 | 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>;$/, |
| 55 | 'Got debugging output: 3'); |
| 56 | } |
| 57 | |
| 58 | # [perl #71806] |
| 59 | cmp_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 | |
| 72 | like |
| 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] |
| 84 | like( |
| 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] |
| 99 | like( |
| 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] |
| 115 | like( |
| 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] |
| 131 | like( |
| 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 | ); |
| 140 | like( |
| 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 |
| 150 | is( |
| 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 |
| 161 | like( |
| 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] |
| 188 | like( |
| 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 |
| 214 | is( |
| 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 |
| 225 | is( |
| 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 |
| 236 | is( |
| 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 |
| 258 | is( |
| 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 |
| 279 | is( |
| 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 | |
| 288 | SKIP: { |
| 289 | skip_if_miniperl("under miniperl", 1); |
| 290 | is( |
| 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 | { |
| 320 | local $ENV{PERL5OPT} = '-d:switchd_empty'; |
| 321 | |
| 322 | like( |
| 323 | runperl( |
| 324 | switches => [ '-Ilib' ], prog => 'print q(hi)', |
| 325 | ), |
| 326 | qr/hi/, |
| 327 | 'putenv does not interfere with PERL5OPT parsing', |
| 328 | ); |
| 329 | } |