[gitmo/Package-Stash-XS.git] / Stash.xs

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

#define NEED_newRV_noinc
#define NEED_sv_2pv_flags
#include "ppport.h"

#ifndef gv_fetchsv
#define gv_fetchsv(n,f,t) gv_fetchpv(SvPV_nolen(n), f, t)
#endif

#ifndef mro_method_changed_in
#define mro_method_changed_in(x) PL_sub_generation++
#endif

#ifdef newSVhek
#define newSVhe(he) newSVhek(HeKEY_hek(he))
#else
#define newSVhe(he) newSVpvn(HePV(he))
#endif

#ifndef savesvpv
#define savesvpv(s) savepv(SvPV_nolen(s))
#endif

typedef enum {
    VAR_NONE = 0,
    VAR_SCALAR,
    VAR_ARRAY,
    VAR_HASH,
    VAR_CODE,
    VAR_IO,
    VAR_GLOB,  /* TODO: unimplemented */
    VAR_FORMAT /* TODO: unimplemented */
} vartype_t;

typedef struct {
    vartype_t type;
    char sigil;
    char *name;
} varspec_t;

const char *vartype_to_string(vartype_t type)
{
    switch (type) {
    case VAR_SCALAR:
        return "SCALAR";
    case VAR_ARRAY:
        return "ARRAY";
    case VAR_HASH:
        return "HASH";
    case VAR_CODE:
        return "CODE";
    case VAR_IO:
        return "IO";
    default:
        return "unknown";
    }
}

I32 vartype_to_svtype(vartype_t type)
{
    switch (type) {
    case VAR_SCALAR:
        return SVt_PV; /* or whatever */
    case VAR_ARRAY:
        return SVt_PVAV;
    case VAR_HASH:
        return SVt_PVHV;
    case VAR_CODE:
        return SVt_PVCV;
    case VAR_IO:
        return SVt_PVIO;
    default:
        return SVt_NULL;
    }
}

vartype_t string_to_vartype(char *vartype)
{
    if (strEQ(vartype, "SCALAR")) {
        return VAR_SCALAR;
    }
    else if (strEQ(vartype, "ARRAY")) {
        return VAR_ARRAY;
    }
    else if (strEQ(vartype, "HASH")) {
        return VAR_HASH;
    }
    else if (strEQ(vartype, "CODE")) {
        return VAR_CODE;
    }
    else if (strEQ(vartype, "IO")) {
        return VAR_IO;
    }
    else {
        croak("Type must be one of 'SCALAR', 'ARRAY', 'HASH', 'CODE', or 'IO'");
    }
}

void _deconstruct_variable_name(char *variable, varspec_t *varspec)
{
    if (!variable || !variable[0])
        croak("You must pass a variable name");

    varspec->type = VAR_NONE;

    switch (variable[0]) {
    case '$':
        varspec->type = VAR_SCALAR;
        break;
    case '@':
        varspec->type = VAR_ARRAY;
        break;
    case '%':
        varspec->type = VAR_HASH;
        break;
    case '&':
        varspec->type = VAR_CODE;
        break;
    }

    if (varspec->type != VAR_NONE) {
        varspec->sigil = variable[0];
        varspec->name = &variable[1];
    }
    else {
        varspec->type = VAR_IO;
        varspec->sigil = '\0';
        varspec->name = variable;
    }
}

void _deconstruct_variable_hash(HV *variable, varspec_t *varspec)
{
    SV **val;

    val = hv_fetch(variable, "name", 4, 0);
    if (!val)
        croak("The 'name' key is required in variable specs");

    varspec->name = savesvpv(*val);
    SAVEFREEPV(varspec->name);

    val = hv_fetch(variable, "sigil", 5, 0);
    if (!val)
        croak("The 'sigil' key is required in variable specs");

    varspec->sigil = (SvPV_nolen(*val))[0];

    val = hv_fetch(variable, "type", 4, 0);
    if (!val)
        croak("The 'type' key is required in variable specs");

    varspec->type = string_to_vartype(SvPV_nolen(*val));
}

int _valid_for_type(SV *value, vartype_t type)
{
    svtype sv_type = SvROK(value) ? SvTYPE(SvRV(value)) : SVt_NULL;

    switch (type) {
    case VAR_SCALAR:
        return sv_type == SVt_NULL ||
               sv_type == SVt_IV   ||
               sv_type == SVt_NV   ||
               sv_type == SVt_PV   ||
               sv_type == SVt_RV;
    case VAR_ARRAY:
        return sv_type == SVt_PVAV;
    case VAR_HASH:
        return sv_type == SVt_PVHV;
    case VAR_CODE:
        return sv_type == SVt_PVCV;
    case VAR_IO:
        return sv_type == SVt_PVIO;
    default:
        return 0;
    }
}

