view release on metacpan or  search on metacpan

perl5db.xs  view on Meta::CPAN

    /* $single |= 4 if $#stack == $deep */
    if (current_depth == SvIV(MY_CXT.deep))
        single = single | 4;
    PL_DBsingle_iv_set(aTHX_ single);

    {
        HV *stash = CopSTASH(PL_curcop);
        STRLEN len = HvNAMELEN_get(stash);
        const char *name = HvNAME(stash);

        if (len > 4 && strncmp(name, "DB::", 4) == 0)
            in_debugger = TRUE;
    }

    /* check function call breakpoint */
    if (!in_debugger)
        try_breaking(aTHX_ aMY_CXT_ GvSV(PL_DBsub), "call");

    return in_debugger;
}

static void after_call(pTHX_ pMY_CXT_ bool in_debugger, int current_depth) {
    /* $single |= $stack[$stack_depth] */
    {
        SV **top = av_fetch(MY_CXT.stack, current_depth, 0);

        PL_DBsingle_iv_set(aTHX_ PL_DBsingle_iv | SvIV(*top));
    }

    /* check function return breakpoint */
    if (!in_debugger)
        try_breaking(aTHX_ aMY_CXT_ GvSV(PL_DBsub), "return");
}

MODULE=dbgp_helper::perl5db PACKAGE=DB::XS

void
sub_xs(...)
  PREINIT:
    dMY_CXT;
  /* needs a separate CV so we can set the LVALUE flag */
  ALIAS:
    lsub_xs = 1
  INIT:
    SV *sub = GvSV(PL_DBsub);
    IV current_depth = SvIV(GvSVn(MY_CXT.stack_depth)) + 1;
    I32 context = GIMME_V;
    /*
       If the original sub was called with the &foo syntax,
       add G_NOARGS to the call_sv() call, so @_ is not copied,
       and the callee can modify it.

       DB::sub (Perl) does this for all calls, because it's written in
       Perl, so @_ is always there, but when DB::XS::sub is called,
       @_ is not set up, because the sub is an XS.
     */
    I32 noargs = (PL_op->op_flags & OPf_STACKED) ? 0 : G_NOARGS;
    bool in_debugger;
    int retcount;
  PPCODE:
    /*
        We're passing through our arguments unmodified, so we can
        re-push them in place, or just restore the MARK declared by
        the implicit dXSARGS, and get the non-adjusted stack pointer
        from the interpreter global.
     */
    PUSHMARK(MARK);
    /* not needed right now, added just in case */
    SPAGAIN;

    in_debugger = before_call(aTHX_ aMY_CXT_ current_depth);
    retcount = call_sv(sub, context | noargs | G_NODEBUG);
    after_call(aTHX_ aMY_CXT_ in_debugger, current_depth);

    /*
       The global stack pointer is already at the right place, so we
       refresh our local copy so the implict PUTBACK at the end is a
       no-op. We could also do XSRETURN(retcount)
     */
    SPAGAIN;

void
setup_lexicals(SV *ldebug, SV *stack, SV *deep, SV *fq_function_names)
  PREINIT:
    dMY_CXT;
  CODE:
    MY_CXT.ldebug = SvRV(ldebug);
    MY_CXT.stack = (AV *) SvRV(stack);
    MY_CXT.deep = SvRV(deep);
    MY_CXT.fq_function_names = (HV *) SvRV(fq_function_names);

void
CLONE(...)
  CODE:
    MY_CXT_CLONE;
    reinit_my_cxt(aTHX_ aMY_CXT);

BOOT:
    MY_CXT_INIT;
    reinit_my_cxt(aTHX_ aMY_CXT);

    CvLVALUE_on(get_cv("DB::XS::lsub_xs", 0));