X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=XS.xs;h=ac7503885effd58a96beaa5240a8938f91876185;hb=HEAD;hp=58c76b9f7e9f7ed27c84f9efd44fc0a3f501a10d;hpb=7e7bf1a653b87b66c95a38e85a9b39a43b54bd4e;p=gitmo%2FPackage-Stash-XS.git

diff --git a/XS.xs b/XS.xs
index 58c76b9..ac75038 100644
--- a/XS.xs
+++ b/XS.xs
@@ -28,6 +28,14 @@
 #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
@@ -96,7 +104,7 @@
 } 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);               \
     }                                   \
@@ -126,6 +134,7 @@ typedef struct {
 
 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)
 {
@@ -185,6 +194,27 @@ static vartype_t string_to_vartype(char *vartype)
     }
 }
 
+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;
@@ -302,18 +332,64 @@ static SV *_get_name(SV *self)
     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)
@@ -377,21 +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;
   CODE:
-    if (!SvPOK(package_name))
-        croak("Package::Stash->new must be passed the name of the package to access");
+    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));
@@ -406,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
 
@@ -453,22 +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;
-        SV *dbval;
+        SV *dbval, *name;
         HV *dbsub;
 
         if ((items - 3) % 2)
@@ -504,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);
@@ -512,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;
@@ -549,8 +657,6 @@ add_symbol(self, variable, initial=NULL, ...)
         }
     }
 
-    SvREFCNT_dec(name);
-
 void
 remove_glob(self, name)
     SV *self
@@ -779,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);