HV *_get_namespace(SV *self)
{
    dSP;
    SV *ret;

    PUSHMARK(SP);
    XPUSHs(self);
    PUTBACK;

    call_method("namespace", G_SCALAR);

    SPAGAIN;
    ret = POPs;
    PUTBACK;

    return (HV*)SvRV(ret);
}

SV *_get_name(SV *self)
{
    dSP;
    SV *ret;

    PUSHMARK(SP);
    XPUSHs(self);
    PUTBACK;

    call_method("name", G_SCALAR);

    SPAGAIN;
    ret = POPs;
    PUTBACK;

    return ret;
}

SV *_get_symbol(SV *self, varspec_t *variable, int vivify)
{
    HV *namespace;
    SV **entry;
    GV *glob;

    namespace = _get_namespace(self);
    entry = hv_fetch(namespace, variable->name, strlen(variable->name), vivify);
    if (!entry)
        return NULL;

    glob = (GV*)(*entry);
    if (!isGV(glob)) {
        SV *namesv;

        namesv = newSVsv(_get_name(self));
        sv_catpvs(namesv, "::");
        sv_catpv(namesv, variable->name);

        /* can't use gv_init here, because it screws up @ISA in a way that I
         * can't reproduce, but that CMOP triggers */
        gv_fetchsv(namesv, GV_ADD, vartype_to_svtype(variable->type));
        SvREFCNT_dec(namesv);
    }

    if (vivify) {
        switch (variable->type) {
        case VAR_SCALAR:
            if (!GvSV(glob))
                GvSV(glob) = newSV(0);
            break;
        case VAR_ARRAY:
            if (!GvAV(glob))
                GvAV(glob) = newAV();
            break;
        case VAR_HASH:
            if (!GvHV(glob))
                GvHV(glob) = newHV();
            break;
        case VAR_CODE:
            croak("Don't know how to vivify CODE variables");
        case VAR_IO:
            if (!GvIO(glob))
                GvIOp(glob) = newIO();
            break;
        default:
            croak("Unknown type in vivication");
        }
    }

    switch (variable->type) {
    case VAR_SCALAR:
        return GvSV(glob);
    case VAR_ARRAY:
        return (SV*)GvAV(glob);
    case VAR_HASH:
        return (SV*)GvHV(glob);
    case VAR_CODE:
        return (SV*)GvCV(glob);
    case VAR_IO:
        return (SV*)GvIO(glob);
    default:
        return NULL;
    }
}

MODULE = Package::Stash  PACKAGE = Package::Stash

PROTOTYPES: DISABLE

SV*
new(class, package_name)
    char *class
    SV *package_name
  PREINIT:
    HV *instance;
    HV *namespace;
    SV *nsref;
  CODE:
    if (!SvPOK(package_name))
        croak("The constructor argument must be the name of a package");

    instance = newHV();

    if (!hv_store(instance, "name", 4, SvREFCNT_inc_simple_NN(package_name), 0)) {
        SvREFCNT_dec(package_name);
        SvREFCNT_dec(instance);
        croak("Couldn't initialize the 'name' key, hv_store failed");
    }
    namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD);
    nsref = newRV_inc((SV*)namespace);
    if (!hv_store(instance, "namespace", 9, nsref, 0)) {
        SvREFCNT_dec(nsref);
        SvREFCNT_dec(instance);
        croak("Couldn't initialize the 'namespace' key, hv_store failed");
    }

    RETVAL = sv_bless(newRV_noinc((SV*)instance), gv_stashpv(class, 0));
  OUTPUT:
    RETVAL

SV*
name(self)
    SV *self
  PREINIT:
    SV **slot;
  CODE:
    if (!sv_isobject(self))
        croak("Can't call name as a class method");
    slot = hv_fetch((HV*)SvRV(self), "name", 4, 0);
    RETVAL = slot ? SvREFCNT_inc_simple_NN(*slot) : &PL_sv_undef;
  OUTPUT:
    RETVAL

SV*
namespace(self)
    SV *self
  PREINIT:
    SV **slot;
  CODE:
    if (!sv_isobject(self))
        croak("Can't call namespace as a class method");
    slot = hv_fetch((HV*)SvRV(self), "namespace", 9, 0);
    RETVAL = slot ? SvREFCNT_inc_simple_NN(*slot) : &PL_sv_undef;
  OUTPUT:
    RETVAL

void
add_symbol(self, variable, initial=NULL, ...)
    SV *self
    varspec_t variable
    SV *initial
  PREINIT:
    SV *name;
    GV *glob;
  CODE:
    if (initial && !_valid_for_type(initial, variable.type))
        croak("%s is not of type %s",
              SvPV_nolen(initial), vartype_to_string(variable.type));

    name = newSVsv(_get_name(self));
    sv_catpvs(name, "::");
    sv_catpv(name, variable.name);

    /* XXX: come back to this when i feel like reimplementing caller() */
