perl/t/op/debug.t

#!./perl

# intended for testing language mechanisms that debuggers use not for
# testing the debugger itself

BEGIN {
    chdir 't' if -d 't';
    require "./test.pl";
    set_up_inc( qw(. ../lib) );
}

use strict;
use warnings;

SKIP:
{
    skip_if_miniperl("need XS", 1);
    # github 23151
    # trivial debugger
    local $ENV{PERL5DB} = 'sub DB::DB {}';
    # eval code trimmed from code generated by Sub::Quote
    fresh_perl_is(<<'CODE', <<'EXPECT',
use B qw(SVf_IOK);

sub _do_eval {
  eval $_[0] or die $!;
}

_do_eval(<<'EVAL');
{
  sub table {
  }
}
1;
EVAL

# look for lines that don't have an IV set
my ($f) = grep /\(eval/, keys %::;
my $x = $::{$f};
my $lineno = 0;
for my $l (@$x) {
  if ($l) {
    my $b = B::svref_2object(\$l);
    if (!($b->FLAGS & SVf_IOK)) {
      print "No IV for $f line $lineno: $l\n";
      last
    }
  }
  ++$lineno;
}

print "Done\n";
CODE
Done
EXPECT
                  {
                      switches => [ '-d' ],
                      stderr => 1,
                  },
                  "saved lines all have an IV"
                  );
}

SKIP:
{
    # Historically lines were stored as PVMG, but we don't need
    # magic on these lines.
    #
    # This checks that none of these lines get upgraded, ie. that
    # we don't need them to be PVMG
    #
    # If this test fails perhaps we do need to make them PVMG
    # and toke.c:S_update_debugger_info and pp_ctl.c:S_save_lines
    # can be switched back to using SVt_PVMG and this test
    # removed.
    #
    # See https://github.com/Perl/perl5/pull/23171#issuecomment-2780007725
    skip_if_miniperl("need B");
    local $ENV{PERL5DB} = 'sub DB::DB {}';
    fresh_perl_is(<<'CODE', <<'EXPECT',
use B;

sub _do_eval {
  eval $_[0] or die $!;
}

_do_eval(<<'EVAL');

sub some_code {
   print "Hello";
}

1;
EVAL

# check if any lines have been upgraded from PVIV
my @files = grep /^_</, keys %::;
for my $f (@files) {
    my $lineno = 0;

    for my $l (@{$f}) {
        if ($l) {
            my $b = B::svref_2object(\$l);
            if (ref $b ne "B::PVIV") {
               print "Not PVIV for $f:$lineno: $l\n";
               last
            }
        }
        ++$lineno;
    }
}
print "Done\n";
CODE
Done
EXPECT
                  {
                      switches => [ '-d' ],
                      stderr => 1,
                  },
                  "saved lines are all PVIV"
                  );
}

{
    # GH 24001
    local $ENV{PERL5DB} = 'sub DB::DB {}';
    fresh_perl_is(<<'CODE', "OK\n",
package DB;
sub DB::sub {
    # avoid deep recursion
    die "Fail" if $DB::sub =~ /^version::/;
    # trigger overloading call from package DB
    my $v = "$^V";
    print $v ne "" ? "OK\n" : ""
}
package main;
sub f {
}
f();
CODE
                  {
                      switches => [ '-d' ],
                  },
                  "overloading call from DB doesn't break into DB::sub");
}
{
    local $ENV{PERL5DB} = 'sub DB::DB {}';
    # make sure we don't break the expected break
    fresh_perl_is(<<'CODE', "OK\n",
package DB;
sub DB::sub {
    our @count;
    if ($DB::sub eq 'version::(""') {
        print "OK\n";
        exit;
    }
    push @count, $DB::sub;
    die "Fail @count\n" if @count > 10;
    &$DB::sub;
}
package main;
sub f {
    my $v = "$^V";
}
f();
CODE
                  {
                      switches => [ '-d' ],
                  },
                  "overloading call from non-DB does break into DB::sub");
}

done_testing();