File Coverage

lib/meta.xs

Criterion	Covered	Total	%
statement	354	430	82.3
branch	258	488	52.8
condition			n/a
subroutine			n/a
pod			n/a
total	612	918	66.6

/*  You may distribute under the terms of either the GNU General Public License
 *  or the Artistic License (the same terms as Perl itself)
 *
 *  (C) Paul Evans, 2022 -- [e-mail]
 */
#define PERL_NO_GET_CONTEXT

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#define HAVE_PERL_VERSION(R, V, S) \
    (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))

#if !HAVE_PERL_VERSION(5,16,0)
#  define true  TRUE
#  define false FALSE

/* CvPROTO was just stored in SvPV */
#  define CvPROTO(cv)       SvPVX(cv)
#  define CvPROTOLEN(cv)    SvCUR(cv)
/* HvNAMELEN did not exist; stash names cannot contain \0 */
#  define HvNAMELEN(stash)  strlen(HvNAME(stash))
/* HvNAME and GvNAME could never be UTF-8 */
#  define HvNAMEUTF8(hv)    0
#  define GvNAMEUTF8(gv)    0

#  define gv_init_sv(gv, stash, sv, flags)  \
                            gv_init(gv, stash, SvPV_nolen(sv), SvCUR(sv), SvUTF8(sv) | flags)
#  define gv_init_pvn(gv, stash, pv, len, flags)  \
                            gv_init(gv, stash, pv, len, flags)
#endif

#if !HAVE_PERL_VERSION(5, 22, 0)
/* copypaste from perl-v5.22.0/perl.h */
#  ifndef DEBUGGING
#    if __has_builtin(__builtin_unreachable) \
       || (__GNUC__ == 4 && __GNUC_MINOR__ >= 5 || __GNUC__ > 4) /* 4.5 -> */
#      define ASSUME(x) ((x) ? (void) 0 : __builtin_unreachable())
#    elif defined(_MSC_VER)
#      define ASSUME(x) __assume(x)
#    elif defined(__ARMCC_VERSION) /* untested */
#      define ASSUME(x) __promise(x)
#    else
/* a random compiler might define assert to its own special optimization token
   so pass it through to C lib as a last resort */
#      define ASSUME(x) assert(x)
#    endif
#  else
#    define ASSUME(x) assert(x)
#  endif

#  define NOT_REACHED ASSUME(0)
#endif

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

#if HAVE_PERL_VERSION(5, 43, 3)
#  define HAVE_OP_MULTIPARAM
#endif

#if HAVE_PERL_VERSION(5, 43, 5)
#  define HAVE_OP_MULTIPARAM_NAMED
#endif

#ifndef av_count
#  define av_count(av)  (AvFILL(av)+1)
#endif

#ifndef G_LIST
#  define G_LIST  G_ARRAY
#endif

#ifndef CvREFCNT_inc
#  define CvREFCNT_inc(cv)  ((CV *)SvREFCNT_inc((SV *)(cv)))
#endif

#if defined (DEBUGGING) && defined(PERL_USE_GCC_BRACE_GROUPS)
#  define _MUST_SVTYPE_FROM_REFSV(rsv, type, svt)  \
    ({ type sv = (type)(SvUV(SvRV(rsv))); assert(sv && SvTYPE(sv) == svt); sv; })
#else
#  define _MUST_SVTYPE_FROM_REFSV(rsv, type, svt)  \
    ((type)(SvUV(SvRV(rsv))))
#endif

#define MUST_STASH_FROM_REFSV(sv)  _MUST_SVTYPE_FROM_REFSV(sv, HV *, SVt_PVHV)
#define MUST_GV_FROM_REFSV(sv)     _MUST_SVTYPE_FROM_REFSV(sv, GV *, SVt_PVGV)
#define MUST_CV_FROM_REFSV(sv)     _MUST_SVTYPE_FROM_REFSV(sv, CV *, SVt_PVCV)

#define SV_FROM_REFSV(sv)  \
  ((SV *)(SvUV(SvRV(sv))))

#define wrap_sv_refsv(sv)  S_wrap_sv_refsv(aTHX_ sv)
SV *S_wrap_sv_refsv(pTHX_ SV *sv)
{
  const char *metaclass;
  switch(SvTYPE(sv)) {
    case SVt_PVGV: metaclass = "meta::glob";       break;
    case SVt_PVCV: metaclass = "meta::subroutine"; break;
    default:       metaclass = "meta::variable";   break;
  }
  return sv_setref_uv(newSV(0), metaclass, PTR2UV(SvREFCNT_inc(sv)));
}

#define wrap_stash(stash)  S_wrap_stash(aTHX_ stash)
static SV *S_wrap_stash(pTHX_ HV *stash)
{
  // TODO: Do we need to refcnt_inc stash?
  return sv_setref_uv(newSV(0), "meta::package", PTR2UV(stash));
}

struct CVwithOP {
  CV *cv;
  OP *op;
  U32 flags;
};

enum {
  CVSIGNATURE_IS_METHOD = (1<<0),
};

#define wrap_cv_signature(cv, op, flags)  S_wrap_cv_signature(aTHX_ cv, op, flags)
static SV *S_wrap_cv_signature(pTHX_ CV *cv, OP *op, U32 flags)
{
  struct CVwithOP ret = { .cv = CvREFCNT_inc(cv), .op = op, .flags = flags };
  return sv_setref_pvn(newSV(0), "meta::subsignature", (const char *)&ret, sizeof(ret));
}

#ifdef HAVE_OP_MULTIPARAM_NAMED

