#define GvCV_set(gv, cv) (GvCV(gv) = (CV*)(cv))
#endif
+#ifndef MUTABLE_PTR
+#define MUTABLE_PTR(p) ((void *) (p))
+#endif
+
+#ifndef MUTABLE_SV
+#define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p))
+#endif
+
+#ifndef SVT_SCALAR
+#define SVT_SCALAR(svt) (svt <= SVt_PVLV)
+#endif
+
+#ifndef SVT_ARRAY
+#define SVT_ARRAY(svt) (svt == SVt_PVAV)
+#endif
+
+#ifndef SVT_HASH
+#define SVT_HASH(svt) (svt == SVt_PVHV)
+#endif
+
+#ifndef SVT_CODE
+#define SVT_CODE(svt) (svt == SVt_PVCV)
+#endif
+
+#ifndef SVT_IO
+#define SVT_IO(svt) (svt == SVt_PVIO)
+#endif
+
+#ifndef SVT_FORMAT
+#define SVT_FORMAT(svt) (svt == SVt_PVFM)
+#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
} while (0)
#define GvSetCV(g,v) do { \
SvREFCNT_dec(GvCV(g)); \
- if ((GvCV_set(g, v))) { \
+ if ((GvCV_set(g, (CV*)(v)))) { \
GvIMPORTED_CV_on(g); \
GvASSUMECV_on(g); \
} \
static U32 name_hash, namespace_hash, type_hash;
static SV *name_key, *namespace_key, *type_key;
+static REGEXP *valid_module_regex;
static const char *vartype_to_string(vartype_t type)
{
}
}
+static int _is_valid_module_name(SV *package)
+{
+ char *buf;
+ STRLEN len;
+ SV *sv;
+
+ buf = SvPV(package, len);
+
+ /* whee cargo cult */
+ sv = sv_newmortal();
+ sv_upgrade(sv, SVt_PV);
+ SvREADONLY_on(sv);
+ SvLEN(sv) = 0;
+ SvUTF8_on(sv);
+ SvPVX(sv) = buf;
+ SvCUR_set(sv, len);
+ SvPOK_on(sv);
+
+ return pregexec(valid_module_regex, buf, buf + len, buf, 1, sv, 1);
+}
+
static void _deconstruct_variable_name(SV *variable, varspec_t *varspec)
{
char *varpv;
varspec->type = string_to_vartype(SvPV_nolen(HeVAL(val)));
}
+static void _check_varspec_is_valid(varspec_t *varspec)
+{
+ if (strstr(SvPV_nolen(varspec->name), "::")) {
+ croak("Variable names may not contain ::");
+ }
+}
+
static 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_PVAV && sv_type != SVt_PVHV &&
- sv_type != SVt_PVCV && sv_type != SVt_PVFM &&
- sv_type != SVt_PVIO;
+ /* XXX is a glob a scalar? assigning a glob to the scalar slot seems
+ * to work here, but in pure perl i'm pretty sure it goes to the EGV
+ * slot, which seems more correct to me. just disable it for now
+ * i guess */
+ return SVT_SCALAR(sv_type) && sv_type != SVt_PVGV;
case VAR_ARRAY:
- return sv_type == SVt_PVAV;
+ return SVT_ARRAY(sv_type);
case VAR_HASH:
- return sv_type == SVt_PVHV;
+ return SVT_HASH(sv_type);
case VAR_CODE:
- return sv_type == SVt_PVCV;
+ return SVT_CODE(sv_type);
case VAR_IO:
- return sv_type == SVt_PVIO;
+ return SVT_IO(sv_type);
default:
return 0;
}
return ret;
}
+static void _real_gv_init(GV *gv, HV *stash, SV *name)
+{
+ char *name_pv;
+ STRLEN name_len;
+
+ name_pv = SvPV(name, name_len);
+ gv_init(gv, stash, name_pv, name_len, 1);
+
+ /* XXX: copied and pasted from gv_fetchpvn_flags and such */
+ /* ignoring the stuff for CORE:: and main:: for now, and also
+ * ignoring the GvMULTI_on bits, since we pass 1 to gv_init above */
+ switch (name_pv[0]) {
+ case 'I':
+ if (strEQ(&name_pv[1], "SA")) {
+ AV *av;
+
+ av = GvAVn(gv);
+ sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
+ NULL, 0);
+ }
+ break;
+ case 'O':
+ if (strEQ(&name_pv[1], "VERLOAD")) {
+ HV *hv;
+
+ hv = GvHVn(gv);
+ hv_magic(hv, NULL, PERL_MAGIC_overload);
+ }
+ break;
+ default:
+ break;
+ }
+}
+
static void _expand_glob(SV *self, SV *varname)
{
- SV *name;
+ HV *namespace;
+ HE *entry;
+ GV *glob;
- name = newSVsv(_get_name(self));
- sv_catpvs(name, "::");
- sv_catsv(name, varname);
+ namespace = _get_namespace(self);
- /* 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(name, GV_ADD, SVt_NULL);
- SvREFCNT_dec(name);
+ if (entry = hv_fetch_ent(namespace, varname, 0, 0)) {
+ glob = (GV*)HeVAL(entry);
+ if (isGV(glob)) {
+ croak("_expand_glob called on stash slot with expanded glob");
+ }
+ else {
+ SvREFCNT_inc(glob);
+ _real_gv_init(glob, namespace, varname);
+ if (!hv_store_ent(namespace, varname, (SV*)glob, 0)) {
+ croak("hv_store failed");
+ }
+ }
+ }
+ else {
+ croak("_expand_glob called on nonexistent stash slot");
+ }
}
static SV *_get_symbol(SV *self, varspec_t *variable, int vivify)
PROTOTYPES: DISABLE
SV*
-new(class, package_name)
+new(class, package)
SV *class
- SV *package_name
+ SV *package
PREINIT:
HV *instance;
CODE:
- if (!SvPOK(package_name))
- croak("The constructor argument must be the name of a package");
+ if (SvPOK(package)) {
+ if (!_is_valid_module_name(package))
+ croak("%s is not a module name", SvPV_nolen(package));
- instance = newHV();
+ 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");
+ if (!hv_store(instance, "name", 4, SvREFCNT_inc_simple_NN(package), 0)) {
+ SvREFCNT_dec(package);
+ SvREFCNT_dec(instance);
+ croak("Couldn't initialize the 'name' key, hv_store failed");
+ }
+ }
+ else if (SvROK(package) && SvTYPE(SvRV(package)) == SVt_PVHV) {
+ instance = newHV();
+
+ if (!hv_store(instance, "namespace", 9, SvREFCNT_inc_simple_NN(package), 0)) {
+ SvREFCNT_dec(package);
+ SvREFCNT_dec(instance);
+ croak("Couldn't initialize the 'namespace' key, hv_store failed");
+ }
+ }
+ else {
+ croak("Package::Stash->new must be passed the name of the package to access");
}
RETVAL = sv_bless(newRV_noinc((SV*)instance), gv_stashsv(class, 0));
CODE:
if (!sv_isobject(self))
croak("Can't call name as a class method");
- slot = hv_fetch_ent((HV*)SvRV(self), name_key, 0, name_hash);
- RETVAL = slot ? SvREFCNT_inc_simple_NN(HeVAL(slot)) : &PL_sv_undef;
+ if (slot = hv_fetch_ent((HV*)SvRV(self), name_key, 0, name_hash)) {
+ RETVAL = SvREFCNT_inc_simple_NN(HeVAL(slot));
+ }
+ else {
+ croak("Can't get the name of an anonymous package");
+ }
OUTPUT:
RETVAL
varspec_t variable
SV *initial
PREINIT:
- SV *name;
GV *glob;
+ HV *namespace;
+ HE *entry;
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_catsv(name, variable.name);
-
if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) {
int i;
char *filename = NULL;
I32 first_line_num = -1, last_line_num = -1;
- STRLEN namelen;
- SV *dbval;
+ SV *dbval, *name;
HV *dbsub;
if ((items - 3) % 2)
if (last_line_num == -1)
last_line_num = first_line_num;
+ name = newSVsv(_get_name(self));
+ sv_catpvs(name, "::");
+ sv_catsv(name, variable.name);
+
/* 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);
SvPV_nolen(name));
SvREFCNT_dec(dbval);
}
+
+ SvREFCNT_dec(name);
}
/* 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));
+ namespace = _get_namespace(self);
+ entry = hv_fetch_ent(namespace, variable.name, 0, 0);
+ if (entry) {
+ glob = (GV*)HeVAL(entry);
+ }
+ else {
+ glob = (GV*)newSV(0);
+ _real_gv_init(glob, namespace, variable.name);
+ if (!hv_store_ent(namespace, variable.name, (SV*)glob, 0)) {
+ croak("hv_store failed");
+ }
+ }
if (initial) {
SV *val;
}
}
- SvREFCNT_dec(name);
-
void
remove_glob(self, name)
SV *self
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;
+
+ fakepmop.op_pmflags = 0;
+ valid_module_regex = pregcomp(vmre, vmre + strlen(vmre), &fakepmop);
+#else
+ SV *re;
+
+ re = newSVpv(vmre, 0);
+ valid_module_regex = pregcomp(re, 0);
+#endif
+
name_key = newSVpvs("name");
PERL_HASH(name_hash, "name", 4);
projects / gitmo/Package-Stash-XS.git / blobdiff