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 => 10); 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 73# [perl #48332] 74like( 75 runperl( 76 switches => [ '-Ilib', '-d:switchd_empty' ], 77 progs => [ 78 'sub foo { print qq _1\n_ }', 79 '*old_foo = \&foo;', 80 '*foo = sub { print qq _2\n_ };', 81 'old_foo(); foo();', 82 ], 83 ), 84 qr "1\r?\n2\r?\n", 85 'Subroutine redefinition works in the debugger [perl #48332]', 86); 87 88# [rt.cpan.org #69862] 89like( 90 runperl( 91 switches => [ '-Ilib', '-d:switchd_empty' ], 92 progs => [ 93 'sub DB::sub { goto &$DB::sub }', 94 'sub foo { print qq _1\n_ }', 95 'sub bar { print qq _2\n_ }', 96 'delete $::{foo}; eval { foo() };', 97 'my $bar = *bar; undef *bar; eval { &$bar };', 98 ], 99 ), 100 qr "1\r?\n2\r?\n", 101 'Subroutines no longer found under their names can be called', 102); 103 104# [rt.cpan.org #69862] 105like( 106 runperl( 107 switches => [ '-Ilib', '-d:switchd_empty' ], 108 progs => [ 109 'sub DB::sub { goto &$DB::sub }', 110 'sub foo { goto &bar::baz; }', 111 'sub bar::baz { print qq _ok\n_ }', 112 'delete $::{bar::::};', 113 'foo();', 114 ], 115 ), 116 qr "ok\r?\n", 117 'No crash when calling orphaned subroutine via goto &', 118); 119 120# test when DB::DB is seen but not defined [perl #114990] 121like( 122 runperl( 123 switches => [ '-Ilib', '-d:nodb' ], 124 prog => [ '1' ], 125 stderr => 1, 126 ), 127 qr/^No DB::DB routine defined/, 128 "No crash when *DB::DB exists but not &DB::DB", 129); 130like( 131 runperl( 132 switches => [ '-Ilib' ], 133 prog => 'sub DB::DB; BEGIN { $^P = 0x22; } for(0..9){ warn }', 134 stderr => 1, 135 ), 136 qr/^No DB::DB routine defined/, 137 "No crash when &DB::DB exists but isn't actually defined", 138); 139 140# [perl #115742] Recursive DB::DB clobbering its own pad 141like( 142 runperl( 143 switches => [ '-Ilib' ], 144 progs => [ split "\n", <<'=' 145 BEGIN { 146 $^P = 0x22; 147 } 148 package DB; 149 sub DB { 150 my $x = 42; 151 return if $__++; 152 $^D |= 1 << 30; # allow recursive calls 153 main::foo(); 154 print $x//q-u-, qq-\n-; 155 } 156 package main; 157 chop; 158 sub foo { chop; } 159= 160 ], 161 stderr => 1, 162 ), 163 qr/42/, 164 "Recursive DB::DB does not clobber its own pad", 165); 166