/*
    my $filename = $opts{filename};
    my $first_line_num = $opts{first_line_num};

    (undef, $filename, $first_line_num) = caller
        if not defined $filename;

    my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0);

    # http://perldoc.perl.org/perldebguts.html#Debugger-Internals
    $DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num";
*/
/*
    if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) {
        int i;
        char *filename = NULL, *name;
        I32 first_line_num, last_line_num;

        if ((items - 3) % 2)
            croak("add_symbol: Odd number of elements in %%opts");

        for (i = 3; i < items; i += 2) {
            char *key;
            key = SvPV_nolen(ST(i));
            if (strEQ(key, "filename")) {
                if (!SvPOK(ST(i + 1)))
                    croak("add_symbol: filename must be a string");
                filename = SvPV_nolen(ST(i + 1));
            }
            else if (strEQ(key, "first_line_num")) {
                if (!SvIOK(ST(i + 1)))
                    croak("add_symbol: first_line_num must be an integer");
                first_line_num = SvIV(ST(i + 1));
            }
            else if (strEQ(key, "last_line_num")) {
                if (!SvIOK(ST(i + 1)))
                    croak("add_symbol: last_line_num must be an integer");
                last_line_num = SvIV(ST(i + 1));
            }
        }

        if (!filename) {
        }
    }
*/

    glob = gv_fetchsv(name, GV_ADDMULTI, vartype_to_svtype(variable.type));

    if (initial) {
        SV *val;

        if (SvROK(initial)) {
            val = SvRV(initial);
            SvREFCNT_inc_simple_void_NN(val);
        }
        else {
            val = newSVsv(initial);
        }

        switch (variable.type) {
        case VAR_SCALAR:
            SvREFCNT_dec(GvSV(glob));
            GvSV(glob) = val;
            GvIMPORTED_SV_on(glob);
            break;
        case VAR_ARRAY:
            SvREFCNT_dec(GvAV(glob));
            GvAV(glob) = (AV*)val;
            GvIMPORTED_AV_on(glob);
            break;
        case VAR_HASH:
            SvREFCNT_dec(GvHV(glob));
            GvHV(glob) = (HV*)val;
            GvIMPORTED_HV_on(glob);
            break;
        case VAR_CODE:
            SvREFCNT_dec(GvCV(glob));
            GvCV(glob) = (CV*)val;
            GvIMPORTED_CV_on(glob);
            GvASSUMECV_on(glob);
            GvCVGEN(glob) = 0;
            mro_method_changed_in(GvSTASH(glob));
            break;
        case VAR_IO:
            SvREFCNT_dec(GvIO(glob));
            GvIOp(glob) = (IO*)val;
            break;
        }
    }

    SvREFCNT_dec(name);

void
remove_glob(self, name)
    SV *self
    char *name
  CODE:
    hv_delete(_get_namespace(self), name, strlen(name), G_DISCARD);

int
has_symbol(self, variable)
    SV *self
    varspec_t variable
  PREINIT:
    HV *namespace;
    SV **entry;
  CODE:
    namespace = _get_namespace(self);
    entry = hv_fetch(namespace, variable.name, strlen(variable.name), 0);
    if (!entry)
        XSRETURN_UNDEF;

    if (isGV(*entry)) {
        GV *glob = (GV*)(*entry);
        switch (variable.type) {
        case VAR_SCALAR:
            RETVAL = GvSV(glob) ? 1 : 0;
            break;
        case VAR_ARRAY:
            RETVAL = GvAV(glob) ? 1 : 0;
            break;
        case VAR_HASH:
            RETVAL = GvHV(glob) ? 1 : 0;
            break;
        case VAR_CODE:
            RETVAL = GvCV(glob) ? 1 : 0;
            break;
        case VAR_IO:
            RETVAL = GvIO(glob) ? 1 : 0;
            break;
        }
    }
    else {
        RETVAL = (variable.type == VAR_CODE);
    }
  OUTPUT:
    RETVAL

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

