| 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 => 18); |
| 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 | ); |