# define newSVmultiparam_named(oaux)  S_newSVmultiparam_named(aTHX_ oaux)
static SV *S_newSVmultiparam_named(pTHX_ struct op_multiparam_named_aux *oaux)
{
  struct op_multiparam_named_aux ret = *oaux;
  ret.namepv = savepvn(ret.namepv, ret.namelen);
  return sv_setref_pvn(newSV(0), "meta::subsignature::named_param", (const char *)&ret, sizeof(ret));
}

# define MULTIPARAM_NAMED_FROM_REFSV(refsv) \
  (struct op_multiparam_named_aux *)SvPVX(SvRV(refsv))

#endif /* HAVE_OP_MULTIPARAM_NAMED */

#ifdef SVf_QUOTEDPREFIX
#  define templateSVf_QUOTEDPREFIX  "%" SVf_QUOTEDPREFIX
#else
#  define templateSVf_QUOTEDPREFIX  "\"%" SVf "\""
#endif

#ifdef PVf_QUOTEDPREFIX
#  define templatePVf_QUOTEDPREFIX  "%" PVf_QUOTEDPREFIX
#else
#  define templatePVf_QUOTEDPREFIX  "\"%s\""
#endif

#define gv_is_empty(gv)  S_gv_is_empty(aTHX_ gv)
static bool S_gv_is_empty(pTHX_ GV *gv)
{
  if(SvFAKE(gv) ||
    GvSV(gv) ||
    GvAV(gv) ||
    GvHV(gv) ||
    GvCV(gv) ||
    GvIO(gv) ||
    GvFORM(gv))
    return false;

  /* TODO: any other safety checks? */
  return true;
}

/* Some helpers for warnings.pm
 *
 * The custom warning categories defined by warnings.pm are implemented
 * entirely in the Perl code, so interacting with it means a lot of call_pv()
 * wrapper functions.
 *
 * The warnings::warnif function is intended to be called from Perl, and
 * presumes the caller stack will have a corresponding caller frame that it
 * should skip. Since we're calling it here from XSUBs that does not happen,
 * so we have to take extra measures to ensure it sees the correct caller
 * context.
 */

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

#define warnings_register_category(category)  S_warnings_register_category(aTHX_ category)
static void S_warnings_register_category(pTHX_ const char *category)
{
  dSP;
  ENTER;

  EXTEND(SP, 1);
  PUSHMARK(SP);
  mPUSHp(category, strlen(category));
  PUTBACK;

  call_pv("warnings::register_categories", G_VOID);

  LEAVE;
}

#define warnings_warnsvif(category, msv)  S_warnings_warnsvif(aTHX_ category, msv)
static void S_warnings_warnsvif(pTHX_ const char *category, SV *msv)
{
  dSP;
  ENTER;

#ifdef HAVE_WARNINGS_WARNIF_AT_LEVEL
  EXTEND(SP, 3);
  PUSHMARK(SP);
  mPUSHp(category, strlen(category));
  mPUSHi(-1); // level = -1 because our XSUB does not have a caller frame
  PUSHs(msv);
  PUTBACK;

  call_pv("warnings::warnif_at_level", G_VOID);
#else
  // warnings::warnif needs to see an extra call frame here. There's no way
  // to hack this up using cx_pushblock etc... as that only works for pureperl
  // CVs. We'll just have to use a trampoline
  EXTEND(SP, 2);
  PUSHMARK(SP);
  mPUSHp(category, strlen(category));
  PUSHs(msv);
  PUTBACK;

  call_pv("meta::warnif_trampoline", G_VOID);
#endif

  LEAVE;
}

#define META_WARNING_CATEGORY "meta::experimental"

#define warn_experimental(fname)  S_warn_experimental(aTHX_ fname)
static void S_warn_experimental(pTHX_ const char *fname)
{
  warnings_warnsvif(META_WARNING_CATEGORY,
    sv_2mortal(newSVpvf("%s is experimental and may be changed or removed without notice", fname)));
}

#define warn_sub_deprecated(cv)  S_warn_sub_deprecated(aTHX_ cv)
static void S_warn_sub_deprecated(pTHX_ CV *cv)
{
  GV *gv = CvGV(cv);

  Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
    "%s::%s() is deprecated and may be removed without notice",
      GvNAME(GvSTASH(gv)), GvNAME(gv));
}

#if HAVE_PERL_VERSION(5, 38, 0)
#  define HAVE_FEATURE_CLASS
#endif

// Flags for get-alike methods
enum {
  GET_OR_UNDEF,
  GET_OR_THROW,
  GET_OR_ADD,
  ADD_OR_THROW,

  GET_OR_UNDEF_WITH_WARNING,
};

static SV *S_get_metaglob_slot(pTHX_ SV *metaglob, U8 svt, const char *slotname, U8 ix)
{
  GV *gv = MUST_GV_FROM_REFSV(metaglob);
  SV *ret;
  switch(svt) {
    case SVt_PVMG: ret =       GvSV (gv); break;
    case SVt_PVAV: ret = (SV *)GvAV (gv); break;
    case SVt_PVHV: ret = (SV *)GvHV (gv); break;
    case SVt_PVCV: ret = (SV *)GvCVu(gv); break;
  }

  if(ret)
    return wrap_sv_refsv(ret);

  switch(ix) {
    case GET_OR_THROW:
      croak("Glob does not have a %s slot", slotname);
    case GET_OR_UNDEF_WITH_WARNING:
    case GET_OR_UNDEF:
      return &PL_sv_undef;

    default:
      NOT_REACHED;
  }
}

