X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=XS.xs;h=ac7503885effd58a96beaa5240a8938f91876185;hb=HEAD;hp=db344889767c0e4ec13a06507437beeb7fb5e0e0;hpb=f88deb66271c78217bd0b488a5ab4581d5b6794a;p=gitmo%2FPackage-Stash-XS.git diff --git a/XS.xs b/XS.xs index db34488..ac75038 100644 --- a/XS.xs +++ b/XS.xs @@ -24,6 +24,42 @@ #define savesvpv(s) savepv(SvPV_nolen(s)) #endif +#ifndef GvCV_set +#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 @@ -68,7 +104,7 @@ } while (0) #define GvSetCV(g,v) do { \ SvREFCNT_dec(GvCV(g)); \ - if ((GvCV(g) = (CV*)(v))) { \ + if ((GvCV_set(g, (CV*)(v)))) { \ GvIMPORTED_CV_on(g); \ GvASSUMECV_on(g); \ } \ @@ -98,8 +134,9 @@ typedef struct { static U32 name_hash, namespace_hash, type_hash; static SV *name_key, *namespace_key, *type_key; +static REGEXP *valid_module_regex; -const char *vartype_to_string(vartype_t type) +static const char *vartype_to_string(vartype_t type) { switch (type) { case VAR_SCALAR: @@ -117,7 +154,7 @@ const char *vartype_to_string(vartype_t type) } } -I32 vartype_to_svtype(vartype_t type) +static I32 vartype_to_svtype(vartype_t type) { switch (type) { case VAR_SCALAR: @@ -135,7 +172,7 @@ I32 vartype_to_svtype(vartype_t type) } } -vartype_t string_to_vartype(char *vartype) +static vartype_t string_to_vartype(char *vartype) { if (strEQ(vartype, "SCALAR")) { return VAR_SCALAR; @@ -157,7 +194,28 @@ vartype_t string_to_vartype(char *vartype) } } -void _deconstruct_variable_name(SV *variable, varspec_t *varspec) +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; @@ -190,49 +248,55 @@ void _deconstruct_variable_name(SV *variable, varspec_t *varspec) } } -void _deconstruct_variable_hash(HV *variable, varspec_t *varspec) +static void _deconstruct_variable_hash(HV *variable, varspec_t *varspec) { HE *val; - STRLEN len; val = hv_fetch_ent(variable, name_key, 0, name_hash); if (!val) croak("The 'name' key is required in variable specs"); - varspec->name = sv_2mortal(newSVhe(val)); + varspec->name = sv_2mortal(newSVsv(HeVAL(val))); 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(HePV(val, len)); + varspec->type = string_to_vartype(SvPV_nolen(HeVAL(val))); } -int _valid_for_type(SV *value, vartype_t type) +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_NULL || - sv_type == SVt_IV || - sv_type == SVt_NV || - sv_type == SVt_PV || - sv_type == SVt_RV; + /* 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; } } -HV *_get_namespace(SV *self) +static HV *_get_namespace(SV *self) { dSP; SV *ret; @@ -250,7 +314,7 @@ HV *_get_namespace(SV *self) return (HV*)SvRV(ret); } -SV *_get_name(SV *self) +static SV *_get_name(SV *self) { dSP; SV *ret; @@ -268,21 +332,67 @@ SV *_get_name(SV *self) return ret; } -void _expand_glob(SV *self, SV *varname) +static void _real_gv_init(GV *gv, HV *stash, SV *name) { - 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) +{ + 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"); + } } -SV *_get_symbol(SV *self, varspec_t *variable, int vivify) +static SV *_get_symbol(SV *self, varspec_t *variable, int vivify) { HV *namespace; HE *entry; @@ -343,30 +453,35 @@ MODULE = Package::Stash::XS PACKAGE = Package::Stash::XS PROTOTYPES: DISABLE SV* -new(class, package_name) +new(class, package) SV *class - SV *package_name + SV *package PREINIT: HV *instance; - HV *namespace; - SV *nsref; 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), 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, "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, "namespace", 9, SvREFCNT_inc_simple_NN(package), 0)) { + SvREFCNT_dec(package); + SvREFCNT_dec(instance); + croak("Couldn't initialize the 'namespace' 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"); + 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)); @@ -381,8 +496,12 @@ name(self) 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 @@ -391,11 +510,34 @@ namespace(self) SV *self PREINIT: HE *slot; + SV *package_name; CODE: if (!sv_isobject(self)) croak("Can't call namespace as a class method"); +#if PERL_VERSION < 10 + package_name = _get_name(self); + RETVAL = newRV_inc((SV*)gv_stashpv(SvPV_nolen(package_name), GV_ADD)); +#else slot = hv_fetch_ent((HV*)SvRV(self), namespace_key, 0, namespace_hash); - RETVAL = slot ? SvREFCNT_inc_simple_NN(HeVAL(slot)) : &PL_sv_undef; + if (slot) { + RETVAL = SvREFCNT_inc_simple_NN(HeVAL(slot)); + } + else { + HV *namespace; + SV *nsref; + + package_name = _get_name(self); + namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD); + nsref = newRV_inc((SV*)namespace); + sv_rvweaken(nsref); + if (!hv_store((HV*)SvRV(self), "namespace", 9, nsref, 0)) { + SvREFCNT_dec(nsref); + SvREFCNT_dec(self); + croak("Couldn't initialize the 'namespace' key, hv_store failed"); + } + RETVAL = SvREFCNT_inc_simple_NN(nsref); + } +#endif OUTPUT: RETVAL @@ -405,23 +547,19 @@ add_symbol(self, variable, initial=NULL, ...) 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) @@ -457,6 +595,10 @@ add_symbol(self, variable, initial=NULL, ...) 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); @@ -465,12 +607,25 @@ add_symbol(self, variable, initial=NULL, ...) 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; @@ -502,8 +657,6 @@ add_symbol(self, variable, initial=NULL, ...) } } - SvREFCNT_dec(name); - void remove_glob(self, name) SV *self @@ -732,6 +885,19 @@ get_all_symbols(self, vartype=VAR_NONE) 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);