SV*
get_or_add_symbol(self, variable)
    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;
    SV **entry;
  CODE:
    namespace = _get_namespace(self);
    entry = hv_fetch(namespace, variable.name, strlen(variable.name), 0);
    if (!entry)
        XSRETURN_EMPTY;

    if (isGV(*entry)) {
        GV *glob = (GV*)(*entry);
        switch (variable.type) {
        case VAR_SCALAR:
            GvSV(glob) = (SV *)NULL;
            break;
        case VAR_ARRAY:
            GvAV(glob) = (AV *)NULL;
            break;
        case VAR_HASH:
            GvHV(glob) = (HV *)NULL;
            break;
        case VAR_CODE:
            GvCV(glob) = (CV *)NULL;
            GvCVGEN(glob) = 0;
            mro_method_changed_in(GvSTASH(glob));
            break;
        case VAR_IO:
            GvIOp(glob) = (IO *)NULL;
            break;
        }
    }
    else {
        if (variable.type == VAR_CODE) {
            hv_delete(namespace, variable.name, strlen(variable.name), G_DISCARD);
        }
    }

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))) {
            mPUSHs(newSVhe(entry));
        }
    }
    else {
        HV *namespace;
        SV *val;
        char *key;
        int len;

        namespace = _get_namespace(self);
        hv_iterinit(namespace);
        while ((val = hv_iternextsv(namespace, &key, &len))) {
            GV *gv = (GV*)val;
            if (isGV(gv)) {
                switch (vartype) {
                case VAR_SCALAR:
                    if (GvSV(val))
                        mXPUSHp(key, len);
                    break;
                case VAR_ARRAY:
                    if (GvAV(val))
                        mXPUSHp(key, len);
                    break;
                case VAR_HASH:
                    if (GvHV(val))
                        mXPUSHp(key, len);
                    break;
                case VAR_CODE:
                    if (GvCVu(val))
                        mXPUSHp(key, len);
                    break;
                case VAR_IO:
                    if (GvIO(val))
                        mXPUSHp(key, len);
                    break;
                }
            }
            else if (vartype == VAR_CODE) {
                mXPUSHp(key, len);
            }
        }
    }
Commit	Line	Data
59017825	1	#include "EXTERN.h"
	2	#include "perl.h"
	3	#include "XSUB.h"
	4
dfabcbae	5	#define NEED_newRV_noinc
	6	#define NEED_sv_2pv_flags
	7	#include "ppport.h"
	8
13f8a7b7	9	#ifndef gv_fetchsv
	10	#define gv_fetchsv(n,f,t) gv_fetchpv(SvPV_nolen(n), f, t)
	11	#endif
	12
	13	#ifndef mro_method_changed_in
	14	#define mro_method_changed_in(x) PL_sub_generation++
	15	#endif
	16
	17	#ifdef newSVhek
	18	#define newSVhe(he) newSVhek(HeKEY_hek(he))
	19	#else
	20	#define newSVhe(he) newSVpvn(HePV(he))
	21	#endif
	22
	23	#ifndef savesvpv
	24	#define savesvpv(s) savepv(SvPV_nolen(s))
	25	#endif
	26
a382a84b	27	typedef enum {
	28	VAR_NONE = 0,
	29	VAR_SCALAR,
	30	VAR_ARRAY,
	31	VAR_HASH,
	32	VAR_CODE,
	33	VAR_IO,
	34	VAR_GLOB, /* TODO: unimplemented */
	35	VAR_FORMAT /* TODO: unimplemented */
	36	} vartype_t;
	37
	38	typedef struct {
	39	vartype_t type;
	40	char sigil;
	41	char *name;
	42	} varspec_t;
	43
76f7c306	44	const char *vartype_to_string(vartype_t type)
	45	{
	46	switch (type) {
	47	case VAR_SCALAR:
	48	return "SCALAR";
	49	case VAR_ARRAY:
	50	return "ARRAY";
	51	case VAR_HASH:
	52	return "HASH";
	53	case VAR_CODE:
	54	return "CODE";
	55	case VAR_IO:
	56	return "IO";
	57	default:
	58	return "unknown";
	59	}
	60	}
	61
	62	I32 vartype_to_svtype(vartype_t type)
	63	{
	64	switch (type) {
	65	case VAR_SCALAR:
	66	return SVt_PV; /* or whatever */
	67	case VAR_ARRAY:
	68	return SVt_PVAV;
	69	case VAR_HASH:
	70	return SVt_PVHV;
	71	case VAR_CODE:
	72	return SVt_PVCV;
	73	case VAR_IO:
	74	return SVt_PVIO;
	75	default:
	76	return SVt_NULL;
	77	}
	78	}
	79