static void split_fqname(const char *namepv, STRLEN namelen,
  const char **pkgnamepvp, STRLEN *pkgnamelenp, const char **basenamepvp, STRLEN *basenamelenp)
{
  STRLEN pkgnamelen = 0;
  const char *pkgnamepv = NULL;
  STRLEN basenamelen = namelen;
  const char *basenamepv = namepv;

  const char *s = namepv + namelen - 2;
  for(/**/; s > namepv; s--) {
    if(s[0] != ':' || s[1] != ':')
      continue;

    /* s now points at the final occurence of '::' in the name
     * pkgname is namepv up to s, basename is s+2 up to its original end */
    pkgnamepv   = namepv;
    pkgnamelen  = s - namepv;
    basenamepv  = s + 2;
    basenamelen = namelen - (basenamepv - namepv);
    break;
  }

  if(pkgnamepvp)   *pkgnamepvp   = pkgnamepv;
  if(pkgnamelenp)  *pkgnamelenp  = pkgnamelen;
  if(basenamepvp)  *basenamepvp  = basenamepv;
  if(basenamelenp) *basenamelenp = basenamelen;
}

MODULE = meta    PACKAGE = meta

SV *
get_package(SV *pkgname)
  CODE:
    warn_experimental("meta::get_package");
    RETVAL = wrap_stash(gv_stashsv(pkgname, GV_ADD));
  OUTPUT:
    RETVAL

SV *
get_this_package()
  CODE:
    warn_experimental("meta::get_this_package");
    RETVAL = wrap_stash(CopSTASH(PL_curcop));
  OUTPUT:
    RETVAL

SV *
for_reference(SV *ref)
  CODE:
    warn_experimental("meta::for_reference");
    if(!SvROK(ref))
      croak("meta::for_reference requires a reference value");
    /* TODO: maybe there's some kinds of SV we'll forbid here? */
    RETVAL = wrap_sv_refsv(SvRV(ref));
  OUTPUT:
    RETVAL

MODULE = meta    PACKAGE = meta::package

SV *
get(SV *cls, SV *pkgname)
  CODE:
    if(SvROK(cls))
      croak("meta::package->get(name) should not be invoked on an instance "
          "(did you mean to call one of the ->get_... methods?)");
    warn_experimental("meta::package->get");
    RETVAL = wrap_stash(gv_stashsv(pkgname, GV_ADD));
  OUTPUT:
    RETVAL

bool
is_class(SV *metapkg)
  CODE:
  {
#ifdef HAVE_FEATURE_CLASS
    HV *stash = MUST_STASH_FROM_REFSV(metapkg);
    RETVAL = HvSTASH_IS_CLASS(stash);
#else
    PERL_UNUSED_VAR(metapkg);
    RETVAL = false;
#endif
  }
  OUTPUT:
    RETVAL

SV *
name(SV *metapkg)
  CODE:
  {
    HV *stash = MUST_STASH_FROM_REFSV(metapkg);
    RETVAL = newSVpvn_flags(HvNAME(stash), HvNAMELEN(stash), HvNAMEUTF8(stash) ? SVf_UTF8 : 0);
  }
  OUTPUT:
    RETVAL

SV *
get_glob(SV *metapkg, SV *name)
  ALIAS:
    can_glob = GET_OR_UNDEF_WITH_WARNING
    get_glob = GET_OR_THROW
    try_get_glob = GET_OR_UNDEF
  CODE:
  {
    if(ix == GET_OR_UNDEF_WITH_WARNING)
      warn_sub_deprecated(cv);
    HV *stash = MUST_STASH_FROM_REFSV(metapkg);
    HE *he = hv_fetch_ent(stash, name, 0, 0);
    if(he) {
      GV *gv = (GV *)HeVAL(he);
      assert(SvTYPE(gv) == SVt_PVGV);
      RETVAL = wrap_sv_refsv((SV *)gv);
    }
    else switch(ix) {
      case GET_OR_THROW:
        croak("Package " templatePVf_QUOTEDPREFIX " does not contain a glob called " templateSVf_QUOTEDPREFIX,
          HvNAME(stash), SVfARG(name));
      case GET_OR_UNDEF_WITH_WARNING:
      case GET_OR_UNDEF:
        RETVAL = &PL_sv_undef;
        break;

      default:
        NOT_REACHED;
    }
  }
  OUTPUT:
    RETVAL

