view release on metacpan or  search on metacpan

XS.xs  view on Meta::CPAN

    SV *self
    varspec_t variable
  PREINIT:
    SV *val;
  CODE:
    val = _get_symbol(self, &variable, 1);
    if (!val)
        XSRETURN_UNDEF;
    RETVAL = newRV_inc(val);
  OUTPUT:
    RETVAL

void
remove_symbol(self, variable)
    SV *self
    varspec_t variable
  PREINIT:
    HV *namespace;
    HE *entry;
    SV *val;
  CODE:
    namespace = _get_namespace(self);
    entry = hv_fetch_ent(namespace, variable.name, 0, 0);
    if (!entry)
        XSRETURN_EMPTY;

    val = HeVAL(entry);
    if (isGV(val)) {
        GV *glob = (GV*)val;
        switch (variable.type) {
        case VAR_SCALAR:
            GvSetSV(glob, NULL);
            break;
        case VAR_ARRAY:
            GvSetAV(glob, NULL);
            break;
        case VAR_HASH:
            GvSetHV(glob, NULL);
            break;
        case VAR_CODE:
            GvSetCV(glob, NULL);
            break;
        case VAR_IO:
            GvSetIO(glob, NULL);
            break;
        default:
            croak("Unknown variable type in remove_symbol");
            break;
        }
    }
    else {
        if (variable.type == VAR_CODE) {
            hv_delete_ent(namespace, variable.name, G_DISCARD, 0);
        }
    }

void
list_all_symbols(self, vartype=VAR_NONE)
    SV *self
    vartype_t vartype
  PPCODE:
    if (vartype == VAR_NONE) {
        HV *namespace;
        HE *entry;
        int keys;

        namespace = _get_namespace(self);
        keys = hv_iterinit(namespace);
        EXTEND(SP, keys);
        while ((entry = hv_iternext(namespace))) {
#if PERL_VERSION < 10
            char *pv;
            STRLEN len;
            pv = HePV(entry, len);
            if (strnEQ(entry, "::ISA::CACHE::", len)) {
                continue;
            }
#endif
            mPUSHs(newSVhe(entry));
        }
    }
    else {
        HV *namespace;
        SV *val;
        char *key;
        I32 len;

        namespace = _get_namespace(self);
        hv_iterinit(namespace);
        while ((val = hv_iternextsv(namespace, &key, &len))) {
            GV *gv = (GV*)val;
#if PERL_VERSION < 10
            if (vartype == VAR_SCALAR && strnEQ(key, "::ISA::CACHE::", len)) {
                continue;
            }
#endif
            if (isGV(gv)) {
                switch (vartype) {
                case VAR_SCALAR:
                    if (GvSVOK(val))
                        mXPUSHp(key, len);
                    break;
                case VAR_ARRAY:
                    if (GvAVOK(val))
                        mXPUSHp(key, len);
                    break;
                case VAR_HASH:
                    if (GvHVOK(val))
                        mXPUSHp(key, len);
                    break;
                case VAR_CODE:
                    if (GvCVOK(val))
                        mXPUSHp(key, len);
                    break;
                case VAR_IO:
                    if (GvIOOK(val))
                        mXPUSHp(key, len);
                    break;
                default:
                    croak("Unknown variable type in list_all_symbols");
                }
            }
            else if (vartype == VAR_CODE) {
                mXPUSHp(key, len);
            }
        }
    }

void
get_all_symbols(self, vartype=VAR_NONE)
    SV *self
    vartype_t vartype
  PREINIT:
    HV *namespace, *ret;
    HE *entry;
  PPCODE:
    namespace = _get_namespace(self);
    ret = newHV();

    hv_iterinit(namespace);
    while ((entry = hv_iternext(namespace))) {
        GV *gv = (GV*)hv_iterval(namespace, entry);
        char *key;
        I32 len;

        key = hv_iterkey(entry, &len);
#if PERL_VERSION < 10
        if ((vartype == VAR_SCALAR || vartype == VAR_NONE)
            && strnEQ(key, "::ISA::CACHE::", len)) {
            continue;
        }
#endif

        if (!isGV(gv)) {
            SV *keysv = newSVpvn(key, len);
            _expand_glob(self, keysv, entry, namespace, 0);
            SvREFCNT_dec(keysv);
        }

        switch (vartype) {
        case VAR_SCALAR:
            if (GvSVOK(gv))
                hv_store(ret, key, len, newRV_inc(GvSV(gv)), 0);
            break;
        case VAR_ARRAY:
            if (GvAVOK(gv))
                hv_store(ret, key, len, newRV_inc((SV*)GvAV(gv)), 0);
            break;
        case VAR_HASH:
            if (GvHVOK(gv))
                hv_store(ret, key, len, newRV_inc((SV*)GvHV(gv)), 0);
            break;
        case VAR_CODE:
            if (GvCVOK(gv))
                hv_store(ret, key, len, newRV_inc((SV*)GvCV(gv)), 0);
            break;
        case VAR_IO:
            if (GvIOOK(gv))
                hv_store(ret, key, len, newRV_inc((SV*)GvIO(gv)), 0);
            break;
        case VAR_NONE:
            hv_store(ret, key, len, SvREFCNT_inc_simple_NN((SV*)gv), 0);
            break;
        default:
            croak("Unknown variable type in get_all_symbols");
        }
    }

    mPUSHs(newRV_noinc((SV*)ret));

BOOT:
    {
        const char *vmre = "\\A[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*\\z";
#if (PERL_VERSION < 9) || ((PERL_VERSION == 9) && (PERL_SUBVERSION < 5))
        PMOP fakepmop;