t/run/switchd.t

   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 => 20);
  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 );
 278
 279 # [perl #122771] -d conflicting with sort optimisations
 280 is(
 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 is(
 290   runperl(
 291    switches => [ '-Ilib', '-d:switchd_empty' ],
 292    progs => [ split "\n",
 293     'use bignum;
 294      $DB::single=2;
 295      print qq/debugged\n/;
 296     '
 297    ],
 298    stderr => 1
 299   ),
 300   "debugged\n",
 301   "\$DB::single set to overload"
 302 );