SV *
get_symbol(SV *metapkg, SV *name, SV *value = NULL)
  ALIAS:
    can_symbol = GET_OR_UNDEF_WITH_WARNING
    get_symbol = GET_OR_THROW
    try_get_symbol = GET_OR_UNDEF
    get_or_add_symbol = GET_OR_ADD
    add_symbol = ADD_OR_THROW
  CODE:
  {
    if(ix == GET_OR_UNDEF_WITH_WARNING)
      warn_sub_deprecated(cv);

    bool create = ix >= GET_OR_ADD;

    if(create) {
      if(value && !SvROK(value))
        croak("Expected a reference for the new value to add_symbol");
    }
    else {
      if(value)
        croak("meta::glob->get_symbol args");
    }

    HV *stash = MUST_STASH_FROM_REFSV(metapkg);
    char sigil = SvPV_nolen(name)[0];
    SV *valuesv = NULL;

    if(value) {
      valuesv = SvRV(value);
      switch(sigil) {
        case '*':
          croak("TODO: Cannot currently cope with adding GLOBs via ->add_symbol");
          break;
        case '$':
          if(SvTYPE(valuesv) > SVt_PVMG)
            croak("Expected a SCALAR reference for the new value to add_symbol('$...')");
          break;
        case '@':
          if(SvTYPE(valuesv) != SVt_PVAV)
            croak("Expected a ARRAY reference for the new value to add_symbol('@...')");
          break;
        case '%':
          if(SvTYPE(valuesv) != SVt_PVHV)
            croak("Expected a HASH reference for the new value to add_symbol('%%...')");
          break;
        case '&':
          if(SvTYPE(valuesv) != SVt_PVCV)
            croak("Expected a CODE reference for the new value to add_symbol('&...')");
          break;
        default:
          croak("Unrecognised name sigil for add_symbol");
      }
    }

    SV *basename = newSVpvn_flags(SvPV_nolen(name) + 1, SvCUR(name) - 1,
        (SvUTF8(name) ? SVf_UTF8 : 0) | SVs_TEMP);
    SV *ret = NULL;
    HE *he = hv_fetch_ent(stash, basename, create ? GV_ADD : 0, 0);
    if(!he)
      goto gv_missing;
    SV *sv = HeVAL(he);

    if(create && SvTYPE(sv) != SVt_PVGV) {
      gv_init_sv((GV *)sv, stash, basename, 0);
      GvMULTI_on(sv);
    }

    if(SvTYPE(sv) == SVt_PVGV) {
      GV *gv = (GV *)sv;
      switch(sigil) {
        case '*': ret = (SV *)      gv;  break;
        case '$': ret =       GvSV (gv); break;
        case '@': ret = (SV *)GvAV (gv); break;
        case '%': ret = (SV *)GvHV (gv); break;
        case '&': ret = (SV *)GvCVu(gv); break;
      }
    }
    else if(SvROK(sv)) {
      // GV-less optimisation; this is an RV to one kind of element
      SV *rv = SvRV(sv);
      switch(sigil) {
        case '*': /* We know it isn't an SVt_PVGV */ ret = NULL; break;
        case '$': ret = (SvTYPE(rv) <= SVt_PVMG) ? rv : NULL; break;
        case '@': ret = (SvTYPE(rv) == SVt_PVAV) ? rv : NULL; break;
        case '%': ret = (SvTYPE(rv) == SVt_PVHV) ? rv : NULL; break;
        case '&': ret = (SvTYPE(rv) == SVt_PVCV) ? rv : NULL; break;
      }
    }
    else
      croak("TODO: Not sure what to do with SvTYPE(sv)=%d\n", SvTYPE(sv));

    if(ix == ADD_OR_THROW && ret)
      croak("Package " templatePVf_QUOTEDPREFIX " already contains a symbol named " templateSVf_QUOTEDPREFIX,
        HvNAME(stash), SVfARG(name));

    if(!ret && create) {
      GV *gv = (GV *)sv;
      ret = valuesv;

      switch(sigil) {
        case '*':
          croak("Cannot create the glob slot itself");
        case '$':
          if(!ret)
            ret = newSV(0);
          GvSV(gv) = SvREFCNT_inc(ret);
          break;
        case '@':
          if(!ret)
            ret = (SV *)newAV();
          GvAV(gv) = (AV *)SvREFCNT_inc(ret);
          break;
        case '%':
          if(!ret)
            ret = (SV *)newHV();
          GvHV(gv) = (HV *)SvREFCNT_inc(ret);
          break;
        case '&':
          if(!ret)
            croak("Cannot create a subroutine by ->get_or_add_symbol");
          GvCV_set(gv, (CV *)SvREFCNT_inc(ret));
          GvCVGEN(gv) = 0;
          break;
      }
    }

    gv_missing:
    if(ret)
      RETVAL = (GIMME_V != G_VOID) ? wrap_sv_refsv(ret) : &PL_sv_undef;
    else switch(ix) {
      case GET_OR_THROW:
        croak("Package " templatePVf_QUOTEDPREFIX " has no symbol named " templateSVf_QUOTEDPREFIX,
          HvNAME(stash), SVfARG(name));
      case GET_OR_UNDEF_WITH_WARNING:
      case GET_OR_UNDEF:
        RETVAL = &PL_sv_undef;
        break;

      default:
        NOT_REACHED;
    }
  }
  OUTPUT:
    RETVAL

SV *
add_named_sub(SV *metapkg, SV *name, SV *value)
  CODE:
  {
    HV *stash = MUST_STASH_FROM_REFSV(metapkg);

    if(!SvROK(value) || SvTYPE(SvRV(value)) != SVt_PVCV)
      croak("Expected a CODE reference for the new value to add_named_sub");
    CV *cv = (CV *)SvRV(value);

    HE *he = hv_fetch_ent(stash, name, GV_ADD, 0);
    GV *gv;
    {
      assert(he);
      SV *sv = HeVAL(he);
      if(SvTYPE(sv) != SVt_PVGV) {
        gv_init_sv((GV *)sv, stash, name, 0);
        GvMULTI_on(sv);
      }

      gv = (GV *)sv;
    }

    if(GvCVu(gv))
      croak("Package " templatePVf_QUOTEDPREFIX " already contains symbol named &" templateSVf_QUOTEDPREFIX,
        HvNAME(stash), SVfARG(name));

    /* Set these in the right order so the name GV works properly */
    GvCV_set(gv, CvREFCNT_inc(cv));
    GvCVGEN(gv) = 0;
    CvGV_set(cv, gv);

    RETVAL = wrap_sv_refsv((SV *)cv);
  }
  OUTPUT:
    RETVAL

