t/run/switchd.t

   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 }