File Coverage

lib/meta.xs

Criterion	Covered	Total	%
statement	148	180	82.2
branch	122	232	52.5
condition			n/a
subroutine			n/a
pod			n/a
total	270	412	65.5

/*  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)
#endif

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

#ifndef G_LIST
#  define G_LIST  G_ARRAY
#endif

/* TODO: Define also for compilers without gcc bracegroups */
#define _MUST_SVTYPE_FROM_REFSV(rsv, type, svt)  \
  ({ type sv = (type)(SvUV(SvRV(rsv))); assert(sv && SvTYPE(sv) == svt); sv; })

#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)
{
  SV *ret = newSV(0);
  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(sv));
}

#ifdef SVf_QUOTEDPREFIX
#  define CROAK_QUOTED_PREFIX(msg, arg)  \
    croak(msg "%" SVf_QUOTEDPREFIX, arg)
#else
#  define CROAK_QUOTED_PREFIX(msg, arg)  \
    croak(msg "\"%" SVf "\"", arg)
#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;
}

MODULE = meta    PACKAGE = meta

SV *
get_package(SV *pkgname)
  CODE:
  {
    HV *stash = gv_stashsv(pkgname, GV_ADD);
    RETVAL = newSV(0);
    // TODO: Do we need to refcnt_inc stash?
    sv_setref_uv(RETVAL, "meta::package", PTR2UV(stash));
  }
  OUTPUT:
    RETVAL

MODULE = meta    PACKAGE = meta::package

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 = 0
    get_glob = 1
  CODE:
  {
    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 = newSV(0);
      // TODO: DO we need to refcnt_inc gv?
      sv_setref_uv(RETVAL, "meta::glob", PTR2UV(gv));
    }
    else if(ix)
      CROAK_QUOTED_PREFIX("Package does not contain a glob called ", SVfARG(name));
    else
      RETVAL = &PL_sv_undef;
  }
  OUTPUT:
    RETVAL

SV *
get_symbol(SV *metapkg, SV *name)
  ALIAS:
    can_symbol = 0
    get_symbol = 1
  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);
    SV *ret = NULL;
    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;
      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 *)GvCV(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));

    missing:
    if(ret)
      RETVAL = wrap_sv_refsv(ret);
    else if(ix)
      CROAK_QUOTED_PREFIX("Package has no symbol named ", SVfARG(name));
    else
      RETVAL = &PL_sv_undef;
  }
  OUTPUT:
    RETVAL

SV *
add_symbol(SV *metapkg, SV *name, SV *value)
  CODE:
  {
    HV *stash = MUST_STASH_FROM_REFSV(metapkg);
    char sigil = SvPV_nolen(name)[0];
    if(!SvROK(value))
      croak("Expected a reference for the new value to add_symbol");

    SV *sv = SvRV(value);
    switch(sigil) {
      case '*':
        croak("TODO: Cannot currently cope with adding GLOBs via ->add_symbol");
        break;
      case '$':
        if(SvTYPE(sv) > SVt_PVMG)
          croak("Expected a SCALAR reference for the new value to add_symbol('$...')");
        break;
      case '@':
        if(SvTYPE(sv) != SVt_PVAV)
          croak("Expected a ARRAY reference for the new value to add_symbol('@...')");
        break;
      case '%':
        if(SvTYPE(sv) != SVt_PVHV)
          croak("Expected a HASH reference for the new value to add_symbol('%...')");
        break;
      case '&':
        if(SvTYPE(sv) != 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);
    HE *he = hv_fetch_ent(stash, basename, GV_ADD, 0);
    GV *gv = (GV *)HeVAL(he);
    if(SvTYPE(gv) != SVt_PVGV) {
      gv_init_sv(gv, stash, basename, 0);
    }

    switch(sigil) {
      case '$':
        if(GvSV(gv))
          CROAK_QUOTED_PREFIX("Already have a symbol named ", SVfARG(name));
        GvSV(gv) = SvREFCNT_inc(sv);
        break;
      case '@':
        if(GvAV(gv))
          CROAK_QUOTED_PREFIX("Already have a symbol named ", SVfARG(name));
        GvAV(gv) = (AV *)SvREFCNT_inc(sv);
        break;
      case '%':
        if(GvHV(gv))
          CROAK_QUOTED_PREFIX("Already have a symbol named ", SVfARG(name));
        GvHV(gv) = (HV *)SvREFCNT_inc(sv);
        break;
      case '&':
        if(GvCV(gv))
          CROAK_QUOTED_PREFIX("Already have a symbol named ", SVfARG(name));
        GvCV_set(gv, (CV *)SvREFCNT_inc(sv));
        break;
    }
    RETVAL = wrap_sv_refsv(sv);
  }
  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);
    SV *ret = NULL;
    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 *)GvCV(gv); GvCV_set(gv, NULL);
          break;
      }

      if(!sv)
        missing:
        CROAK_QUOTED_PREFIX("Cannot remove non-existing symbol from package: ", SVfARG(name));

      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));
  }

MODULE = meta    PACKAGE = meta::symbol

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 *
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_slot(SV *metaglob)
  ALIAS:
    can_scalar =    1
    get_scalar = 0x81
    can_array  =    2
    get_array  = 0x82
    can_hash   =    3
    get_hash   = 0x83
    can_code   =    4
    get_code   = 0x84
  CODE:
  {
    GV *gv = MUST_GV_FROM_REFSV(metaglob);
    SV *ret;
    switch(ix & ~0x80) {
      case 1: ret =       GvSV(gv); break;
      case 2: ret = (SV *)GvAV(gv); break;
      case 3: ret = (SV *)GvHV(gv); break;
      case 4: ret = (SV *)GvCV(gv); break;
    }
    if(ret)
      RETVAL = wrap_sv_refsv(ret);
    else if(ix & 0x80)
      croak("Glob does not have a %s slot",
        ((const char *[]){NULL, "scalar", "array", "hash", "code"})[ix & ~0x80]);
    else
      RETVAL = &PL_sv_undef;
  }
  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);
      for(UV 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

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 *
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