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 => 11);
  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 # [perl #48332]
  74 like(
  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]
  89 like(
  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]
 105 like(
 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]
 121 like(
 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 );
 130 like(
 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
 141 like(
 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
 167 # [perl #118627]
 168 like(
 169   runperl(
 170    switches => [ '-Ilib', '-d:switchd_empty' ],
 171    prog     => 'print @{q|_<-e|}',
 172   ),
 173   qr "use Devel::switchd_empty;(?:BEGIN|\r?\nprint)",
 174                          # miniperl tacks a BEGIN block on to the same line
 175  'Copy on write does not mangle ${"_<-e"}[0] [perl #118627]',
 176 );