Handle circular refs when converting from Perl First half of CLOWNFISH-36.
Project: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/repo Commit: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/commit/3e0546fa Tree: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/tree/3e0546fa Diff: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/diff/3e0546fa Branch: refs/heads/master Commit: 3e0546fabc8a2c3953561e184fc3bc5d2a10a8f1 Parents: 6c8dbb3 Author: Nick Wellnhofer <wellnho...@aevum.de> Authored: Tue Mar 8 11:54:42 2016 +0100 Committer: Nick Wellnhofer <wellnho...@aevum.de> Committed: Thu Mar 10 14:29:29 2016 +0100 ---------------------------------------------------------------------- runtime/perl/t/binding/016-vector.t | 29 ++++++- runtime/perl/t/binding/017-hash.t | 14 +++- runtime/perl/xs/XSBind.c | 128 +++++++++++++++++++++++++++---- 3 files changed, 151 insertions(+), 20 deletions(-) ---------------------------------------------------------------------- http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/3e0546fa/runtime/perl/t/binding/016-vector.t ---------------------------------------------------------------------- diff --git a/runtime/perl/t/binding/016-vector.t b/runtime/perl/t/binding/016-vector.t index ff2e547..15c3942 100644 --- a/runtime/perl/t/binding/016-vector.t +++ b/runtime/perl/t/binding/016-vector.t @@ -16,8 +16,8 @@ use strict; use warnings; -use Test::More tests => 1; -use Clownfish; +use Test::More tests => 3; +use Clownfish qw( to_clownfish ); my ( $vector, $twin ); @@ -32,3 +32,28 @@ $vector->insert( $twin = $vector->clone_raw; is_deeply( $twin->to_perl, $vector->to_perl, "clone" ); +use Data::Dumper; + +my $hashref = { foo => 'Foo', bar => 'Bar' }; +$hashref->{baz} = [ { circular => [ undef, $hashref ], one => 'One' } ]; + +my $arrayref = []; +push( @$arrayref, [] ) for 1..5000; +push( @$arrayref, $arrayref, { key => $arrayref }, 42, $hashref, 'string' ); + +$vector = to_clownfish($arrayref); +is( $$vector, ${ $vector->fetch_raw(5000) }, + 'to_clownfish($arrayref) handles circular references' ); + +my $hash = $vector->fetch_raw(5003); +is( + $$hash, + ${ + $hash->fetch_raw('baz') + ->fetch_raw(0) + ->fetch_raw('circular') + ->fetch_raw(1) + }, + 'to_clownfish($arrayref) handles deep circular references' +); + http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/3e0546fa/runtime/perl/t/binding/017-hash.t ---------------------------------------------------------------------- diff --git a/runtime/perl/t/binding/017-hash.t b/runtime/perl/t/binding/017-hash.t index 9b26829..b69d8e7 100644 --- a/runtime/perl/t/binding/017-hash.t +++ b/runtime/perl/t/binding/017-hash.t @@ -16,7 +16,7 @@ use strict; use warnings; -use Test::More tests => 10; +use Test::More tests => 12; use Clownfish qw( to_clownfish ); my $hash = Clownfish::Hash->new( capacity => 10 ); @@ -45,3 +45,15 @@ my $round_tripped = to_clownfish( \%hash_with_utf8_keys )->to_perl; is_deeply( $round_tripped, \%hash_with_utf8_keys, "Round trip conversion of hash with UTF-8 keys" ); +my $hashref = {}; +$hashref->{foo} = $hashref; +$hashref->{bar} = [ $hashref ]; + +$hash = to_clownfish($hashref); +is( $$hash, ${ $hash->fetch_raw('foo') }, + 'to_clownfish($hashref) handles circular references' ); + +$hash = to_clownfish({ key => $hashref })->fetch_raw('key'); +is( $$hash, ${ $hash->fetch_raw('bar')->fetch_raw(0) }, + 'to_clownfish($hashref) handles deep circular references' ); + http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/3e0546fa/runtime/perl/xs/XSBind.c ---------------------------------------------------------------------- diff --git a/runtime/perl/xs/XSBind.c b/runtime/perl/xs/XSBind.c index 85bd85b..a4f9046 100644 --- a/runtime/perl/xs/XSBind.c +++ b/runtime/perl/xs/XSBind.c @@ -30,6 +30,7 @@ #include "Clownfish/HashIterator.h" #include "Clownfish/Method.h" #include "Clownfish/Num.h" +#include "Clownfish/PtrHash.h" #include "Clownfish/TestHarness/TestUtils.h" #include "Clownfish/Util/Atomic.h" #include "Clownfish/Util/StringHelper.h" @@ -38,19 +39,29 @@ #define XSBIND_REFCOUNT_FLAG 1 #define XSBIND_REFCOUNT_SHIFT 1 +// Used to remember converted objects in array and hash conversion to +// handle circular references. The root object and SV are stored separately +// to allow lazy creation of the seen PtrHash. +typedef struct { + cfish_Obj *root_obj; + SV *root_sv; + cfish_PtrHash *seen; +} cfish_ConversionCache; + static bool S_maybe_perl_to_cfish(pTHX_ SV *sv, cfish_Class *klass, bool increment, - void *allocation, cfish_Obj **obj_ptr); + void *allocation, cfish_ConversionCache *cache, + cfish_Obj **obj_ptr); // Convert a Perl hash into a Clownfish Hash. Caller takes responsibility for // a refcount. static cfish_Hash* -S_perl_hash_to_cfish_hash(pTHX_ HV *phash); +S_perl_hash_to_cfish_hash(pTHX_ HV *phash, cfish_ConversionCache *cache); // Convert a Perl array into a Clownfish Vector. Caller takes responsibility // for a refcount. static cfish_Vector* -S_perl_array_to_cfish_array(pTHX_ AV *parray); +S_perl_array_to_cfish_array(pTHX_ AV *parray, cfish_ConversionCache *cache); cfish_Obj* XSBind_new_blank_obj(pTHX_ SV *either_sv) { @@ -103,7 +114,7 @@ XSBind_sv_true(pTHX_ SV *sv) { cfish_Obj* XSBind_perl_to_cfish(pTHX_ SV *sv, cfish_Class *klass) { cfish_Obj *retval = NULL; - if (!S_maybe_perl_to_cfish(aTHX_ sv, klass, true, NULL, &retval)) { + if (!S_maybe_perl_to_cfish(aTHX_ sv, klass, true, NULL, NULL, &retval)) { THROW(CFISH_ERR, "Can't convert to %o", CFISH_Class_Get_Name(klass)); } else if (!retval) { @@ -115,7 +126,7 @@ XSBind_perl_to_cfish(pTHX_ SV *sv, cfish_Class *klass) { cfish_Obj* XSBind_perl_to_cfish_nullable(pTHX_ SV *sv, cfish_Class *klass) { cfish_Obj *retval = NULL; - if (!S_maybe_perl_to_cfish(aTHX_ sv, klass, true, NULL, &retval)) { + if (!S_maybe_perl_to_cfish(aTHX_ sv, klass, true, NULL, NULL, &retval)) { THROW(CFISH_ERR, "Can't convert to %o", CFISH_Class_Get_Name(klass)); } return retval; @@ -124,7 +135,9 @@ XSBind_perl_to_cfish_nullable(pTHX_ SV *sv, cfish_Class *klass) { cfish_Obj* XSBind_perl_to_cfish_noinc(pTHX_ SV *sv, cfish_Class *klass, void *allocation) { cfish_Obj *retval = NULL; - if (!S_maybe_perl_to_cfish(aTHX_ sv, klass, false, allocation, &retval)) { + if (!S_maybe_perl_to_cfish(aTHX_ sv, klass, false, allocation, NULL, + &retval) + ) { THROW(CFISH_ERR, "Can't convert to %o", CFISH_Class_Get_Name(klass)); } else if (!retval) { @@ -135,7 +148,8 @@ XSBind_perl_to_cfish_noinc(pTHX_ SV *sv, cfish_Class *klass, void *allocation) { static bool S_maybe_perl_to_cfish(pTHX_ SV *sv, cfish_Class *klass, bool increment, - void *allocation, cfish_Obj **obj_ptr) { + void *allocation, cfish_ConversionCache *cache, + cfish_Obj **obj_ptr) { if (sv_isobject(sv)) { cfish_String *class_name = CFISH_Class_Get_Name(klass); // Assume that the class name is always NULL-terminated. Somewhat @@ -161,13 +175,13 @@ S_maybe_perl_to_cfish(pTHX_ SV *sv, cfish_Class *klass, bool increment, if (inner_type == SVt_PVAV) { if (klass == CFISH_VECTOR || klass == CFISH_OBJ) { obj = (cfish_Obj*) - S_perl_array_to_cfish_array(aTHX_ (AV*)inner); + S_perl_array_to_cfish_array(aTHX_ (AV*)inner, cache); } } else if (inner_type == SVt_PVHV) { if (klass == CFISH_HASH || klass == CFISH_OBJ) { obj = (cfish_Obj*) - S_perl_hash_to_cfish_hash(aTHX_ (HV*)inner); + S_perl_hash_to_cfish_hash(aTHX_ (HV*)inner, cache); } } else if (inner_type < SVt_PVAV && !SvOK(inner)) { @@ -250,10 +264,40 @@ XSBind_hash_key_to_utf8(pTHX_ HE *entry, STRLEN *size_ptr) { } static cfish_Hash* -S_perl_hash_to_cfish_hash(pTHX_ HV *phash) { +S_perl_hash_to_cfish_hash(pTHX_ HV *phash, cfish_ConversionCache *cache) { + cfish_ConversionCache new_cache; + + if (cache) { + // Lookup perl hash in conversion cache. + if ((SV*)phash == cache->root_sv) { + return (cfish_Hash*)CFISH_INCREF(cache->root_obj); + } + if (cache->seen) { + void *cached_hash = CFISH_PtrHash_Fetch(cache->seen, phash); + if (cached_hash) { + return (cfish_Hash*)CFISH_INCREF(cached_hash); + } + } + } + uint32_t num_keys = hv_iterinit(phash); cfish_Hash *retval = cfish_Hash_new(num_keys); + if (!cache) { + // Set up conversion cache. + cache = &new_cache; + cache->root_obj = (cfish_Obj*)retval; + cache->root_sv = (SV*)phash; + cache->seen = NULL; + } + else { + if (!cache->seen) { + // Create PtrHash lazily. + cache->seen = cfish_PtrHash_new(0); + } + CFISH_PtrHash_Store(cache->seen, phash, retval); + } + while (num_keys--) { HE *entry = hv_iternext(phash); STRLEN key_len = 0; @@ -261,31 +305,77 @@ S_perl_hash_to_cfish_hash(pTHX_ HV *phash) { SV *value_sv = HeVAL(entry); // Recurse. - cfish_Obj *value - = XSBind_perl_to_cfish_nullable(aTHX_ value_sv, CFISH_OBJ); + cfish_Obj *value; + bool success = S_maybe_perl_to_cfish(aTHX_ value_sv, CFISH_OBJ, + true, NULL, cache, &value); + if (!success) { + THROW(CFISH_ERR, "Can't convert to Clownfish::Obj"); + } CFISH_Hash_Store_Utf8(retval, key_str, key_len, value); } + if (cache == &new_cache && cache->seen) { + CFISH_PtrHash_Destroy(cache->seen); + } + return retval; } static cfish_Vector* -S_perl_array_to_cfish_array(pTHX_ AV *parray) { +S_perl_array_to_cfish_array(pTHX_ AV *parray, cfish_ConversionCache *cache) { + cfish_ConversionCache new_cache; + + if (cache) { + // Lookup perl array in conversion cache. + if ((SV*)parray == cache->root_sv) { + return (cfish_Vector*)CFISH_INCREF(cache->root_obj); + } + if (cache->seen) { + void *cached_vector = CFISH_PtrHash_Fetch(cache->seen, parray); + if (cached_vector) { + return (cfish_Vector*)CFISH_INCREF(cached_vector); + } + } + } + const uint32_t size = av_len(parray) + 1; cfish_Vector *retval = cfish_Vec_new(size); + if (!cache) { + // Set up conversion cache. + cache = &new_cache; + cache->root_obj = (cfish_Obj*)retval; + cache->root_sv = (SV*)parray; + cache->seen = NULL; + } + else { + if (!cache->seen) { + // Create PtrHash lazily. + cache->seen = cfish_PtrHash_new(0); + } + CFISH_PtrHash_Store(cache->seen, parray, retval); + } + // Iterate over array elems. for (uint32_t i = 0; i < size; i++) { SV **elem_sv = av_fetch(parray, i, false); if (elem_sv) { - cfish_Obj *elem - = XSBind_perl_to_cfish_nullable(aTHX_ *elem_sv, CFISH_OBJ); + cfish_Obj *elem; + bool success = S_maybe_perl_to_cfish(aTHX_ *elem_sv, CFISH_OBJ, + true, NULL, cache, &elem); + if (!success) { + THROW(CFISH_ERR, "Can't convert to Clownfish::Obj"); + } if (elem) { CFISH_Vec_Store(retval, i, elem); } } } CFISH_Vec_Resize(retval, size); // needed if last elem is NULL + if (cache == &new_cache && cache->seen) { + CFISH_PtrHash_Destroy(cache->seen); + } + return retval; } @@ -391,7 +481,9 @@ XSBind_arg_to_cfish(pTHX_ SV *value, const char *label, cfish_Class *klass, void *allocation) { cfish_Obj *obj = NULL; - if (!S_maybe_perl_to_cfish(aTHX_ value, klass, false, allocation, &obj)) { + if (!S_maybe_perl_to_cfish(aTHX_ value, klass, false, allocation, NULL, + &obj) + ) { THROW(CFISH_ERR, "Invalid value for '%s' - not a %o", label, CFISH_Class_Get_Name(klass)); CFISH_UNREACHABLE_RETURN(cfish_Obj*); @@ -409,7 +501,9 @@ XSBind_arg_to_cfish_nullable(pTHX_ SV *value, const char *label, cfish_Class *klass, void *allocation) { cfish_Obj *obj = NULL; - if (!S_maybe_perl_to_cfish(aTHX_ value, klass, false, allocation, &obj)) { + if (!S_maybe_perl_to_cfish(aTHX_ value, klass, false, allocation, NULL, + &obj) + ) { THROW(CFISH_ERR, "Invalid value for '%s' - not a %o", label, CFISH_Class_Get_Name(klass)); CFISH_UNREACHABLE_RETURN(cfish_Obj*);
