#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) newSVpv(HePV(he, PL_na), 0)
+#endif
+
+#ifndef savesvpv
+#define savesvpv(s) savepv(SvPV_nolen(s))
+#endif
+
+/* HACK: scalar slots are always populated on perl < 5.10, so treat undef
+ * as nonexistent. this is consistent with the previous behavior of the pure
+ * perl version of this module (since this is the behavior that perl sees
+ * in all versions */
+#if PERL_VERSION < 10
+#define GvSVOK(g) (GvSV(g) && SvTYPE(GvSV(g)) != SVt_NULL)
+#else
+#define GvSVOK(g) GvSV(g)
+#endif
+
+#define GvAVOK(g) GvAV(g)
+#define GvHVOK(g) GvHV(g)
+#define GvCVOK(g) GvCVu(g) /* XXX: should this really be GvCVu? or GvCV? */
+#define GvIOOK(g) GvIO(g)
+
+/* see above - don't let scalar slots become unpopulated, this breaks
+ * assumptions in core */
+#if PERL_VERSION < 10
+#define GvSetSV(g,v) do { \
+ SV *_v = (SV*)(v); \
+ SvREFCNT_dec(GvSV(g)); \
+ if ((GvSV(g) = _v ? _v : newSV(0))) \
+ GvIMPORTED_SV_on(g); \
+} while (0)
+#else
+#define GvSetSV(g,v) do { \
+ SvREFCNT_dec(GvSV(g)); \
+ if ((GvSV(g) = (SV*)(v))) \
+ GvIMPORTED_SV_on(g); \
+} while (0)
+#endif
+
+#define GvSetAV(g,v) do { \
+ SvREFCNT_dec(GvAV(g)); \
+ if ((GvAV(g) = (AV*)(v))) \
+ GvIMPORTED_AV_on(g); \
+} while (0)
+#define GvSetHV(g,v) do { \
+ SvREFCNT_dec(GvHV(g)); \
+ if ((GvHV(g) = (HV*)(v))) \
+ GvIMPORTED_HV_on(g); \
+} while (0)
+#define GvSetCV(g,v) do { \
+ SvREFCNT_dec(GvCV(g)); \
+ if ((GvCV(g) = (CV*)(v))) { \
+ GvIMPORTED_CV_on(g); \
+ GvASSUMECV_on(g); \
+ } \
+ GvCVGEN(g) = 0; \
+ mro_method_changed_in(GvSTASH(g)); \
+} while (0)
+#define GvSetIO(g,v) do { \
+ SvREFCNT_dec(GvIO(g)); \
+ GvIOp(g) = (IO*)(v); \
+} while (0)
+
+/* XXX: the core implementation of caller() is private, so we need a
+ * a reimplementation. luckily, padwalker already has done this. rafl says
+ * that there should be a public interface in 5.14, so maybe look into
+ * converting to use that at some point */
+#include "stolen_bits_of_padwalker.c"
+
typedef enum {
VAR_NONE = 0,
VAR_SCALAR,
typedef struct {
vartype_t type;
- char sigil;
char *name;
+ I32 namelen;
} varspec_t;
+static U32 name_hash, namespace_hash, type_hash;
+static SV *name_key, *namespace_key, *type_key;
+
const char *vartype_to_string(vartype_t type)
{
switch (type) {
}
}
-void _deconstruct_variable_name(char *variable, varspec_t *varspec)
+void _deconstruct_variable_name(SV *varsv, varspec_t *varspec)
{
- if (!variable || !variable[0])
- croak("You must pass a variable name");
+ char *variable;
+ STRLEN len;
- varspec->type = VAR_NONE;
+ variable = SvPV(varsv, len);
+ if (!variable[0])
+ croak("You must pass a variable name");
switch (variable[0]) {
case '$':
varspec->type = VAR_SCALAR;
+ varspec->name = &variable[1];
+ varspec->namelen = len - 1;
break;
case '@':
varspec->type = VAR_ARRAY;
+ varspec->name = &variable[1];
+ varspec->namelen = len - 1;
break;
case '%':
varspec->type = VAR_HASH;
+ varspec->name = &variable[1];
+ varspec->namelen = len - 1;
break;
case '&':
varspec->type = VAR_CODE;
- break;
- }
-
- if (varspec->type != VAR_NONE) {
- varspec->sigil = variable[0];
varspec->name = &variable[1];
- }
- else {
+ varspec->namelen = len - 1;
+ break;
+ default:
varspec->type = VAR_IO;
- varspec->sigil = '\0';
varspec->name = variable;
+ varspec->namelen = len;
+ break;
}
}
void _deconstruct_variable_hash(HV *variable, varspec_t *varspec)
{
- SV **val;
+ HE *val;
+ char *valpv;
+ STRLEN len;
- val = hv_fetch(variable, "name", 4, 0);
+ val = hv_fetch_ent(variable, name_key, 0, name_hash);
if (!val)
croak("The 'name' key is required in variable specs");
- varspec->name = savesvpv(*val);
+ valpv = HePV(val, len);
+ varspec->name = savepvn(valpv, len);
SAVEFREEPV(varspec->name);
+ varspec->namelen = len;
- 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);
+ val = hv_fetch_ent(variable, type_key, 0, type_hash);
if (!val)
croak("The 'type' key is required in variable specs");
- varspec->type = string_to_vartype(SvPV_nolen(*val));
+ valpv = HePV(val, len);
+ varspec->type = string_to_vartype(valpv);
}
int _valid_for_type(SV *value, vartype_t type)
return ret;
}
-SV *_get_package_symbol(SV *self, varspec_t *variable, int vivify)
+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);
+ entry = hv_fetch(namespace, variable->name, variable->namelen, vivify);
if (!entry)
return NULL;
if (vivify) {
switch (variable->type) {
case VAR_SCALAR:
- if (!GvSV(glob))
- GvSV(glob) = newSV(0);
+ if (!GvSVOK(glob))
+ GvSetSV(glob, newSV(0));
break;
case VAR_ARRAY:
- if (!GvAV(glob))
- GvAV(glob) = newAV();
+ if (!GvAVOK(glob))
+ GvSetAV(glob, newAV());
break;
case VAR_HASH:
- if (!GvHV(glob))
- GvHV(glob) = newHV();
+ if (!GvHVOK(glob))
+ GvSetHV(glob, newHV());
break;
case VAR_CODE:
croak("Don't know how to vivify CODE variables");
case VAR_IO:
- if (!GvIO(glob))
- GvIOp(glob) = newIO();
+ if (!GvIOOK(glob))
+ GvSetIO(glob, newIO());
break;
default:
croak("Unknown type in vivication");
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();
- hv_store(instance, "name", 4, SvREFCNT_inc_simple_NN(package_name), 0);
+ 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);
- hv_store(instance, "namespace", 9, newRV_inc((SV*)namespace), 0);
+ 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:
name(self)
SV *self
PREINIT:
- SV **slot;
+ HE *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;
+ slot = hv_fetch_ent((HV*)SvRV(self), name_key, 0, name_hash);
+ RETVAL = slot ? SvREFCNT_inc_simple_NN(HeVAL(slot)) : &PL_sv_undef;
OUTPUT:
RETVAL
namespace(self)
SV *self
PREINIT:
- SV **slot;
+ HE *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;
+ slot = hv_fetch_ent((HV*)SvRV(self), namespace_key, 0, namespace_hash);
+ RETVAL = slot ? SvREFCNT_inc_simple_NN(HeVAL(slot)) : &PL_sv_undef;
OUTPUT:
RETVAL
void
-add_package_symbol(self, variable, initial=NULL, ...)
+add_symbol(self, variable, initial=NULL, ...)
SV *self
varspec_t variable
SV *initial
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;
+ char *filename = NULL, *namepv;
+ I32 first_line_num = -1, last_line_num = -1;
+ STRLEN namelen;
+ SV *dbval;
+ HV *dbsub;
if ((items - 3) % 2)
- croak("add_package_symbol: Odd number of elements in %%opts");
+ 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_package_symbol: filename must be a string");
+ 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_package_symbol: first_line_num must be an integer");
+ 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_package_symbol: last_line_num must be an integer");
+ croak("add_symbol: last_line_num must be an integer");
last_line_num = SvIV(ST(i + 1));
}
}
- if (!filename) {
+ if (!filename || first_line_num == -1) {
+ I32 cxix_from, cxix_to;
+ PERL_CONTEXT *cx, *ccstack;
+ COP *cop = NULL;
+
+ cx = upcontext(0, &cop, &ccstack, &cxix_from, &cxix_to);
+ if (!cop)
+ cop = PL_curcop;
+
+ if (!filename)
+ filename = CopFILE(cop);
+ if (first_line_num == -1)
+ first_line_num = cop->cop_line;
+ }
+
+ if (last_line_num == -1)
+ last_line_num = first_line_num;
+
+ /* http://perldoc.perl.org/perldebguts.html#Debugger-Internals */
+ dbsub = get_hv("DB::sub", 1);
+ dbval = newSVpvf("%s:%d-%d", filename, first_line_num, last_line_num);
+ namepv = SvPV(name, namelen);
+ if (!hv_store(dbsub, namepv, namelen, dbval, 0)) {
+ warn("Failed to update $DB::sub for subroutine %s", namepv);
+ SvREFCNT_dec(dbval);
}
}
-*/
+ /* GV_ADDMULTI rather than GV_ADD because otherwise you get 'used only
+ * once' warnings in some situations... i can't reproduce this, but CMOP
+ * triggers it */
glob = gv_fetchsv(name, GV_ADDMULTI, vartype_to_svtype(variable.type));
if (initial) {
switch (variable.type) {
case VAR_SCALAR:
- SvREFCNT_dec(GvSV(glob));
- GvSV(glob) = val;
+ GvSetSV(glob, val);
break;
case VAR_ARRAY:
- SvREFCNT_dec((SV*)GvAV(glob));
- GvAV(glob) = (AV*)val;
+ GvSetAV(glob, val);
break;
case VAR_HASH:
- SvREFCNT_dec((SV*)GvHV(glob));
- GvHV(glob) = (HV*)val;
+ GvSetHV(glob, val);
break;
case VAR_CODE:
- SvREFCNT_dec((SV*)GvCV(glob));
- GvCV(glob) = (CV*)val;
+ GvSetCV(glob, val);
break;
case VAR_IO:
- SvREFCNT_dec((SV*)GvIO(glob));
- GvIOp(glob) = (IO*)val;
+ GvSetIO(glob, val);
break;
}
}
SvREFCNT_dec(name);
void
-remove_package_glob(self, name)
+remove_glob(self, namesv)
SV *self
- char *name
+ SV *namesv
+ PREINIT:
+ char *name;
+ STRLEN len;
CODE:
- hv_delete(_get_namespace(self), name, strlen(name), G_DISCARD);
+ name = SvPV(namesv, len);
+ hv_delete(_get_namespace(self), name, len, G_DISCARD);
int
-has_package_symbol(self, variable)
+has_symbol(self, variable)
SV *self
varspec_t variable
PREINIT:
SV **entry;
CODE:
namespace = _get_namespace(self);
- entry = hv_fetch(namespace, variable.name, strlen(variable.name), 0);
+ entry = hv_fetch(namespace, variable.name, variable.namelen, 0);
if (!entry)
XSRETURN_UNDEF;
GV *glob = (GV*)(*entry);
switch (variable.type) {
case VAR_SCALAR:
- RETVAL = GvSV(glob) ? 1 : 0;
+ RETVAL = GvSVOK(glob) ? 1 : 0;
break;
case VAR_ARRAY:
- RETVAL = GvAV(glob) ? 1 : 0;
+ RETVAL = GvAVOK(glob) ? 1 : 0;
break;
case VAR_HASH:
- RETVAL = GvHV(glob) ? 1 : 0;
+ RETVAL = GvHVOK(glob) ? 1 : 0;
break;
case VAR_CODE:
- RETVAL = GvCV(glob) ? 1 : 0;
+ RETVAL = GvCVOK(glob) ? 1 : 0;
break;
case VAR_IO:
- RETVAL = GvIO(glob) ? 1 : 0;
+ RETVAL = GvIOOK(glob) ? 1 : 0;
break;
}
}
RETVAL
SV*
-get_package_symbol(self, variable)
+get_symbol(self, variable)
SV *self
varspec_t variable
PREINIT:
SV *val;
CODE:
- val = _get_package_symbol(self, &variable, 0);
+ val = _get_symbol(self, &variable, 0);
if (!val)
XSRETURN_UNDEF;
RETVAL = newRV_inc(val);
RETVAL
SV*
-get_or_add_package_symbol(self, variable)
+get_or_add_symbol(self, variable)
SV *self
varspec_t variable
PREINIT:
SV *val;
CODE:
- val = _get_package_symbol(self, &variable, 1);
+ val = _get_symbol(self, &variable, 1);
if (!val)
XSRETURN_UNDEF;
RETVAL = newRV_inc(val);
RETVAL
void
-remove_package_symbol(self, variable)
+remove_symbol(self, variable)
SV *self
varspec_t variable
PREINIT:
SV **entry;
CODE:
namespace = _get_namespace(self);
- entry = hv_fetch(namespace, variable.name, strlen(variable.name), 0);
+ entry = hv_fetch(namespace, variable.name, variable.namelen, 0);
if (!entry)
XSRETURN_EMPTY;
GV *glob = (GV*)(*entry);
switch (variable.type) {
case VAR_SCALAR:
- GvSV(glob) = (SV *)NULL;
+ GvSetSV(glob, NULL);
break;
case VAR_ARRAY:
- GvAV(glob) = (AV *)NULL;
+ GvSetAV(glob, NULL);
break;
case VAR_HASH:
- GvHV(glob) = (HV *)NULL;
+ GvSetHV(glob, NULL);
break;
case VAR_CODE:
- GvCV(glob) = (CV *)NULL;
+ GvSetCV(glob, NULL);
break;
case VAR_IO:
- GvIOp(glob) = (IO *)NULL;
+ GvSetIO(glob, NULL);
break;
}
}
else {
if (variable.type == VAR_CODE) {
- hv_delete(namespace, variable.name, strlen(variable.name), G_DISCARD);
+ hv_delete(namespace, variable.name, variable.namelen, G_DISCARD);
}
}
void
-list_all_package_symbols(self, vartype=VAR_NONE)
+list_all_symbols(self, vartype=VAR_NONE)
SV *self
vartype_t vartype
PPCODE:
keys = hv_iterinit(namespace);
EXTEND(SP, keys);
while ((entry = hv_iternext(namespace))) {
- mPUSHs(newSVhek(HeKEY_hek(entry)));
+ mPUSHs(newSVhe(entry));
}
}
else {
HV *namespace;
SV *val;
char *key;
- int len;
+ I32 len;
namespace = _get_namespace(self);
hv_iterinit(namespace);
if (isGV(gv)) {
switch (vartype) {
case VAR_SCALAR:
- if (GvSV(val))
+ if (GvSVOK(val))
mXPUSHp(key, len);
break;
case VAR_ARRAY:
- if (GvAV(val))
+ if (GvAVOK(val))
mXPUSHp(key, len);
break;
case VAR_HASH:
- if (GvHV(val))
+ if (GvHVOK(val))
mXPUSHp(key, len);
break;
case VAR_CODE:
- if (GvCVu(val))
+ if (GvCVOK(val))
mXPUSHp(key, len);
break;
case VAR_IO:
- if (GvIO(val))
+ if (GvIOOK(val))
mXPUSHp(key, len);
break;
}
}
}
}
+
+BOOT:
+ {
+ name_key = newSVpvs("name");
+ PERL_HASH(name_hash, "name", 4);
+
+ namespace_key = newSVpvs("namespace");
+ PERL_HASH(namespace_hash, "namespace", 9);
+
+ type_key = newSVpvs("type");
+ PERL_HASH(type_hash, "type", 4);
+ }
projects / gitmo/Package-Stash-XS.git / blobdiff