void
remove_symbol(SV *metapkg, SV *name)
  CODE:
  {
    HV *stash = MUST_STASH_FROM_REFSV(metapkg);
    char sigil = SvPV_nolen(name)[0];
    SV *basename = newSVpvn_flags(SvPV_nolen(name) + 1, SvCUR(name) - 1,
        (SvUTF8(name) ? SVf_UTF8 : 0) | SVs_TEMP);
    HE *he = hv_fetch_ent(stash, basename, 0, 0);
    if(!he)
      goto missing;
    SV *sv = HeVAL(he);

    if(SvTYPE(sv) == SVt_PVGV) {
      GV *gv = (GV *)sv;
      SV *sv = NULL;
      switch(sigil) {
        case '*': croak("TODO: Cannot ->remove_symbol on a glob"); break;
        case '$':
          sv = GvSV(gv); GvSV(gv) = NULL;
          break;
        case '@':
          sv = (SV *)GvAV(gv); GvAV(gv) = NULL;
          break;
        case '%':
          sv = (SV *)GvHV(gv); GvHV(gv) = NULL;
          break;
        case '&':
          sv = (SV *)GvCVu(gv); GvCV_set(gv, NULL);
          GvCVGEN(gv) = 0;
          break;
      }

      if(!sv)
        missing:
        croak("Cannot remove non-existing symbol " templateSVf_QUOTEDPREFIX " from package " templatePVf_QUOTEDPREFIX,
          SVfARG(name), HvNAME(stash));

      SvREFCNT_dec(sv);

      /* TODO: Perl core has a gv_try_downgrade() we could call here, but XS
       * modules can't see it
       */
      if(gv_is_empty(gv))
        hv_delete_ent(stash, basename, G_DISCARD, 0);
    }
    else if(SvROK(sv)) {
      // GV-less optimisation; this is an RV to one kind of element
      SV *rv = SvRV(sv);
      switch(sigil) {
        case '*': /* We know it isn't a SVt_PVGV */ goto missing; break;
        case '$': if(SvTYPE(rv)  > SVt_PVMG) goto missing; break;
        case '@': if(SvTYPE(rv) != SVt_PVAV) goto missing; break;
        case '%': if(SvTYPE(rv) != SVt_PVHV) goto missing; break;
        case '&': if(SvTYPE(rv) != SVt_PVCV) goto missing; break;
      }

      hv_delete_ent(stash, basename, G_DISCARD, 0);
    }
    else
      croak("TODO: Not sure what to do with SvTYPE(sv)=%d\n", SvTYPE(sv));
  }

void
list_globs(SV *metapkg)
  ALIAS:
    list_all_globs        = 0
    list_globs            = 1
    list_subpackage_globs = 2
  PPCODE:
  {
    HV *stash = MUST_STASH_FROM_REFSV(metapkg);
    UV retcount = 0;
    hv_iterinit(stash);
    HE *he;
    while((he = hv_iternext(stash))) {
      GV *gv = (GV *)HeVAL(he);
      assert(SvTYPE(gv) == SVt_PVGV);
      if(ix) {
        STRLEN keylen;
        const char *keypv = HePV(he, keylen);
        bool is_subpackage = keylen > 2 && keypv[keylen-2] == ':' && keypv[keylen-1] == ':';
        if(ix == 1 && is_subpackage)
          continue;
        if(ix == 2 && !is_subpackage)
          continue;
      }
      EXTEND(SP, 1);
      mPUSHs(wrap_sv_refsv((SV *)gv));
      retcount++;
    }
    XSRETURN(retcount);
  }

void
_list_symbols(SV *metapkg, SV *sigils)
  PPCODE:
  {
    HV *stash = MUST_STASH_FROM_REFSV(metapkg);
    const char *sigilfilter = sigils && SvOK(sigils) ? SvPV_nolen(sigils) : NULL;

    UV retcount = 0;
    hv_iterinit(stash);
    HE *he;
    while((he = hv_iternext(stash))) {
      STRLEN keylen;
      const char *keypv = HePV(he, keylen);
      bool is_subpackage = keylen > 2 && keypv[keylen-2] == ':' && keypv[keylen-1] == ':';
      if(is_subpackage)
        continue;
#define PUSH_SVREF_IF(sv, sigil)                                    \
      if((sv) &&                                                    \
          (!sigilfilter || strchr(sigilfilter, sigil))) {           \
        SV *_sv = (SV *)(sv);                                       \
        SV *namesv = newSVpvf("%c%.*s", sigil, (int)keylen, keypv); \
        if(HeUTF8(he)) SvUTF8_on(namesv);                           \
        EXTEND(SP, 2);                                              \
        mPUSHs(namesv);                                             \
        mPUSHs(wrap_sv_refsv(_sv));                                 \
        retcount += 2;                                              \
      }

      SV *sv = HeVAL(he);
      if(SvTYPE(sv) == SVt_PVGV) {
        GV *gv = (GV *)sv;

        PUSH_SVREF_IF(GvSV (gv), '$');
        PUSH_SVREF_IF(GvAV (gv), '@');
        PUSH_SVREF_IF(GvHV (gv), '%');
        PUSH_SVREF_IF(GvCVu(gv), '&');
      }
      else if(SvROK(sv)) {
        // GV-less optimisation; this is an RV to one kind of element
        SV *rv = SvRV(sv);
        U8 type = SvTYPE(rv);

        PUSH_SVREF_IF(type <= SVt_PVMG ? rv : NULL, '$');
        PUSH_SVREF_IF(type == SVt_PVAV ? rv : NULL, '@');
        PUSH_SVREF_IF(type == SVt_PVHV ? rv : NULL, '%');
        PUSH_SVREF_IF(type == SVt_PVCV ? rv : NULL, '&');
      }
      else
        croak("TODO: Not sure what to do with SvTYPE(sv)=%d\n", SvTYPE(sv));
    }
#undef PUSH_SVREF_IF
    XSRETURN(retcount);
  }

