In perl.git, the branch smueller/hash_vtable has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/cbcc509d6cd1a435393639fdd1cf0514f998a554?hp=9e821d0e5999fd089de04633c8d62a610b5d9e60>
- Log -----------------------------------------------------------------
commit cbcc509d6cd1a435393639fdd1cf0514f998a554
Author: Steffen Mueller <smuel...@cpan.org>
Date: Thu Feb 2 18:04:39 2017 +0100
Hash vtavbles: hv_store and friends
M hv.c
M hv_vtbl.c
M hv_vtbl.h
commit edf3cb43b67f05b0f11bcb6e0ac4306ae4a122ba
Author: Steffen Mueller <smuel...@cpan.org>
Date: Thu Feb 2 18:03:35 2017 +0100
Hash vtables: Expose the damned flag on hv_undef
M hv.c
M hv_vtbl.c
M hv_vtbl.h
-----------------------------------------------------------------------
Summary of changes:
hv.c | 15 ++++++++++-----
hv_vtbl.c | 66 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--
hv_vtbl.h | 7 +++++--
3 files changed, 79 insertions(+), 9 deletions(-)
diff --git a/hv.c b/hv.c
index 4f68f92794..f65c93e83c 100644
--- a/hv.c
+++ b/hv.c
@@ -401,7 +401,13 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key,
STRLEN klen,
flags, hash);
}
else if (action & HV_FETCH_ISSTORE) {
- /* TODO - until then fall through */
+ assert((action & ~(HV_FETCH_ISSTORE|HV_FETCH_JUST_SV)) == 0);
+ if (action & HV_FETCH_JUST_SV) {
+ return (void *)vtable->hvt_store(hv, keysv, key, klen, flags,
val, hash);
+ }
+ else {
+ return (void *)vtable->hvt_store_ent(hv, keysv, key, klen,
flags, val, hash);
+ }
}
else if (action & HV_FETCH_JUST_SV) {
assert((action & ~(HV_FETCH_JUST_SV|HV_FETCH_LVALUE)) == 0);
@@ -1777,9 +1783,8 @@ Perl_hv_clear(pTHX_ HV *hv)
xhv = (XPVHV*)SvANY(hv);
- if (HvBODYHASVTBL(xhv)) {
- HvBODYVTBL(xhv)->hvt_clear(aTHX_ hv);
- }
+ if (HvBODYHASVTBL(xhv))
+ return HvBODYVTBL(xhv)->hvt_clear(aTHX_ hv);
/* avoid hv being freed when calling destructors below */
EXTEND_MORTAL(1);
@@ -2018,7 +2023,7 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
DEBUG_A(Perl_hv_assert(aTHX_ hv));
xhv = (XPVHV*)SvANY(hv);
if (HvBODYHASVTBL(xhv)) {
- return HvBODYVTBL(xhv)->hvt_undef(aTHX_ hv);
+ return HvBODYVTBL(xhv)->hvt_undef(aTHX_ hv, flags);
}
save = cBOOL(SvREFCNT(hv));
diff --git a/hv_vtbl.c b/hv_vtbl.c
index 1d4b40ef3e..5a98ffb1f4 100644
--- a/hv_vtbl.c
+++ b/hv_vtbl.c
@@ -69,7 +69,7 @@ S_hv_mock_std_vtable_clear(pTHX_ HV *hv)
}
STATIC void
-S_hv_mock_std_vtable_undef(pTHX_ HV *hv)
+S_hv_mock_std_vtable_undef(pTHX_ HV *hv, U32 flags)
{
/* THIS IS PURELY FOR TESTING! */
XPVHV* xhv = (XPVHV *)SvANY(hv);
@@ -80,7 +80,8 @@ S_hv_mock_std_vtable_undef(pTHX_ HV *hv)
SAVEPPTR(vtable);
xhv->xhv_vtbl = NULL;
- hv_undef(hv);
+ /* FIXME find a way to ditch "flags"... */
+ Perl_hv_undef_flags(pTHX_ hv, flags);
LEAVE;
}
@@ -161,6 +162,65 @@ S_hv_mock_std_vtable_fetch_ent(pTHX_ HV *hv, SV *keysv,
const char *key,
return retval;
}
+STATIC SV **
+S_hv_mock_std_vtable_store(pTHX_ HV *hv, SV *keysv,
+ const char *key, STRLEN klen, int key_flags,
+ SV *val, U32 hash)
+{
+ /* THIS IS PURELY FOR TESTING! */
+ SV **retval;
+ XPVHV* xhv = (XPVHV *)SvANY(hv);
+ HV_VTBL *vtable = xhv->xhv_vtbl;
+
+ ENTER;
+ /* localize vtable such that hv_common takes the normal code path */
+ SAVEPPTR(vtable);
+ xhv->xhv_vtbl = NULL;
+
+ {
+ retval = (SV **)hv_common(hv, keysv, key, klen, key_flags,
+ HV_FETCH_ISSTORE|HV_FETCH_JUST_SV,
+ val, hash);
+ }
+
+ LEAVE;
+
+ return retval;
+}
+
+
+
+/* TODO Returning a HE* is problematic for a pluggable hash implementation
+ * since HE's are specific to perl's default implementation. So a wildly
+ * different hash implementation would have to fake up HE's here. Sigh.
+ * Options? Slowly try to move all uses to use the SV-fetching variant
+ * instead? (But I assume there's some very good reasons why many places
+ * would fetch HE's.)
+ */
+STATIC HE *
+S_hv_mock_std_vtable_store_ent(pTHX_ HV *hv, SV *keysv,
+ const char *key, STRLEN klen, int key_flags,
+ SV *val, U32 hash)
+{
+ /* THIS IS PURELY FOR TESTING! */
+ HE *retval;
+ XPVHV* xhv = (XPVHV *)SvANY(hv);
+ HV_VTBL *vtable = xhv->xhv_vtbl;
+
+ ENTER;
+ /* localize vtable such that hv_common takes the normal code path */
+ SAVEPPTR(vtable);
+ xhv->xhv_vtbl = NULL;
+
+ retval = (HE *)hv_common(hv, keysv, key, klen, key_flags,
+ HV_FETCH_ISSTORE, val, hash);
+
+ LEAVE;
+
+ return retval;
+}
+
+
STATIC bool
S_hv_mock_std_vtable_exists(pTHX_ HV *hv, SV *keysv, const char *key,
STRLEN klen, int key_flags, U32 hash)
@@ -187,6 +247,8 @@ HV_VTBL PL_mock_std_vtable = {
S_hv_mock_std_vtable_destroy,
S_hv_mock_std_vtable_fetch,
S_hv_mock_std_vtable_fetch_ent,
+ S_hv_mock_std_vtable_store,
+ S_hv_mock_std_vtable_store_ent,
S_hv_mock_std_vtable_exists,
S_hv_mock_std_vtable_delete,
S_hv_mock_std_vtable_clear,
diff --git a/hv_vtbl.h b/hv_vtbl.h
index 71f8b44382..a0158a150a 100644
--- a/hv_vtbl.h
+++ b/hv_vtbl.h
@@ -19,7 +19,10 @@ struct hv_vtbl {
/* fetch_flags can contain at least HV_FETCH_LVALUE and HV_FETCH_EMPTY_HE
*/
HE * (*hvt_fetch_ent)(pTHX_ HV *hv, SV *keysv, const char *key,
STRLEN klen, int key_flags, I32 fetch_flags, U32 hash);
- /* TODO store */
+ /* Implements hv_store (and hv_stores) */
+ SV ** (*hvt_store)(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN
klen, int key_flags, SV *val, U32 hash);
+ /* Implements hv_store_ent */
+ HE * (*hvt_store_ent)(pTHX_ HV *hv, SV *keysv, const char *key,
STRLEN klen, int key_flags, SV *val, U32 hash);
/* Implements the equivalent of hv_exists(_ent) */
bool (*hvt_exists)(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN
klen, int key_flags, U32 hash);
@@ -33,7 +36,7 @@ struct hv_vtbl {
* seems to be a "no, really do away with everything" sort of corner
case. Need to understand
* significance for this much better. Is that just for stashes? But
really, I'd hate to expose
* some internal hack. Needs more thinking! */
- void (*hvt_undef)(pTHX_ HV *hv);
+ void (*hvt_undef)(pTHX_ HV *hv, U32 flags);
/* TODO also wrap all the iteration primitives! */
/* TODO research what other primitives are missing! */
--
Perl5 Master Repository
