BEGIN {
chdir 't' if -d 't';
@INC = qw(../lib lib);
+ require "./test.pl";
}
-BEGIN { require "./test.pl"; }
-
# This test depends on t/lib/Devel/switchd*.pm.
-plan(tests => 13);
+plan(tests => 21);
my $r;
qr/^No DB::DB routine defined/,
"No crash when &DB::DB exists but isn't actually defined",
);
+# or seen and defined later
+is(
+ runperl(
+ switches => [ '-Ilib', '-d:nodb' ], # nodb.pm contains *DB::DB...if 0
+ prog => 'warn; sub DB::DB { print qq-ok\n-; exit }',
+ stderr => 1,
+ ),
+ "ok\n",
+ "DB::DB works after '*DB::DB if 0'",
+);
# [perl #115742] Recursive DB::DB clobbering its own pad
like(
'PERL5DB with embedded newlines',
);
}
+
+# test that DB::goto works
+is(
+ runperl(
+ switches => [ '-Ilib', '-d:switchd_goto' ],
+ prog => 'sub baz { print qq|hello;\n| } sub foo { goto &baz } foo()',
+ stderr => 1,
+ ),
+ "goto<main::baz>;hello;\n",
+ "DB::goto"
+);
+
+# Test that %DB::lsub is not vivified
+is(
+ runperl(
+ switches => [ '-Ilib', '-d:switchd_empty' ],
+ progs => ['sub DB::sub {} sub foo : lvalue {} foo();',
+ 'print qq-ok\n- unless defined *DB::lsub{HASH}'],
+ ),
+ "ok\n",
+ "%DB::lsub is not vivified"
+);
+
+# Test setting of breakpoints without *DB::dbline aliased
+is(
+ runperl(
+ switches => [ '-Ilib', '-d:nodb' ],
+ progs => [ split "\n",
+ 'sub DB::DB {
+ $DB::single = 0, return if $DB::single; print qq[ok\n]; exit
+ }
+ ${q(_<).__FILE__}{6} = 1; # set a breakpoint
+ sub foo {
+ die; # line 6
+ }
+ foo();
+ '
+ ],
+ stderr => 1
+ ),
+ "ok\n",
+ "setting breakpoints without *DB::dbline aliased"
+);
+
+# [perl #121255]
+# Check that utf8 caches are flushed when $DB::sub is set
+is(
+ runperl(
+ switches => [ '-Ilib', '-d:switchd_empty' ],
+ progs => [ split "\n",
+ 'sub DB::sub{length($DB::sub); goto &$DB::sub}
+ ${^UTF8CACHE}=-1;
+ print
+ eval qq|sub oo\x{25f} { 42 }
+ sub ooooo\x{25f} { oo\x{25f}() }
+ ooooo\x{25f}()|
+ || $@,
+ qq|\n|;
+ '
+ ],
+ stderr => 1
+ ),
+ "42\n",
+ 'UTF8 length caches on $DB::sub are flushed'
+);
+
+# [perl #122771] -d conflicting with sort optimisations
+is(
+ runperl(
+ switches => [ '-Ilib', '-d:switchd_empty' ],
+ prog => 'BEGIN { $^P &= ~0x4 } sort { $$b <=> $$a } (); print qq-42\n-',
+ ),
+ "42\n",
+ '-d does not conflict with sort optimisations'
+);
+
+SKIP: {
+ skip_if_miniperl("under miniperl", 1);
+is(
+ runperl(
+ switches => [ '-Ilib', '-d:switchd_empty' ],
+ progs => [ split "\n",
+ 'use bignum;
+ $DB::single=2;
+ print qq/debugged\n/;
+ '
+ ],
+ stderr => 1
+ ),
+ "debugged\n",
+ "\$DB::single set to overload"
+);
+}
+
+# [perl #123748]
+#
+# On some platforms, it's possible that calls to getenv() will
+# return a pointer to statically allocated data that may be
+# overwritten by subsequent calls to getenv/putenv/setenv/unsetenv.
+#
+# In perl.c, s = PerlEnv_GetEnv("PERL5OPT") is called, and
+# then moreswitches(s), which, if -d:switchd_empty is given,
+# will call my_setenv("PERL5DB", "use Devel::switchd_empty"),
+# and then return to continue parsing s.
+#
+# This may need -Accflags="-DPERL_USE_SAFE_PUTENV" to fail on
+# affected systems.
+{
+local $ENV{PERL5OPT} = '-d:switchd_empty';
+
+like(
+ runperl(
+ switches => [ '-Ilib' ], prog => 'print q(hi)',
+ ),
+ qr/hi/,
+ 'putenv does not interfere with PERL5OPT parsing',
+);
+}