void
list_subpackages(SV *metapkg)
  PPCODE:
  {
    HV *stash = MUST_STASH_FROM_REFSV(metapkg);
    UV retcount = 0;
    hv_iterinit(stash);
    HE *he;
    while((he = hv_iternext(stash))) {
      STRLEN keylen;
      const char *keypv = HePV(he, keylen);
      bool is_subpackage = keylen > 2 && keypv[keylen-2] == ':' && keypv[keylen-1] == ':';
      if(!is_subpackage)
        continue;

      GV *gv = (GV *)HeVAL(he);
      assert(SvTYPE(gv) == SVt_PVGV);
      HV *substash = GvHV(gv);

      EXTEND(SP, 2);

      mPUSHp(keypv, keylen - 2);
      if(HeUTF8(he))
        SvUTF8_on(*SP);

      mPUSHs(wrap_stash(substash));

      retcount += 2;
    }
    XSRETURN(retcount);
  }

MODULE = meta    PACKAGE = meta::symbol

void
DESTROY(SV *metasym)
  CODE:
  {
    SV *sv = SV_FROM_REFSV(metasym);
    SvREFCNT_dec(sv);
  }

bool
is_scalar(SV *metasym)
  CODE:
  {
    SV *sv = SV_FROM_REFSV(metasym);
    RETVAL = SvTYPE(sv) <= SVt_PVMG;
  }
  OUTPUT:
    RETVAL

bool
_is_type(SV *metasym)
  ALIAS:
    is_glob       = SVt_PVGV
    is_array      = SVt_PVAV
    is_hash       = SVt_PVHV
    is_subroutine = SVt_PVCV
  CODE:
  {
    SV *sv = SV_FROM_REFSV(metasym);
    RETVAL = SvTYPE(sv) == ix;
  }
  OUTPUT:
    RETVAL

SV *
reference(SV *metasym)
  CODE:
  {
    SV *sv = SV_FROM_REFSV(metasym);
    RETVAL = newRV_inc(sv);
  }
  OUTPUT:
    RETVAL

MODULE = meta    PACKAGE = meta::glob

SV *
get(SV *cls, SV *globname)
  ALIAS:
    get = GET_OR_THROW
    try_get = GET_OR_UNDEF
    get_or_add = GET_OR_ADD
  CODE:
  {
    if(SvROK(cls))
      croak("meta::glob->get(name) should not be invoked on an instance "
          "(did you mean to call one of the ->get_... methods?)");
    bool create = (ix == GET_OR_ADD);

    warn_experimental("meta::glob->get");
    GV *gv = gv_fetchsv(globname, create ? GV_ADDMULTI : 0, SVt_PVGV);
    if(gv) {
      assert(SvTYPE(gv) == SVt_PVGV);
      RETVAL = wrap_sv_refsv((SV *)gv);
    }
    else switch(ix) {
      case GET_OR_THROW:
        croak("Symbol table does not contain a glob called " templateSVf_QUOTEDPREFIX,
          SVfARG(globname));
      case GET_OR_UNDEF:
        RETVAL = &PL_sv_undef;
        break;

      default:
        NOT_REACHED;
    }
  }
  OUTPUT:
    RETVAL

SV *
basename(SV *metaglob)
  CODE:
  {
    GV *gv = MUST_GV_FROM_REFSV(metaglob);
    RETVAL = newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
  }
  OUTPUT:
    RETVAL

SV *get_scalar(SV *metaglob)
  ALIAS:
    can_scalar = GET_OR_UNDEF_WITH_WARNING
    get_scalar = GET_OR_THROW
    try_get_scalar = GET_OR_UNDEF
  CODE:
    if(ix == GET_OR_UNDEF_WITH_WARNING)
      warn_sub_deprecated(cv);
    RETVAL = S_get_metaglob_slot(aTHX_ metaglob, SVt_PVMG, "scalar", ix);
  OUTPUT:
    RETVAL

SV *get_array(SV *metaglob)
  ALIAS:
    can_array = GET_OR_UNDEF_WITH_WARNING
    get_array = GET_OR_THROW
    try_get_array = GET_OR_UNDEF
  CODE:
    if(ix == GET_OR_UNDEF_WITH_WARNING)
      warn_sub_deprecated(cv);
    RETVAL = S_get_metaglob_slot(aTHX_ metaglob, SVt_PVAV, "array", ix);
  OUTPUT:
    RETVAL

SV *get_hash(SV *metaglob)
  ALIAS:
    can_hash = GET_OR_UNDEF_WITH_WARNING
    get_hash = GET_OR_THROW
    try_get_hash = GET_OR_UNDEF
  CODE:
    if(ix == GET_OR_UNDEF_WITH_WARNING)
      warn_sub_deprecated(cv);
    RETVAL = S_get_metaglob_slot(aTHX_ metaglob, SVt_PVHV, "hash", ix);
  OUTPUT:
    RETVAL

SV *get_code(SV *metaglob)
  ALIAS:
    can_code = GET_OR_UNDEF_WITH_WARNING
    get_code = GET_OR_THROW
    try_get_code = GET_OR_UNDEF
  CODE:
    if(ix == GET_OR_UNDEF_WITH_WARNING)
      warn_sub_deprecated(cv);
    RETVAL = S_get_metaglob_slot(aTHX_ metaglob, SVt_PVCV, "code", ix);
  OUTPUT:
    RETVAL

MODULE = meta    PACKAGE = meta::variable