a382a84b	80	vartype_t string_to_vartype(char *vartype)
	81	{
	82	if (strEQ(vartype, "SCALAR")) {
	83	return VAR_SCALAR;
	84	}
	85	else if (strEQ(vartype, "ARRAY")) {
	86	return VAR_ARRAY;
	87	}
	88	else if (strEQ(vartype, "HASH")) {
	89	return VAR_HASH;
	90	}
	91	else if (strEQ(vartype, "CODE")) {
	92	return VAR_CODE;
	93	}
	94	else if (strEQ(vartype, "IO")) {
	95	return VAR_IO;
	96	}
	97	else {
	98	croak("Type must be one of 'SCALAR', 'ARRAY', 'HASH', 'CODE', or 'IO'");
	99	}
	100	}
	101
	102	void _deconstruct_variable_name(char variable, varspec_t varspec)
	103	{
	104	if (!variable \|\| !variable[0])
	105	croak("You must pass a variable name");
	106
	107	varspec->type = VAR_NONE;
	108
	109	switch (variable[0]) {
	110	case '$':
	111	varspec->type = VAR_SCALAR;
	112	break;
	113	case '@':
	114	varspec->type = VAR_ARRAY;
	115	break;
	116	case '%':
	117	varspec->type = VAR_HASH;
	118	break;
	119	case '&':
	120	varspec->type = VAR_CODE;
	121	break;
	122	}
	123
	124	if (varspec->type != VAR_NONE) {
	125	varspec->sigil = variable[0];
	126	varspec->name = &variable[1];
	127	}
	128	else {
	129	varspec->type = VAR_IO;
	130	varspec->sigil = '\0';
	131	varspec->name = variable;
	132	}
	133	}
	134
	135	void _deconstruct_variable_hash(HV variable, varspec_t varspec)
	136	{
	137	SV **val;
a382a84b	138
	139	val = hv_fetch(variable, "name", 4, 0);
	140	if (!val)
	141	croak("The 'name' key is required in variable specs");
	142
	143	varspec->name = savesvpv(*val);
301f570b	144	SAVEFREEPV(varspec->name);
a382a84b	145
	146	val = hv_fetch(variable, "sigil", 5, 0);
	147	if (!val)
	148	croak("The 'sigil' key is required in variable specs");
	149
	150	varspec->sigil = (SvPV_nolen(*val))[0];
	151
	152	val = hv_fetch(variable, "type", 4, 0);
	153	if (!val)
	154	croak("The 'type' key is required in variable specs");
	155
	156	varspec->type = string_to_vartype(SvPV_nolen(*val));
	157	}
	158
	159	int _valid_for_type(SV *value, vartype_t type)
	160	{
	161	svtype sv_type = SvROK(value) ? SvTYPE(SvRV(value)) : SVt_NULL;
	162
	163	switch (type) {
	164	case VAR_SCALAR:
	165	return sv_type == SVt_NULL \|\|
	166	sv_type == SVt_IV \|\|
	167	sv_type == SVt_NV \|\|
	168	sv_type == SVt_PV \|\|
	169	sv_type == SVt_RV;
	170	case VAR_ARRAY:
	171	return sv_type == SVt_PVAV;
	172	case VAR_HASH:
	173	return sv_type == SVt_PVHV;
	174	case VAR_CODE:
	175	return sv_type == SVt_PVCV;
	176	case VAR_IO:
76f7c306	177	return sv_type == SVt_PVIO;
a382a84b	178	default:
	179	return 0;
	180	}
	181	}
	182
3fd56b4d	183	HV _get_namespace(SV self)
	184	{
	185	dSP;
	186	SV *ret;
	187
	188	PUSHMARK(SP);
	189	XPUSHs(self);
	190	PUTBACK;
	191
612dcf3b	192	call_method("namespace", G_SCALAR);
3fd56b4d	193
	194	SPAGAIN;
	195	ret = POPs;
	196	PUTBACK;
	197
	198	return (HV*)SvRV(ret);
	199	}
	200
76f7c306	201	SV _get_name(SV self)
	202	{
	203	dSP;
	204	SV *ret;
	205
	206	PUSHMARK(SP);
	207	XPUSHs(self);
	208	PUTBACK;
	209
612dcf3b	210	call_method("name", G_SCALAR);
76f7c306	211
	212	SPAGAIN;
	213	ret = POPs;
	214	PUTBACK;
	215
	216	return ret;
	217	}
	218
15c104e2	219	SV _get_symbol(SV self, varspec_t *variable, int vivify)
4871b1a0	220	{
	221	HV *namespace;
	222	SV **entry;
	223	GV *glob;
	224
	225	namespace = _get_namespace(self);
	226	entry = hv_fetch(namespace, variable->name, strlen(variable->name), vivify);
	227	if (!entry)
	228	return NULL;
	229
	230	glob = (GV)(entry);
	231	if (!isGV(glob)) {
	232	SV *namesv;
4871b1a0	233
	234	namesv = newSVsv(_get_name(self));
	235	sv_catpvs(namesv, "::");
	236	sv_catpv(namesv, variable->name);
	237
b55c97c2	238	/* can't use gv_init here, because it screws up @ISA in a way that I
	239	* can't reproduce, but that CMOP triggers */
	240	gv_fetchsv(namesv, GV_ADD, vartype_to_svtype(variable->type));
02b2a57f	241	SvREFCNT_dec(namesv);
4871b1a0	242	}
	243
	244	if (vivify) {
	245	switch (variable->type) {
	246	case VAR_SCALAR:
	247	if (!GvSV(glob))
	248	GvSV(glob) = newSV(0);
	249	break;
	250	case VAR_ARRAY:
	251	if (!GvAV(glob))
	252	GvAV(glob) = newAV();
	253	break;
	254	case VAR_HASH:
	255	if (!GvHV(glob))
	256	GvHV(glob) = newHV();
	257	break;
	258	case VAR_CODE:
	259	croak("Don't know how to vivify CODE variables");
	260	case VAR_IO:
	261	if (!GvIO(glob))
	262	GvIOp(glob) = newIO();
	263	break;
	264	default:
	265	croak("Unknown type in vivication");
	266	}
	267	}
	268
	269	switch (variable->type) {
	270	case VAR_SCALAR:
	271	return GvSV(glob);
	272	case VAR_ARRAY:
	273	return (SV*)GvAV(glob);
	274	case VAR_HASH:
	275	return (SV*)GvHV(glob);
	276	case VAR_CODE:
	277	return (SV*)GvCV(glob);
	278	case VAR_IO:
	279	return (SV*)GvIO(glob);
	280	default:
	281	return NULL;
	282	}
	283	}
	284
