Object-Pad

 view release on metacpan or  search on metacpan

lib/Object/Pad.xs  view on Meta::CPAN

#include "XSParseSublike.h"

#include "perl-backcompat.c.inc"

#ifdef HAVE_DMD_HELPER
#  define WANT_DMD_API_044
#  include "DMD_helper.h"
#endif

#include "perl-additions.c.inc"
#include "lexer-additions.c.inc"
#include "exec_optree.c.inc"
#include "forbid_outofblock_ops.c.inc"
#include "optree-additions.c.inc"
#include "newMYCONSTSUB.c.inc"
#include "newOP_CUSTOM.c.inc"

#if HAVE_PERL_VERSION(5, 26, 0)
#  define HAVE_PARSE_SUBSIGNATURE
#endif

#if HAVE_PERL_VERSION(5, 28, 0)
#  define HAVE_UNOP_AUX_PV
#endif

#include "object_pad.h"
#include "class.h"
#include "field.h"

#define warn_deprecated(...)  Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED), __VA_ARGS__)

typedef void MethodAttributeHandler(pTHX_ MethodMeta *meta, const char *value, void *data);

struct MethodAttributeDefinition {
  char *attrname;
  /* TODO: int flags */
  MethodAttributeHandler *apply;
  void *applydata;
};

/**********************************
 * Class and Field Implementation *
 **********************************/

void ObjectPad_extend_pad_vars(pTHX_ const ClassMeta *meta)
{
  PADOFFSET padix;

  padix = pad_add_name_pvs("$self", 0, NULL, NULL);
  if(padix != PADIX_SELF)
    croak("ARGH: Expected that padix[$self] = 1");

  /* Give it a name that isn't valid as a Perl variable so it can't collide */
  padix = pad_add_name_pvs("@(Object::Pad/fields)", 0, NULL, NULL);
  if(padix != PADIX_FIELDS)
    croak("ARGH: Expected that padix[@fields] = 2");

  if(meta->type == METATYPE_ROLE) {
    /* Don't give this a padname or Future::AsyncAwait will break it (RT137649) */
    padix = pad_add_name_pvs("", 0, NULL, NULL);
    if(padix != PADIX_EMBEDDING)
      croak("ARGH: Expected that padix[(embedding)] = 3");
  }
}

static void S_freepadsv(pTHX_ PADOFFSET padix)
{
  SvREFCNT_dec(PAD_SVl(padix));
  PAD_SVl(padix) = NULL;
}
#define SAVEFREEPADSV(padix)  SAVEDESTRUCTOR_X(S_freepadsv, (void *)(padix))

#define bind_field_to_pad(sv, fieldix, private, padix)  S_bind_field_to_pad(aTHX_ sv, fieldix, private, padix)
static void S_bind_field_to_pad(pTHX_ SV *sv, FIELDOFFSET fieldix, U8 private, PADOFFSET padix)
{
  SV *val;
  switch(private) {
    case OPpFIELDPAD_SV:
      val = sv;
      break;
    case OPpFIELDPAD_AV:
      if(!SvROK(sv) || SvTYPE(val = SvRV(sv)) != SVt_PVAV)
        croak("ARGH: expected to find an ARRAY reference at field index %ld", (long int)fieldix);
      break;
    case OPpFIELDPAD_HV:
      if(!SvROK(sv) || SvTYPE(val = SvRV(sv)) != SVt_PVHV)
        croak("ARGH: expected to find a HASH reference at field index %ld", (long int)fieldix);
      break;
    default:
      croak("ARGH: unsure what to do with this field type");
  }

  SAVESPTR(PAD_SVl(padix));
  PAD_SVl(padix) = SvREFCNT_inc(val);
  SAVEFREEPADSV(padix);
}