void
value(SV *metavar)
  PPCODE:
  {
    if(GIMME_V == G_VOID)
      // TODO: warn?
      XSRETURN(0);

    /* TODO: all of the-below is super-fragile and probably doesn't work
     * properly with tied scalars/arrays/hashes. Eugh.
     */

    SV *sv = SV_FROM_REFSV(metavar);
    if(SvTYPE(sv) <= SVt_PVMG) {
      SV *ret = sv_mortalcopy(sv);
      XPUSHs(ret);
      XSRETURN(1);
    }
    else if(SvTYPE(sv) == SVt_PVAV) {
      /* Array */
      AV *av = (AV *)sv;
      UV count = av_count(av);

      if(GIMME_V == G_SCALAR) {
        mXPUSHu(count);
        XSRETURN(1);
      }
      EXTEND(SP, count);
      UV i;
      for(i = 0; i < count; i++)
        PUSHs(sv_mortalcopy(*av_fetch(av, i, 0)));
      XSRETURN(count);
    }
    else if(SvTYPE(sv) == SVt_PVHV) {
      /* Hash */
      HV *hv = (HV *)sv;
      UV count = 0;
      U8 gimme = GIMME_V;

      HE *he;
      hv_iterinit(hv);
      while((he = hv_iternext(hv))) {
        SV *key = HeSVKEY(he);
        if(!key)
          key = newSVpvn_flags(HeKEY(he), HeKLEN(he), HeKFLAGS(he) | SVs_TEMP);

        if(gimme == G_LIST) {
          EXTEND(SP, 2);
          PUSHs(key);
          PUSHs(HeVAL(he));
        }
        count++;
      }

      if(gimme == G_LIST)
        XSRETURN(count * 2);

      mPUSHu(count);
      XSRETURN(1);
    }
    else
      croak("Argh unrecognised SvTYPE(sv)=%d", SvTYPE(sv));
  }

MODULE = meta    PACKAGE = meta::subroutine

bool
is_method(SV *metasub)
  CODE:
  {
#ifdef HAVE_FEATURE_CLASS
    CV *cv = MUST_CV_FROM_REFSV(metasub);
    RETVAL = CvIsMETHOD(cv);
#else
    PERL_UNUSED_VAR(metasub);
    RETVAL = false;
#endif
  }
  OUTPUT:
    RETVAL

SV *
subname(SV *metasub)
  CODE:
  {
    CV *cv = MUST_CV_FROM_REFSV(metasub);

    GV *gv = CvGV(cv);
    if(!gv)
      RETVAL = &PL_sv_undef;
    else
      RETVAL = newSVpvf("%s::%s", HvNAME(GvSTASH(gv)), GvNAME(gv));
  }
  OUTPUT:
    RETVAL

SV *
set_subname(SV *metasub, SV *name)
  CODE:
  {
    CV *cv = MUST_CV_FROM_REFSV(metasub);

    STRLEN namelen;
    const char *namepv = SvPV(name, namelen);

    const char *pkgnamepv, *basenamepv;
    STRLEN pkgnamelen, basenamelen;
    split_fqname(namepv, namelen,
      &pkgnamepv, &pkgnamelen, &basenamepv, &basenamelen);

    HV *stash;
    if(pkgnamelen)
      stash = gv_stashpvn(pkgnamepv, pkgnamelen, GV_ADD | SvUTF8(name));
    else
      stash = CopSTASH(PL_curcop);

    /* We can't just change the name in the sub's GV because that might be
     * shared and break all kinds of things. We'll have to make a new GV.
     */
    GV *newgv = (GV *)newSV(0);
    gv_init_pvn(newgv, stash, basenamepv, basenamelen, SvUTF8(name));

    CvANON_off(cv);
    CvGV_set(cv, newgv);

    /* CvGV_set claimed a reference to newgv; we can drop it now */
    SvREFCNT_dec(newgv);

    RETVAL = SvREFCNT_inc(metasub);
  }
  OUTPUT:
    RETVAL

SV *
prototype(SV *metasub)
  CODE:
  {
    CV *cv = MUST_CV_FROM_REFSV(metasub);

    if(!SvPOK(cv))
      RETVAL = &PL_sv_undef;
    else
      RETVAL = newSVpvn_flags(CvPROTO(cv), CvPROTOLEN(cv), SvUTF8(cv));
  }
  OUTPUT:
    RETVAL

SV *
set_prototype(SV *metasub, SV *proto)
  CODE:
  {
    CV *cv = MUST_CV_FROM_REFSV(metasub);

    if(SvOK(proto))
      sv_copypv((SV *)cv, proto);
    else
      SvPOK_off((SV *)cv);

    RETVAL = SvREFCNT_inc(metasub);
  }
  OUTPUT:
    RETVAL

SV *
signature(SV *metasub)
  CODE:
  {
    CV *cv = MUST_CV_FROM_REFSV(metasub);

    RETVAL = &PL_sv_undef;
#ifdef HAVE_SUB_SIGNATURES
    if(CvISXSUB(cv))
      goto nosig;

    OP *oproot = CvROOT(cv);
    if(!oproot)
      goto nosig;

    /* The optree of a signatured sub should be an OP_LEAVESUB at toplevel.
     * Nested inside will be maybe one or two OP_NULL[OP_LINESEQ[...]]
     * subtrees, inside of which will be a COP, OP_ARGCHECK, ...
     * It is the OP_ARGCHECK we are looking for
     */

    assert(oproot->op_type == OP_LEAVESUB);
    OP *o = cUNOPx(oproot)->op_first;

    U32 flags = 0;

    /* Descend into OP_NULL / OP_LINESEQ trees while skipping past COPs
     */
    while(o) {
      if(o->op_type == OP_NULL)
        o = cUNOPo->op_first;
      else if(o->op_type == OP_LINESEQ)
        o = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
      else if(o->op_type == OP_NEXTSTATE || o->op_type == OP_DBSTATE)
        o = OpSIBLING(o);
#  ifdef HAVE_FEATURE_CLASS
      else if(o->op_type == OP_METHSTART)
        o = OpSIBLING(o), flags |= CVSIGNATURE_IS_METHOD;
#  endif
      else
        break;
    }

    if(!o)
      goto nosig;

    if(o->op_type == OP_ARGCHECK
#ifdef HAVE_OP_MULTIPARAM
       || o->op_type == OP_MULTIPARAM
#endif
    )
      RETVAL = wrap_cv_signature(cv, o, flags);

    nosig:
      ;
#endif
  }
  OUTPUT:
    RETVAL