59017825	285	MODULE = Package::Stash PACKAGE = Package::Stash
59017825	286
be2a7e99	287	PROTOTYPES: DISABLE
be2a7e99	288
59017825	289	SV*
	290	new(class, package_name)
	291	char *class
	292	SV *package_name
3496f1e8	293	PREINIT:
59017825	294	HV *instance;
59017825	295	HV *namespace;
1d6c978b	296	SV *nsref;
59017825	297	CODE:
	298	if (!SvPOK(package_name))
	299	croak("The constructor argument must be the name of a package");
	300
6c3e69c6	301	instance = newHV();
59017825	302
1d6c978b	303	if (!hv_store(instance, "name", 4, SvREFCNT_inc_simple_NN(package_name), 0)) {
1d6c978b	304	SvREFCNT_dec(package_name);
c86a1630	305	SvREFCNT_dec(instance);
e8d57afd	306	croak("Couldn't initialize the 'name' key, hv_store failed");
1d6c978b	307	}
59017825	308	namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD);
1d6c978b	309	nsref = newRV_inc((SV*)namespace);
	310	if (!hv_store(instance, "namespace", 9, nsref, 0)) {
	311	SvREFCNT_dec(nsref);
c86a1630	312	SvREFCNT_dec(instance);
e8d57afd	313	croak("Couldn't initialize the 'namespace' key, hv_store failed");
1d6c978b	314	}
59017825	315
6c3e69c6	316	RETVAL = sv_bless(newRV_noinc((SV*)instance), gv_stashpv(class, 0));
59017825	317	OUTPUT:
59017825	318	RETVAL
194acf47	319
	320	SV*
	321	name(self)
	322	SV *self
3496f1e8	323	PREINIT:
194acf47	324	SV **slot;
	325	CODE:
	326	if (!sv_isobject(self))
	327	croak("Can't call name as a class method");
	328	slot = hv_fetch((HV*)SvRV(self), "name", 4, 0);
a2fec41a	329	RETVAL = slot ? SvREFCNT_inc_simple_NN(*slot) : &PL_sv_undef;
194acf47	330	OUTPUT:
	331	RETVAL
	332
	333	SV*
	334	namespace(self)
	335	SV *self
3496f1e8	336	PREINIT:
194acf47	337	SV **slot;
	338	CODE:
	339	if (!sv_isobject(self))
	340	croak("Can't call namespace as a class method");
	341	slot = hv_fetch((HV*)SvRV(self), "namespace", 9, 0);
