SV *
_create_class(pkg, name, ...)
    SV *pkg
    SV *name
  ALIAS:
    _create_class = METATYPE_CLASS
    _create_role  = METATYPE_ROLE
  CODE:
  {
    PERL_UNUSED_ARG(pkg);
    dKWARG(2);
    SV *superclassname = NULL;
    bool set_compclassmeta = false;
    bool set_abstract = false;
    {
      const COP *cop;
      const HV *mystash = CopSTASH(PL_curcop);
      for(int level = 0; level < 20; level++) {
        const PERL_CONTEXT *cx = caller_cx(level, NULL);
        if(!cx)
          break;
        cop = cx->blk_oldcop;
        if(CopSTASH(cop) != mystash)
          break;
        cop = NULL;
      }
      if(cop && !cophh_exists_pvs(CopHINTHASH_get(cop), "Object::Pad/experimental(mop)", 0))
        Perl_ck_warner(aTHX_ packWARN(WARN_EXPERIMENTAL),
          "The Object::Pad MOP API is experimental and may be changed or removed without notice");
    }
    static const char *args[] = {
      "extends",
      "isa",
      "_set_compclassmeta",
      "abstract",
      NULL
    };
    while(KWARG_NEXT(args)) {
      switch(kwarg) {
        case 0: /* extends */
        case 1: /* isa */
          if(ix != METATYPE_CLASS)
            croak("Only a class may extend another");
          superclassname = sv_mortalcopy(kwval);
          break;
        case 2: /* _set_compclassmeta */
          set_compclassmeta = SvTRUE(kwval);
          break;
        case 3: /* abstract */
          set_abstract = SvTRUE(kwval);
          break;
      }
    }
    ClassMeta *meta = mop_create_class(ix, name);
    if(superclassname && SvOK(superclassname))
      mop_class_set_superclass(meta, superclassname);
    if(set_abstract)
      meta->abstract = true;
    mop_class_begin(meta);
    RETVAL = newSV(0);
    sv_setref_uv(RETVAL, "Object::Pad::MOP::Class", PTR2UV(meta));
    if(set_compclassmeta) {
      compclassmeta_set(meta);
      CV *cv = newXS(NULL, &xsub_mop_class_seal, __FILE__);
      CvXSUBANY(cv).any_ptr = meta;
      if(!PL_unitcheckav)
        PL_unitcheckav = newAV();
      av_push(PL_unitcheckav, (SV *)cv);
    }
  }
  OUTPUT:
    RETVAL
bool
is_class(ClassMeta *self)
  ALIAS:
    is_class = METATYPE_CLASS
    is_role  = METATYPE_ROLE
  CODE:
    RETVAL = (self->type == ix);
  OUTPUT:
    RETVAL
bool
is_abstract(ClassMeta *self)
  CODE:
    RETVAL = self->abstract;
  OUTPUT:
    RETVAL
SV *
name(ClassMeta *self)
  CODE:
    RETVAL = SvREFCNT_inc(self->name);
  OUTPUT:
    RETVAL
void
superclasses(ClassMeta *self)
  PPCODE:
    if(self->type == METATYPE_CLASS && self->cls.supermeta) {
      PUSHs(sv_newmortal());
      sv_setref_uv(ST(0), "Object::Pad::MOP::Class", PTR2UV(self->cls.supermeta));
      XSRETURN(1);
    }
    XSRETURN(0);
void
direct_roles(ClassMeta *self)
  ALIAS:
    direct_roles = 0
    all_roles    = 1
  PPCODE:
  {
    U32 count = 0;
    /* TODO Consider recursion */
    U32 i;
    switch(self->type) {
      case METATYPE_CLASS: {
        U32 nroles;
        RoleEmbedding **embeddings = NULL;
        switch(ix) {
          case 0: embeddings = mop_class_get_direct_roles(self, &nroles); break;
          case 1: embeddings = mop_class_get_all_roles(self, &nroles); break;
        }
        for(i = 0; i < nroles; i++) {
          SV *sv = sv_newmortal();
          sv_setref_uv(sv, "Object::Pad::MOP::Class", PTR2UV(embeddings[i]->rolemeta));
          XPUSHs(sv);
          count++;
        }
        break;
      }
      case METATYPE_ROLE:
        break;
    }
    XSRETURN(count);
  }
