view release on metacpan or  search on metacpan

PadWalker.xs  view on Meta::CPAN

CV *
up_cv(pTHX_ I32 uplevel, const char * caller_name)
{
    PERL_CONTEXT *cx, *ccstack;
    I32 cxix_from, cxix_to, i;

    if (uplevel < 0)
      croak("%s: sub is < 0", caller_name);

    cx = upcontext(aTHX_ uplevel, 0, &ccstack, &cxix_from, &cxix_to);
    if (cx == (PERL_CONTEXT *)-1) {
      croak("%s: Not nested deeply enough", caller_name);
      return 0;  /* NOT REACHED, but stop picky compilers from whining */
    }
    else if (cx)
      return cx->blk_sub.cv;
      
    else {

      for (i = cxix_from-1; i > cxix_to; --i)
        if (CxTYPE(&ccstack[i]) == CXt_EVAL) {
          I32 old_op_type = CxOLD_OP_TYPE(&ccstack[i]);
          if (old_op_type == OP_REQUIRE || old_op_type == OP_DOFILE)
            return ccstack[i].blk_eval.cv;
        }

      return PL_main_cv;
    }
}

STATIC bool
is_scalar_type(SV *sv) {
    return !(
        SvTYPE(sv) == SVt_PVAV
     || SvTYPE(sv) == SVt_PVHV
     || SvTYPE(sv) == SVt_PVCV
     || isGV_with_GP(sv)
     || SvTYPE(sv) == SVt_PVIO
   );
}

STATIC bool
is_correct_type(SV *orig, SV *restore) {
    return (
        ( SvTYPE(orig) == SvTYPE(restore) )
            ||
        ( is_scalar_type(orig) && is_scalar_type(restore) )
    );
}


MODULE = PadWalker              PACKAGE = PadWalker
PROTOTYPES: DISABLE             

void
peek_my(uplevel)
I32 uplevel;
 PREINIT:
    HV* ret = newHV();
    HV* ignore = newHV();
 PPCODE:
    do_peek(aTHX_ uplevel, ret, ignore);
    SvREFCNT_dec((SV*) ignore);
    EXTEND(SP, 1);
    PUSHs(sv_2mortal(newRV_noinc((SV*)ret)));

void
peek_our(uplevel)
I32 uplevel;
 PREINIT:
    HV* ret = newHV();
    HV* ignore = newHV();
 PPCODE:
    do_peek(aTHX_ uplevel, ignore, ret);
    SvREFCNT_dec((SV*) ignore);
    EXTEND(SP, 1);
    PUSHs(sv_2mortal(newRV_noinc((SV*)ret)));


void
peek_sub(cv)
CV* cv;
  PREINIT:
    HV* ret = newHV();
    HV* ignore = newHV();
  PPCODE:
    if (CvISXSUB(cv))
      die("PadWalker: cv has no padlist");
    padlist_into_hash(aTHX_ CvPADLIST(cv), ret, ignore, 0, CvDEPTH(cv));
    SvREFCNT_dec((SV*) ignore);
    EXTEND(SP, 1);
    PUSHs(sv_2mortal(newRV_noinc((SV*)ret)));

void
set_closed_over(sv, pad)
SV* sv;
HV* pad;
  PREINIT:
    I32 i;
    CV *cv = (CV *)SvRV(sv);
    U32 val_depth = CvDEPTH(cv) ? CvDEPTH(cv) : 1;
    PADNAMELIST *pad_namelist = PadlistNAMES(CvPADLIST(cv));
    PAD *pad_vallist  = PadlistARRAY(CvPADLIST(cv))[val_depth];
  CODE:
    for (i=PadnamelistMAX(pad_namelist); i>=0; --i) {
      PADNAME* name = PadnamelistARRAY(pad_namelist)[i];
      char* name_str;

      if (name && (name_str = PadnamePV(name))) {
        STRLEN name_len = strlen(name_str);

        if (PadnameOUTER(name) && !PadnameIsOUR(name)) {
          SV **restore_ref = hv_fetch(pad, name_str, name_len, FALSE);
          if ( restore_ref ) {
            if ( SvROK(*restore_ref) ) {
              SV *restore = SvRV(*restore_ref);
              SV *orig = PadARRAY(pad_vallist)[i];
              int restore_type = SvTYPE(restore);

              if ( !orig || is_correct_type(orig, restore) ) {
                SvREFCNT_inc(restore);

                PadARRAY(pad_vallist)[i] = restore;
              } else {
                croak("Incorrect reftype for variable %s (got %s expected %s)", name_str, sv_reftype(restore, 0), sv_reftype(orig, 0));
              }
            } else {
              croak("The variable for %s is not a reference", name_str);
            }
          }
        }
      }
    }



void
closed_over(cv)
CV* cv;
  PREINIT:
    HV* ret = newHV();
    HV* targs;
  PPCODE:
    if (GIMME_V == G_ARRAY) {
        targs = newHV();
        get_closed_over(aTHX_ cv, ret, targs);
    
        EXTEND(SP, 2);
        PUSHs(sv_2mortal(newRV_noinc((SV*)ret)));
        PUSHs(sv_2mortal(newRV_noinc((SV*)targs)));
    }
    else {
        get_closed_over(aTHX_ cv, ret, 0);
        
        EXTEND(SP, 1);
        PUSHs(sv_2mortal(newRV_noinc((SV*)ret)));
    }

char*
var_name(sub, var_ref)
SV* sub;
SV* var_ref;
  PREINIT:
    SV *cv;
  CODE:
    if (!SvROK(var_ref))
      croak("Usage: PadWalker::var_name(sub, var_ref)");
      
    if (SvROK(sub)) {
      cv = SvRV(sub);
      if (SvTYPE(cv) != SVt_PVCV)
        croak("PadWalker::var_name: sub is neither a CODE reference nor a number");
    } else
      cv = (SV *) up_cv(aTHX_ SvIV(sub), "PadWalker::upcontext");
    
    RETVAL = get_var_name((CV *) cv, SvRV(var_ref));
  OUTPUT:
    RETVAL

void
_upcontext(uplevel)
I32 uplevel
  PPCODE:
    /* This is used by Devel::Caller. */
    XPUSHs(sv_2mortal(newSViv((IV)upcontext(aTHX_ uplevel, 0, 0, 0, 0))));