a2fec41a	342	RETVAL = slot ? SvREFCNT_inc_simple_NN(*slot) : &PL_sv_undef;
194acf47	343	OUTPUT:
194acf47	344	RETVAL
3fd56b4d	345
3fd56b4d	346	void
15c104e2	347	add_symbol(self, variable, initial=NULL, ...)
76f7c306	348	SV *self
	349	varspec_t variable
	350	SV *initial
	351	PREINIT:
	352	SV *name;
	353	GV *glob;
	354	CODE:
	355	if (initial && !_valid_for_type(initial, variable.type))
	356	croak("%s is not of type %s",
	357	SvPV_nolen(initial), vartype_to_string(variable.type));
	358
	359	name = newSVsv(_get_name(self));
	360	sv_catpvs(name, "::");
	361	sv_catpv(name, variable.name);
	362
	363	/* XXX: come back to this when i feel like reimplementing caller() */
	364	/*
	365	my $filename = $opts{filename};
	366	my $first_line_num = $opts{first_line_num};
	367
	368	(undef, $filename, $first_line_num) = caller
	369	if not defined $filename;
	370
	371	my $last_line_num = $opts{last_line_num} \|\| ($first_line_num \|\|= 0);
	372
	373	# http://perldoc.perl.org/perldebguts.html#Debugger-Internals
	374	$DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num";
	375	*/
	376	/*
	377	if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) {
	378	int i;
	379	char filename = NULL, name;
	380	I32 first_line_num, last_line_num;
	381
	382	if ((items - 3) % 2)
15c104e2	383	croak("add_symbol: Odd number of elements in %%opts");
76f7c306	384
	385	for (i = 3; i < items; i += 2) {
	386	char *key;
	387	key = SvPV_nolen(ST(i));
	388	if (strEQ(key, "filename")) {
	389	if (!SvPOK(ST(i + 1)))
15c104e2	390	croak("add_symbol: filename must be a string");
76f7c306	391	filename = SvPV_nolen(ST(i + 1));
	392	}
	393	else if (strEQ(key, "first_line_num")) {
	394	if (!SvIOK(ST(i + 1)))
15c104e2	395	croak("add_symbol: first_line_num must be an integer");
76f7c306	396	first_line_num = SvIV(ST(i + 1));
	397	}
	398	else if (strEQ(key, "last_line_num")) {
	399	if (!SvIOK(ST(i + 1)))
15c104e2	400	croak("add_symbol: last_line_num must be an integer");
76f7c306	401	last_line_num = SvIV(ST(i + 1));
	402	}
	403	}
	404
	405	if (!filename) {
	406	}
	407	}
	408	*/
	409
fedea7f9	410	glob = gv_fetchsv(name, GV_ADDMULTI, vartype_to_svtype(variable.type));
76f7c306	411
	412	if (initial) {
	413	SV *val;
	414
	415	if (SvROK(initial)) {
	416	val = SvRV(initial);
a2fec41a	417	SvREFCNT_inc_simple_void_NN(val);
76f7c306	418	}
	419	else {
	420	val = newSVsv(initial);
	421	}
	422
	423	switch (variable.type) {
	424	case VAR_SCALAR:
a2fec41a	425	SvREFCNT_dec(GvSV(glob));
76f7c306	426	GvSV(glob) = val;
02b4c373	427	GvIMPORTED_SV_on(glob);
76f7c306	428	break;
76f7c306	429	case VAR_ARRAY:
6cce0a02	430	SvREFCNT_dec(GvAV(glob));
76f7c306	431	GvAV(glob) = (AV*)val;
02b4c373	432	GvIMPORTED_AV_on(glob);
76f7c306	433	break;
76f7c306	434	case VAR_HASH:
6cce0a02	435	SvREFCNT_dec(GvHV(glob));
76f7c306	436	GvHV(glob) = (HV*)val;
02b4c373	437	GvIMPORTED_HV_on(glob);
76f7c306	438	break;
76f7c306	439	case VAR_CODE:
6cce0a02	440	SvREFCNT_dec(GvCV(glob));
76f7c306	441	GvCV(glob) = (CV*)val;
02b4c373	442	GvIMPORTED_CV_on(glob);
	443	GvASSUMECV_on(glob);
	444	GvCVGEN(glob) = 0;
	445	mro_method_changed_in(GvSTASH(glob));
76f7c306	446	break;
76f7c306	447	case VAR_IO:
6cce0a02	448	SvREFCNT_dec(GvIO(glob));
76f7c306	449	GvIOp(glob) = (IO*)val;
	450	break;
	451	}
	452	}
	453
5bb2b07b	454	SvREFCNT_dec(name);
5bb2b07b	455
76f7c306	456	void
15c104e2	457	remove_glob(self, name)
3fd56b4d	458	SV *self
3fd56b4d	459	char *name
3fd56b4d	460	CODE:
3fd56b4d	461	hv_delete(_get_namespace(self), name, strlen(name), G_DISCARD);
9b608466	462
34805376	463	int
15c104e2	464	has_symbol(self, variable)
34805376	465	SV *self
	466	varspec_t variable
	467	PREINIT:
	468	HV *namespace;
	469	SV **entry;
	470	CODE:
	471	namespace = _get_namespace(self);
	472	entry = hv_fetch(namespace, variable.name, strlen(variable.name), 0);
	473	if (!entry)
	474	XSRETURN_UNDEF;
	475
	476	if (isGV(*entry)) {
	477	GV glob = (GV)(*entry);
	478	switch (variable.type) {
	479	case VAR_SCALAR:
	480	RETVAL = GvSV(glob) ? 1 : 0;
	481	break;
	482	case VAR_ARRAY:
	483	RETVAL = GvAV(glob) ? 1 : 0;
	484	break;
	485	case VAR_HASH:
	486	RETVAL = GvHV(glob) ? 1 : 0;
	487	break;
	488	case VAR_CODE:
	489	RETVAL = GvCV(glob) ? 1 : 0;
	490	break;
	491	case VAR_IO:
	492	RETVAL = GvIO(glob) ? 1 : 0;
	493	break;
	494	}
	495	}
	496	else {
	497	RETVAL = (variable.type == VAR_CODE);
	498	}
	499	OUTPUT:
	500	RETVAL
	501