MODULE = meta    PACKAGE = meta::subsignature

void
DESTROY(SV *metasig)
  CODE:
  {
    struct CVwithOP *cvop = (struct CVwithOP *)SvPVX(SvRV(metasig));

    SvREFCNT_dec(cvop->cv);
    // ->op is not refcounted
  }

SV *
mandatory_params(SV *metasig)
  ALIAS:
    mandatory_params = 0
    optional_params  = 1
    slurpy           = 2
    min_args         = 3
    max_args         = 4
  CODE:
  {
    int params, opt_params;
    size_t n_named;
    char slurpy;
#ifdef HAVE_SUB_SIGNATURES
    struct CVwithOP *cvop = (struct CVwithOP *)SvPVX(SvRV(metasig));
#  if HAVE_PERL_VERSION(5, 31, 5)
#    ifdef HAVE_OP_MULTIPARAM
    struct op_multiparam_aux *aux = NULL;
    if(cvop->op->op_type == OP_MULTIPARAM) {
      aux = (struct op_multiparam_aux *)cUNOP_AUXx(cvop->op)->op_aux;

      params     = aux->n_positional;
      opt_params = params - aux->min_args;
#      ifdef HAVE_OP_MULTIPARAM_NAMED
      n_named    = aux->n_named;
#      else
      n_named    = 0;
#      endif
      slurpy     = aux->slurpy;
    }
    else
#    endif
    {
      struct op_argcheck_aux *aux = (struct op_argcheck_aux *)cUNOP_AUXx(cvop->op)->op_aux;
      params     = aux->params + ((cvop->flags & CVSIGNATURE_IS_METHOD) ? 1 : 0);
      opt_params = aux->opt_params;
      n_named    = 0;
      slurpy     = aux->slurpy;
    }
#  else
    UNOP_AUX_item *aux = cUNOP_AUXx(cvop->op)->op_aux;
    params     = aux[0].iv;
    opt_params = aux[1].iv;
    n_named    = 0;
    slurpy     = aux[2].iv;
#  endif

    switch(ix) {
      case 0: /* mandatory_params */
        RETVAL = newSViv(params - opt_params);
        break;
      case 1: /* optional_params */
        RETVAL = newSViv(opt_params);
        break;
      case 2: /* slurpy */
        RETVAL = slurpy ? newSVpvf("%c", slurpy) : &PL_sv_undef;
        break;
      case 3: /* min_args */
#  ifdef HAVE_OP_MULTIPARAM_NAMED
        if(n_named) {
          int min_args = 0;
          /* Each mandatory named parameter counts for 2 arguments
           */
          for(size_t namedix = 0; namedix < n_named; namedix++) {
            struct op_multiparam_named_aux *named = &(aux->named[namedix]);
            if(named->is_required)
              min_args += 2;
          }
          /* If any named parameters are required then all of the optional
           * positional ones must be passed, to allow for them */
          if(min_args) {
            RETVAL = newSViv(params + min_args);
            break;
          }
        }
        /* else fallthrough */
#  endif
        RETVAL = newSViv(params - opt_params);
        break;
      case 4: /* max_args */
        RETVAL = (slurpy || n_named) ? &PL_sv_undef : newSViv(params);
        break;

      default:
        NOT_REACHED;
    }
#endif
  }
  OUTPUT:
    RETVAL

void
named_params(SV *metasig)
  PPCODE:
  {
#ifdef HAVE_OP_MULTIPARAM_NAMED
    struct CVwithOP *cvop = (struct CVwithOP *)SvPVX(SvRV(metasig));
    if(cvop->op->op_type != OP_MULTIPARAM)
      XSRETURN(0);

    struct op_multiparam_aux *aux = (struct op_multiparam_aux *)cUNOP_AUXx(cvop->op)->op_aux;
    size_t n_named = aux->n_named;
    EXTEND(SP, 2 * n_named);
    for(size_t namedix = 0; namedix < n_named; namedix++) {
      struct op_multiparam_named_aux *named = &(aux->named[namedix]);
      PUSHs(newSVpvn_flags(named->namepv, named->namelen, SVf_UTF8|SVs_TEMP));
      mPUSHs(newSVmultiparam_named(named));
    }
    XSRETURN(2 * n_named);
#else
    XSRETURN(0);
#endif
  }

MODULE = meta    PACKAGE = meta::subsignature::named_param

void DESTROY(SV *metaparam)
  CODE:
  {
#ifdef HAVE_OP_MULTIPARAM_NAMED
    struct op_multiparam_named_aux *aux = MULTIPARAM_NAMED_FROM_REFSV(metaparam);
#endif
  }

SV *name(SV *metaparam)
  CODE:
  {
#ifdef HAVE_OP_MULTIPARAM_NAMED
    struct op_multiparam_named_aux *aux = MULTIPARAM_NAMED_FROM_REFSV(metaparam);
    RETVAL = newSVpvn_flags(aux->namepv, aux->namelen, SVf_UTF8);
#else
    RETVAL = &PL_sv_undef;
#endif
  }
  OUTPUT:
    RETVAL

bool is_required(SV *metaparam)
  CODE:
  {
#ifdef HAVE_OP_MULTIPARAM_NAMED
    struct op_multiparam_named_aux *aux = MULTIPARAM_NAMED_FROM_REFSV(metaparam);
    RETVAL = aux->is_required;
#else
    RETVAL = false;
#endif
  }
  OUTPUT:
    RETVAL

BOOT:
  warnings_register_category(META_WARNING_CATEGORY);