void
add_role(ClassMeta *self, role)
    SV *role
  ALIAS:
    compose_role = 0
  CODE:
  {
    ClassMeta *rolemeta = NULL;
    PERL_UNUSED_VAR(ix);
    if(SvROK(role)) {
      if(!sv_derived_from(role, "Object::Pad::MOP::Class"))
        croak("Expected a role name string or Object::Pad::MOP::Class; got %" SVf, SVfARG(role));
      rolemeta = MUST_CLASSMETA_FROM_RV(role);
    }
    else {
      HV *rolestash = gv_stashsv(role, 0);
      /* Don't attempt to `require` it; that is caller's responsibilty */
      if(!rolestash)
        croak("Role %" SVf " does not exist", SVfARG(role));
      GV **metagvp = (GV **)hv_fetchs(rolestash, "META", 0);
      if(metagvp)
        rolemeta = NUM2PTR(ClassMeta *, SvUV(SvRV(GvSV(*metagvp))));
    }
    if(!rolemeta || rolemeta->type != METATYPE_ROLE)
      croak("%" SVf " is not a role", SVfARG(role));
    mop_class_begin(self);
    mop_class_add_role(self, rolemeta);
  }
void
add_BUILD(ClassMeta *self, code)
    CV *code
  CODE:
    mop_class_begin(self);
    mop_class_add_BUILD(self, (CV *)SvREFCNT_inc((SV *)code));
SV *
add_method(ClassMeta *self, mname, ...)
    SV *mname
  CODE:
  {
    if(items < 3)
      croak_xs_usage(cv, "self, mname, ..., code");
    SV *ref = ST(items-1); items--;
    if(!SvROK(ref) || SvTYPE(SvRV(ref)) != SVt_PVCV)
      croak("Expected CODE reference");
    dKWARG(2);
    /* Take a copy now to run FETCH magic */
    mname = sv_2mortal(newSVsv(mname));
    mop_class_begin(self);
    if(SvOK(mname) && SvPOK(mname) && strEQ(SvPVX(mname), "BUILD")) {
      croak("Adding a method called BUILD is not supported; use ->add_BUILD directly");
    }
    MethodMeta *methodmeta = mop_class_add_method_cv(self, mname, (CV *)SvREFCNT_inc(CV_FROM_REF(ref)));
    static const char *args[] = {
      "common",
      NULL
    };
    while(KWARG_NEXT(args)) {
      switch(kwarg) {
        case 0: /* common */
          methodmeta->is_common = SvTRUE(kwval);
          break;
      }
    }
    RETVAL = newSV(0);
    sv_setref_uv(RETVAL, "Object::Pad::MOP::Method", PTR2UV(methodmeta));
  }
  OUTPUT:
    RETVAL
void
get_direct_method(ClassMeta *self, methodname)
    SV *methodname
  ALIAS:
    get_method = 1
  PPCODE:
  {
    bool recurse = !!ix;
    ClassMeta *class = self;
    do {
      AV *methods = class->direct_methods;
      U32 nmethods = av_count(methods);
      U32 i;
      for(i = 0; i < nmethods; i++) {
        MethodMeta *methodmeta = (MethodMeta *)AvARRAY(methods)[i];
        if(!sv_eq(methodmeta->name, methodname))
          continue;
        ST(0) = sv_newmortal();
        sv_setref_iv(ST(0), "Object::Pad::MOP::Method", PTR2UV(methodmeta));
        XSRETURN(1);
      }
      if(class->type == METATYPE_CLASS)
        class = class->cls.supermeta;
      else
        class = NULL;
    } while(recurse && class);
    croak("Class %" SVf " does not have a method called '%" SVf "'",
      SVfARG(self->name), SVfARG(methodname));
  }
void
direct_methods(ClassMeta *self)
  ALIAS:
    all_methods = 1
  PPCODE:
    bool recurse = !!ix;
    /* A hash to remove overrides */
    HV *mnames = NULL;
    if(recurse) {
      mnames = newHV();
      SAVEFREESV(mnames);
    }
    U32 retcount = 0;
    do {
      AV *methods = self->direct_methods;
      U32 nmethods = av_count(methods);
      EXTEND(SP, retcount + nmethods);  /* might be an overestimate but don't worry */
      U32 i;
      for(i = 0; i < nmethods; i++) {
        MethodMeta *methodmeta = (MethodMeta *)AvARRAY(methods)[i];
        if(mnames && hv_exists_ent(mnames, methodmeta->name, 0))
          continue;
        ST(retcount) = sv_newmortal();
        sv_setref_iv(ST(retcount), "Object::Pad::MOP::Method", PTR2UV(methodmeta));
        retcount++;
        hv_store_ent(mnames, methodmeta->name, &PL_sv_yes, 0);
      }
      if(self->type == METATYPE_CLASS)
        self = self->cls.supermeta;
      else
        self = NULL;
    } while(recurse && self);
    XSRETURN(retcount);