e3ad44fd	502	SV*
15c104e2	503	get_symbol(self, variable)
e3ad44fd	504	SV *self
	505	varspec_t variable
	506	PREINIT:
fca4ed0c	507	SV *val;
e3ad44fd	508	CODE:
15c104e2	509	val = _get_symbol(self, &variable, 0);
4871b1a0	510	if (!val)
e3ad44fd	511	XSRETURN_UNDEF;
93c36417	512	RETVAL = newRV_inc(val);
4871b1a0	513	OUTPUT:
4871b1a0	514	RETVAL
e3ad44fd	515
4871b1a0	516	SV*
15c104e2	517	get_or_add_symbol(self, variable)
4871b1a0	518	SV *self
	519	varspec_t variable
	520	PREINIT:
	521	SV *val;
	522	CODE:
15c104e2	523	val = _get_symbol(self, &variable, 1);
fca4ed0c	524	if (!val)
fca4ed0c	525	XSRETURN_UNDEF;
93c36417	526	RETVAL = newRV_inc(val);
e3ad44fd	527	OUTPUT:
	528	RETVAL
	529
9b608466	530	void
15c104e2	531	remove_symbol(self, variable)
215f49f8	532	SV *self
	533	varspec_t variable
	534	PREINIT:
	535	HV *namespace;
	536	SV **entry;
	537	CODE:
	538	namespace = _get_namespace(self);
	539	entry = hv_fetch(namespace, variable.name, strlen(variable.name), 0);
	540	if (!entry)
	541	XSRETURN_EMPTY;
	542
	543	if (isGV(*entry)) {
	544	GV glob = (GV)(*entry);
	545	switch (variable.type) {
	546	case VAR_SCALAR:
4e3b237e	547	GvSV(glob) = (SV *)NULL;
215f49f8	548	break;
215f49f8	549	case VAR_ARRAY:
4e3b237e	550	GvAV(glob) = (AV *)NULL;
215f49f8	551	break;
215f49f8	552	case VAR_HASH:
4e3b237e	553	GvHV(glob) = (HV *)NULL;
215f49f8	554	break;
215f49f8	555	case VAR_CODE:
4e3b237e	556	GvCV(glob) = (CV *)NULL;
02b4c373	557	GvCVGEN(glob) = 0;
02b4c373	558	mro_method_changed_in(GvSTASH(glob));
215f49f8	559	break;
215f49f8	560	case VAR_IO:
4e3b237e	561	GvIOp(glob) = (IO *)NULL;
215f49f8	562	break;
	563	}
	564	}
	565	else {
	566	if (variable.type == VAR_CODE) {
	567	hv_delete(namespace, variable.name, strlen(variable.name), G_DISCARD);
	568	}
	569	}
	570
	571	void
15c104e2	572	list_all_symbols(self, vartype=VAR_NONE)
9b608466	573	SV *self
	574	vartype_t vartype
	575	PPCODE:
	576	if (vartype == VAR_NONE) {
	577	HV *namespace;
	578	HE *entry;
	579	int keys;
	580
	581	namespace = _get_namespace(self);
	582	keys = hv_iterinit(namespace);
	583	EXTEND(SP, keys);
ebcc8ba8	584	while ((entry = hv_iternext(namespace))) {
13f8a7b7	585	mPUSHs(newSVhe(entry));
9b608466	586	}
	587	}
	588	else {
	589	HV *namespace;
9b608466	590	SV *val;
	591	char *key;
	592	int len;
	593
	594	namespace = _get_namespace(self);
	595	hv_iterinit(namespace);
ebcc8ba8	596	while ((val = hv_iternextsv(namespace, &key, &len))) {
9b608466	597	GV gv = (GV)val;
	598	if (isGV(gv)) {
	599	switch (vartype) {
	600	case VAR_SCALAR:
	601	if (GvSV(val))
	602	mXPUSHp(key, len);
	603	break;
	604	case VAR_ARRAY:
	605	if (GvAV(val))
	606	mXPUSHp(key, len);
	607	break;
	608	case VAR_HASH:
	609	if (GvHV(val))
	610	mXPUSHp(key, len);
	611	break;
	612	case VAR_CODE:
	613	if (GvCVu(val))
	614	mXPUSHp(key, len);
	615	break;
	616	case VAR_IO:
	617	if (GvIO(val))
	618	mXPUSHp(key, len);
	619	break;
	620	}
	621	}
	622	else if (vartype == VAR_CODE) {
	623	mXPUSHp(key, len);
	624	}
	625	}
	626	}