#define methstart_common(is_role)  S_methstart_common(aTHX_ is_role)
static void S_methstart_common(pTHX_ bool is_role)
{
  bool create = PL_op->op_flags & OPf_MOD;
  bool do_shift = PL_op->op_flags & OPf_STACKED;

  SV *self;
  if(do_shift)
    self = av_shift(GvAV(PL_defgv));
  else
    self = PAD_SVl(PADIX_SELF);

  if(!SvROK(self) || !SvOBJECT(SvRV(self)))
    croak("Cannot invoke method on a non-instance");

  HV *classstash;
  FIELDOFFSET offset;
  RoleEmbedding *embedding = NULL;

  if(is_role) {
    /* Embedding info is stored in pad1; PAD_SVl() will look at CvDEPTH. We'll
     * have to grab it manually */
    PAD *pad1 = PadlistARRAY(CvPADLIST(find_runcv(0)))[1];
    SV *embeddingsv = PadARRAY(pad1)[PADIX_EMBEDDING];

    /* We should never see NULL */
    assert(embeddingsv);

    if(SvTYPE(embeddingsv) == SVt_PVHV) {
      HV *applied_classes = (HV *)embeddingsv;
      HV *stash = SvSTASH(SvRV(self));

      if(stash == CvSTASH(find_runcv(0)))
        croak("Cannot invoke a role method directly");

      AV *isa = mro_get_linear_isa(stash);

      for(UV idx = 0; idx < av_count(isa); idx++) {
        HE *he = hv_fetch_ent(applied_classes, AvARRAY(isa)[idx], 0, 0);
        if(!he)
          continue;

        /* HeVAL is a RoleEmbedding * directly */
        embedding = MUST_ROLEEMBEDDING(HeVAL(he));
        break;
      }

      if(!embedding)
        croak("Could not find embedding info for %" HEKf " in applied classes map",
          HEKfARG(HvNAME_HEK(stash)));
    }
    else {
      embedding = MUST_ROLEEMBEDDING(SvPVX(embeddingsv));
    }

    if(embedding == &ObjectPad__embedding_standalone) {
      classstash = NULL;
      offset     = 0;
    }
    else {
      classstash = embedding->classmeta->stash;
      offset     = embedding->offset;
    }
  }
  else {
    classstash = CvSTASH(find_runcv(0));
    offset     = 0;
  }

  if(classstash) {
    if(!sv_derived_from_hv(self, classstash))
      croak("Cannot invoke foreign method on non-derived instance");
  }

  if(do_shift) {
    save_clearsv(&PAD_SVl(PADIX_SELF));
    sv_setsv(PAD_SVl(PADIX_SELF), self);
  }

  SV *fieldstore;

  if(is_role) {
    if(embedding == &ObjectPad__embedding_standalone) {
      fieldstore = NULL;
    }
    else {
      fieldstore = get_obj_fieldstore(self, embedding->classmeta->repr, create);
    }
  }
  else {
    /* op_private contains the repr type so we can extract backing */
    fieldstore = get_obj_fieldstore(self, PL_op->op_private, create);
  }

  if(fieldstore) {
    SAVESPTR(PAD_SVl(PADIX_FIELDS));
    PAD_SVl(PADIX_FIELDS) = SvREFCNT_inc(fieldstore);
    SAVEFREEPADSV(PADIX_FIELDS);
  }

  UNOP_AUX_item *aux = cUNOP_AUX->op_aux;
  if(aux) {
    U32 fieldcount  = (aux++)->uv;
    U32 max_fieldix = (aux++)->uv;
    SV **fieldsvs = fieldstore_fields(fieldstore);

    if(max_fieldix + offset > fieldstore_maxfield(fieldstore))
      croak("ARGH: instance does not have a field at index %ld", (long int)max_fieldix);

    while(fieldcount) {
      PADOFFSET padix   = (aux++)->uv;
      UV        fieldix = (aux++)->uv + offset;

lib/Object/Pad.xs  view on Meta::CPAN

      {"the ADJUST phasers AV",      DMD_FIELD_PTR,  .ptr = classmeta->adjustcvs},       \
      {"the temporary method scope", DMD_FIELD_PTR,  .ptr = classmeta->methodscope}

  switch(classmeta->type) {
    case METATYPE_CLASS:
      DMD_DUMP_STRUCT(ctx, "Object::Pad/ClassMeta.class", classmeta, sizeof(ClassMeta),
        N_COMMON_FIELDS+5, ((const DMDNamedField []){
          COMMON_FIELDS,
          {"the supermeta",                         DMD_FIELD_PTR, .ptr = classmeta->cls.supermeta},
          {"the foreign superclass constructor CV", DMD_FIELD_PTR, .ptr = classmeta->cls.foreign_new},
          {"the foreign superclass DOES CV",        DMD_FIELD_PTR, .ptr = classmeta->cls.foreign_does},
          {"the direct roles AV",                   DMD_FIELD_PTR, .ptr = classmeta->cls.direct_roles},
          {"the embedded roles AV",                 DMD_FIELD_PTR, .ptr = classmeta->cls.embedded_roles},
        })
      );
      break;

    case METATYPE_ROLE:
      DMD_DUMP_STRUCT(ctx, "Object::Pad/ClassMeta.role", classmeta, sizeof(ClassMeta),
        N_COMMON_FIELDS+3, ((const DMDNamedField []){
          COMMON_FIELDS,
          {"the superroles AV",           DMD_FIELD_PTR, .ptr = classmeta->role.superroles},
          {"the role applied classes HV", DMD_FIELD_PTR, .ptr = classmeta->role.applied_classes},
          {"the role APPLY phasers AV",   DMD_FIELD_PTR, .ptr = classmeta->role.applycvs},
        })
      );
      break;
  }

#undef COMMON_FIELDS

  I32 i;

  for(i = 0; i < av_count(classmeta->fields); i++) {
    FieldMeta *fieldmeta = MUST_FIELDMETA(AvARRAY(classmeta->fields)[i]);

    dump_fieldmeta(aTHX_ ctx, fieldmeta);
  }

  for(i = 0; i < av_count(classmeta->direct_methods); i++) {
    MethodMeta *methodmeta = MUST_METHODMETA(AvARRAY(classmeta->direct_methods)[i]);

    dump_methodmeta(aTHX_ ctx, methodmeta);
  }

  HV *parammap;
  if((parammap = classmeta->parammap)) {
    hv_iterinit(parammap);

    HE *iter;
    while((iter = hv_iternext(parammap))) {
      ParamMeta *parammeta = MUST_PARAMMETA(HeVAL(iter));

      dump_parammeta(aTHX_ ctx, parammeta);
    }
  }

  switch(classmeta->type) {
    case METATYPE_CLASS:
      for(i = 0; i < av_count(classmeta->cls.direct_roles); i++) {
        RoleEmbedding *embedding = MUST_ROLEEMBEDDING(AvARRAY(classmeta->cls.direct_roles)[i]);

        dump_roleembedding(aTHX_ ctx, embedding);
      }
      break;

    case METATYPE_ROLE:
      /* No need to dump the values of role.applied_classes because any class
       * they're applied to will have done that already */
      break;
  }
}

static int dumppackage_class(pTHX_ DMDContext *ctx, const SV *sv)
{
  int ret = 0;

  ClassMeta *meta = MUST_CLASSMETA(SvUV((SV *)sv));

  dump_classmeta(aTHX_ ctx, meta);

  ret += DMD_ANNOTATE_SV(sv, (SV *)meta, "the Object::Pad class");

  return ret;
}
#endif

/*********************
 * Custom FieldHooks *
 *********************/

struct CustomFieldHookData
{
  SV *apply_cb;
};

static bool fieldhook_custom_apply(pTHX_ FieldMeta *fieldmeta, SV *value, SV **hookdata_ptr, void *_funcdata)
{
  struct CustomFieldHookData *funcdata = _funcdata;

  SV *cb;
  if((cb = funcdata->apply_cb)) {
    dSP;
    ENTER;
    SAVETMPS;

    SV *fieldmetasv = sv_newmortal();
    sv_setref_uv(fieldmetasv, "Object::Pad::MOP::Field", PTR2UV(fieldmeta));

    PUSHMARK(SP);
    EXTEND(SP, 2);
    PUSHs(fieldmetasv);
    PUSHs(value);
    PUTBACK;

    call_sv(cb, G_SCALAR);

    SPAGAIN;
    SV *ret = POPs;
    *hookdata_ptr = SvREFCNT_inc(ret);

lib/Object/Pad.xs  view on Meta::CPAN

    struct FieldHookFuncs *_funcs;
    Newxz(_funcs, 1, struct FieldHookFuncs);
    Copy(&funcs, _funcs, 1, struct FieldHookFuncs);
    if(_funcs->permit_hintkey)
      _funcs->permit_hintkey = savepv(_funcs->permit_hintkey);

    struct CustomFieldHookData *_funcdata;
    Newxz(_funcdata, 1, struct CustomFieldHookData);
    Copy(&funcdata, _funcdata, 1, struct CustomFieldHookData);
    if(_funcdata->apply_cb)
      _funcdata->apply_cb = newSVsv(_funcdata->apply_cb);

    register_field_attribute(savepv(SvPV_nolen(name)), _funcs, _funcdata);
  }

MODULE = Object::Pad    PACKAGE = Object::Pad::MetaFunctions

SV *
metaclass(SV *obj)
  CODE:
  {
    if(!SvROK(obj) || !SvOBJECT(SvRV(obj)))
      croak("Expected an object reference to metaclass");

    HV *stash = SvSTASH(SvRV(obj));

    GV **gvp = (GV **)hv_fetchs(stash, "META", 0);
    if(!gvp)
      croak("Unable to find ClassMeta for %" HEKf, HEKfARG(HvNAME_HEK(stash)));

    RETVAL = newSVsv(GvSV(*gvp));
  }
  OUTPUT:
    RETVAL

void
deconstruct_object(SV *obj)
  PPCODE:
  {
    if(!SvROK(obj) || !SvOBJECT(SvRV(obj)))
      croak("Expected an object reference to deconstruct_object");

    ClassMeta *classmeta = mop_get_class_for_stash(SvSTASH(SvRV(obj)));

    SV *fieldstore = get_obj_fieldstore(obj, classmeta->repr, true);

    U32 retcount = 0;

    PUSHs(sv_mortalcopy(classmeta->name));
    retcount++;

    PUTBACK;

    while(classmeta) {
      retcount += deconstruct_object_class(fieldstore, classmeta, 0);

      AV *roles = classmeta->cls.direct_roles;
      U32 nroles = av_count(roles);
      for(U32 i = 0; i < nroles; i++) {
        RoleEmbedding *embedding = MUST_ROLEEMBEDDING(AvARRAY(roles)[i]);

        retcount += deconstruct_object_class(fieldstore, embedding->rolemeta, embedding->offset);
      }

      classmeta = classmeta->cls.supermeta;
    }

    SPAGAIN;
    XSRETURN(retcount);
  }

SV *
ref_field(SV *fieldname, SV *obj)
  CODE:
  {
    SV *want_classname = NULL, *want_fieldname;

    if(!SvROK(obj) || !SvOBJECT(SvRV(obj)))
      croak("Expected an object reference to ref_field");

    SvGETMAGIC(fieldname);

    char *s = SvPV_nolen(fieldname);
    char *dotpos;
    if((dotpos = strchr(s, '.'))) {
      U32 flags = SvUTF8(fieldname) ? SVf_UTF8 : 0;
      want_classname = newSVpvn_flags(s, dotpos - s, flags);
      want_fieldname = newSVpvn_flags(dotpos + 1, strlen(dotpos + 1), flags);
    }
    else {
      want_fieldname = SvREFCNT_inc(fieldname);
    }

    SAVEFREESV(want_classname);
    SAVEFREESV(want_fieldname);

    ClassMeta *classmeta = mop_get_class_for_stash(SvSTASH(SvRV(obj)));

    SV *fieldstore = get_obj_fieldstore(obj, classmeta->repr, true);

    while(classmeta) {
      if(!want_classname || sv_eq(want_classname, classmeta->name)) {
        RETVAL = ref_field_class(want_fieldname, fieldstore, classmeta, 0);
        if(RETVAL)
          goto done;
      }

      AV *roles = classmeta->cls.direct_roles;
      U32 nroles = av_count(roles);
      for(U32 i = 0; i < nroles; i++) {
        RoleEmbedding *embedding = MUST_ROLEEMBEDDING(AvARRAY(roles)[i]);

        if(!want_classname || sv_eq(want_classname, embedding->rolemeta->name)) {
          RETVAL = ref_field_class(want_fieldname, fieldstore, embedding->rolemeta, embedding->offset);
          if(RETVAL)
            goto done;
        }
      }

      classmeta = classmeta->cls.supermeta;
    }

    if(want_classname)
      croak("Could not find a field called %" SVf " in class %" SVf,
        SVfARG(want_fieldname), SVfARG(want_classname));
    else
      croak("Could not find a field called %" SVf " in any class",
        SVfARG(want_fieldname));
done:
    ;
  }
  OUTPUT:
    RETVAL

BOOT:
  XopENTRY_set(&xop_methstart, xop_name, "methstart");
  XopENTRY_set(&xop_methstart, xop_desc, "enter method");
  XopENTRY_set(&xop_methstart, xop_class, OA_UNOP_AUX);
  Perl_custom_op_register(aTHX_ &pp_methstart, &xop_methstart);

  XopENTRY_set(&xop_rolemethstart, xop_name, "rolemethstart");
  XopENTRY_set(&xop_rolemethstart, xop_desc, "enter role method");
  XopENTRY_set(&xop_rolemethstart, xop_class, OA_UNOP_AUX);
  Perl_custom_op_register(aTHX_ &pp_rolemethstart, &xop_rolemethstart);

  XopENTRY_set(&xop_commonmethstart, xop_name, "commonmethstart");
  XopENTRY_set(&xop_commonmethstart, xop_desc, "enter method :common");
  XopENTRY_set(&xop_commonmethstart, xop_class, OA_BASEOP);
  Perl_custom_op_register(aTHX_ &pp_commonmethstart, &xop_commonmethstart);

  CvLVALUE_on(get_cv("Object::Pad::MOP::Field::value", 0));
#ifdef HAVE_DMD_HELPER
  DMD_SET_PACKAGE_HELPER("Object::Pad::MOP::Class", &dumppackage_class);
#endif

  boot_xs_parse_keyword(0.48); /* XPK_FLAG_PERMIT_LEXICAL */

  register_xs_parse_keyword("class", &kwhooks_class, (void *)METATYPE_CLASS);
  register_xs_parse_keyword("role",  &kwhooks_role,  (void *)METATYPE_ROLE);

  register_xs_parse_keyword("inherit", &kwhooks_inherit, NULL);
  register_xs_parse_keyword("apply",   &kwhooks_apply,   NULL);

  register_xs_parse_keyword("field", &kwhooks_field, "field");
  register_xs_parse_keyword("has",   &kwhooks_has,   "has");

  register_xs_parse_keyword("BUILD",        &kwhooks_BUILD, (void *)PHASER_BUILD);
  register_xs_parse_keyword("ADJUST",       &kwhooks_ADJUST, (void *)PHASER_ADJUST);
  register_xs_parse_keyword("ADJUSTPARAMS", &kwhooks_ADJUST, (void *)PHASER_ADJUSTPARAMS);
  register_xs_parse_keyword("APPLY",        &kwhooks_APPLY, (void *)PHASER_APPLY);