void
add_required_method(ClassMeta *self, mname)
    SV *mname
  CODE:
    mop_class_begin(self);
    mop_class_add_required_method(self, mname);
SV *
add_field(ClassMeta *self, fieldname, ...)
    SV *fieldname
  CODE:
  {
    dKWARG(2);
    mop_class_begin(self);
    FieldMeta *fieldmeta = mop_class_add_field(self, sv_mortalcopy(fieldname));
    static const char *args[] = {
      "default",
      "param",
      "reader",
      "writer",
      "mutator",
      "accessor",
      "weak",
      "attributes",
      NULL,
    };
    while(KWARG_NEXT(args)) {
      switch(kwarg) {
        case 0: /* default */
          mop_field_set_default_sv(fieldmeta, newSVsv(kwval));
          break;
        case 1: /* param */
          mop_field_apply_attribute(fieldmeta, "param", kwval);
          break;
        case 2: /* reader */
          mop_field_apply_attribute(fieldmeta, "reader", kwval);
          break;
        case 3: /* writer */
          mop_field_apply_attribute(fieldmeta, "writer", kwval);
          break;
        case 4: /* mutator */
          mop_field_apply_attribute(fieldmeta, "mutator", kwval);
          break;
        case 5: /* accessor */
          mop_field_apply_attribute(fieldmeta, "accessor", kwval);
          break;
        case 6: /* weak */
          mop_field_apply_attribute(fieldmeta, "weak", NULL);
          break;
        case 7: /* attributes */
        {
          if(!SvROK(kwval) || SvTYPE(SvRV(kwval)) != SVt_PVAV)
            croak("Expected 'attributes' to be given an ARRAY reference");
          AV *attributes = AV_FROM_REF(kwval);
          for(IV ix = 0; ix < av_count(attributes); ix += 2) {
            SV *attrname = *av_fetch(attributes, ix, 0);
            SV *attrval  = ix+1 < av_count(attributes) ? *av_fetch(attributes, ix + 1, 0) : &PL_sv_undef;
            mop_field_apply_attribute(fieldmeta, SvPV_nolen(attrname), attrval);
          }
        }
      }
    }
    mop_field_seal(fieldmeta);
    RETVAL = newSV(0);
    sv_setref_uv(RETVAL, "Object::Pad::MOP::Field", PTR2UV(fieldmeta));
  }
  OUTPUT:
    RETVAL
void
get_field(ClassMeta *self, fieldname)
    SV *fieldname
  PPCODE:
  {
    FieldMeta *fieldmeta = mop_class_find_field(self, fieldname, FIND_FIELD_ONLY_DIRECT);
    if(fieldmeta) {
      ST(0) = sv_newmortal();
      sv_setref_iv(ST(0), "Object::Pad::MOP::Field", PTR2UV(fieldmeta));
      XSRETURN(1);
    }
    croak("Class %" SVf " does not have a field called '%" SVf "'",
      self->name, fieldname);
  }
void
fields(ClassMeta *self)
  PPCODE:
    AV *fields = self->fields;
    U32 nfields = av_count(fields);
    EXTEND(SP, nfields);
    U32 retcount = 0;
    FIELDOFFSET i;
    for(i = 0; i < nfields; i++) {
      FieldMeta *fieldmeta = (FieldMeta *)AvARRAY(fields)[i];
      if(!fieldmeta->is_direct)
        continue;
      ST(i) = sv_newmortal();
      sv_setref_iv(ST(i), "Object::Pad::MOP::Field", PTR2UV(fieldmeta));
      retcount++;
    }
    XSRETURN(retcount);
void
required_method_names(ClassMeta *self)
  PPCODE:
    if(self->type != METATYPE_ROLE)
      croak("Can only call ->required_method_names on a metaclass for a role");
    AV *required_methods = self->requiremethods;
    U32 nmethods = av_count(required_methods);
    EXTEND(SP, nmethods);
    int i;
    for(i = 0; i < nmethods; i++) {
      ST(i) = sv_2mortal(newSVsv(AvARRAY(required_methods)[i]));
    }
    XSRETURN(nmethods);
void
seal(ClassMeta *self)
  CODE:
    mop_class_seal(self);