Repository: lucy-clownfish Updated Branches: refs/heads/master d601b8b8b -> 74c12c7ef
Allow Perl subclasses to use hashrefs If a parent class without ivars is subclassed from Perl, don't store the pointer to the Clownfish object in the SV, but use a hashref as underlying Perl object. This allows Perl subclasses to store their own ivars directly in the hashref without having to resort to inside-out objects. This requires to create a host object wrapper whenever an object is constructed or a Clownfish method is invoked. A similar approach can be used by other host languages without class-based inheritance. The perl_to_cfish functions now use Class_fetch and an is_a check based on the Clownfish parent class pointer instead of calling sv_derived_from. I haven't checked whether there's a performance impact, but this might actually be faster than the old code. The old inside-out approach is still supported by overloading scalar dereferencing for host object wrappers. Project: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/repo Commit: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/commit/0bfeb23e Tree: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/tree/0bfeb23e Diff: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/diff/0bfeb23e Branch: refs/heads/master Commit: 0bfeb23eccec3519d2bf72126c5c9aea7464c4c8 Parents: d601b8b Author: Nick Wellnhofer <[email protected]> Authored: Mon Mar 6 13:26:59 2017 +0100 Committer: Nick Wellnhofer <[email protected]> Committed: Sat Mar 18 20:57:21 2017 +0100 ---------------------------------------------------------------------- compiler/src/CFCBindCore.c | 8 + runtime/c/src/clownfish.c | 5 + runtime/core/Clownfish/Class.c | 14 +- runtime/core/Clownfish/Class.cfh | 5 + runtime/go/ext/clownfish.c | 5 + .../perl/buildlib/Clownfish/Build/Binding.pm | 30 +- runtime/perl/t/binding/010-class.t | 11 +- runtime/perl/t/binding/019-obj.t | 30 +- runtime/perl/xs/XSBind.c | 341 ++++++++++++++++--- runtime/perl/xs/XSBind.h | 6 + runtime/python/cfext/CFBind.c | 5 + runtime/test/Clownfish/Test/TestHost.c | 26 +- runtime/test/Clownfish/Test/TestHost.cfh | 21 ++ 13 files changed, 431 insertions(+), 76 deletions(-) ---------------------------------------------------------------------- http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/compiler/src/CFCBindCore.c ---------------------------------------------------------------------- diff --git a/compiler/src/CFCBindCore.c b/compiler/src/CFCBindCore.c index 35f107b..cfe9d09 100644 --- a/compiler/src/CFCBindCore.c +++ b/compiler/src/CFCBindCore.c @@ -199,6 +199,12 @@ S_write_parcel_h(CFCBindCore *self, CFCParcel *parcel) { " void *klass;\n" "} cfish_Dummy;\n" "\n" + "typedef struct cfish_HostObjWrapper {\n" + " CFISH_OBJ_HEAD\n" + " void *klass;\n" + " void *wrapped;\n" + "} cfish_HostObjWrapper;\n" + "\n" "/* Access the function pointer for a given method from the object.\n" " */\n" "static CFISH_INLINE cfish_method_t\n" @@ -287,6 +293,8 @@ S_write_parcel_h(CFCBindCore *self, CFCParcel *parcel) { "/* Flags for internal use. */\n" "#define CFISH_fREFCOUNTSPECIAL 0x00000001\n" "#define CFISH_fFINAL 0x00000002\n" + "#define CFISH_fEMPTY 0x00000004\n" + "#define CFISH_fHOST 0x00000008\n" ; const char *cfish_defs_2 = "#ifdef CFISH_USE_SHORT_NAMES\n" http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/c/src/clownfish.c ---------------------------------------------------------------------- diff --git a/runtime/c/src/clownfish.c b/runtime/c/src/clownfish.c index 239a796..5f4f7a4 100644 --- a/runtime/c/src/clownfish.c +++ b/runtime/c/src/clownfish.c @@ -165,6 +165,11 @@ Class_find_parent_class(String *class_name) { UNREACHABLE_RETURN(String*); } +void +Class_adjust_host_subclass(Class *klass) { + UNUSED_VAR(klass); +} + /**** Method ***************************************************************/ String* http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/core/Clownfish/Class.c ---------------------------------------------------------------------- diff --git a/runtime/core/Clownfish/Class.c b/runtime/core/Clownfish/Class.c index c5bbd34..5eaedb2 100644 --- a/runtime/core/Clownfish/Class.c +++ b/runtime/core/Clownfish/Class.c @@ -153,6 +153,9 @@ Class_bootstrap(const cfish_ParcelSpec *parcel_spec) { if (spec->flags & cfish_ClassSpec_FINAL) { klass->flags |= CFISH_fFINAL; } + if (klass->obj_alloc_size == sizeof(Obj)) { + klass->flags |= CFISH_fEMPTY; + } if (parent) { // Copy parent vtable. @@ -290,7 +293,7 @@ Class_init_registry() { } static Class* -S_simple_subclass(Class *parent, String *name) { +S_subclass_from_host(Class *parent, String *name) { if (parent->flags & CFISH_fFINAL) { THROW(ERR, "Can't subclass final class %o", Class_Get_Name(parent)); } @@ -310,6 +313,13 @@ S_simple_subclass(Class *parent, String *name) { memcpy(subclass->vtable, parent->vtable, parent->class_alloc_size - offsetof(Class, vtable)); + if ((subclass->flags & (CFISH_fHOST | CFISH_fEMPTY)) == CFISH_fEMPTY) { + // Subclassing an empty class for the first time. + subclass->flags |= CFISH_fHOST; + subclass->obj_alloc_size = sizeof(cfish_HostObjWrapper); + Class_adjust_host_subclass(subclass); + } + return subclass; } @@ -336,7 +346,7 @@ Class_singleton(String *class_name, Class *parent) { } } - singleton = S_simple_subclass(parent, class_name); + singleton = S_subclass_from_host(parent, class_name); // Allow host methods to override. fresh_host_methods = Class_fresh_host_methods(class_name); http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/core/Clownfish/Class.cfh ---------------------------------------------------------------------- diff --git a/runtime/core/Clownfish/Class.cfh b/runtime/core/Clownfish/Class.cfh index 3ac602c..f717a60 100644 --- a/runtime/core/Clownfish/Class.cfh +++ b/runtime/core/Clownfish/Class.cfh @@ -90,6 +90,11 @@ public final class Clownfish::Class inherits Clownfish::Obj { inert incremented Vector* fresh_host_methods(String *class_name); + /** Perform final adjustments to a host subclass. + */ + inert void + adjust_host_subclass(Class *klass); + /** Replace a function pointer in the Class's vtable. */ public void http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/go/ext/clownfish.c ---------------------------------------------------------------------- diff --git a/runtime/go/ext/clownfish.c b/runtime/go/ext/clownfish.c index 28f95b5..d05e4b7 100644 --- a/runtime/go/ext/clownfish.c +++ b/runtime/go/ext/clownfish.c @@ -169,6 +169,11 @@ Class_find_parent_class(String *class_name) { UNREACHABLE_RETURN(String*); } +void +Class_adjust_host_subclass(Class *klass) { + UNUSED_VAR(klass); +} + void* Class_To_Host_IMP(Class *self, void *vcache) { UNUSED_VAR(self); http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/perl/buildlib/Clownfish/Build/Binding.pm ---------------------------------------------------------------------- diff --git a/runtime/perl/buildlib/Clownfish/Build/Binding.pm b/runtime/perl/buildlib/Clownfish/Build/Binding.pm index 9fa4942..9805d5b 100644 --- a/runtime/perl/buildlib/Clownfish/Build/Binding.pm +++ b/runtime/perl/buildlib/Clownfish/Build/Binding.pm @@ -82,11 +82,11 @@ PPCODE: cfish_String *str = CFISH_Obj_To_String(obj); CFISH_DECREF(str); -int -refcount(obj) - cfish_Obj *obj; +U32 +refcount(sv) + SV *sv; CODE: - RETVAL = (int)CFISH_REFCOUNT_NN(obj); + RETVAL = SvREFCNT(SvROK(sv) ? SvRV(sv) : sv); OUTPUT: RETVAL END_XS_CODE @@ -750,27 +750,7 @@ void DESTROY(sv) SV *sv PPCODE: - if (sv_derived_from(sv, "Clownfish::Obj")) { - /* - * During global destruction, DESTROY is called in random order on - * objects remaining because of refcount leaks or circular references. - * This can cause memory corruption with Clownfish objects, so better - * leak instead of corrupting memory. - * - * Unfortunately, Perl's global destruction is still severely broken - * as of early 2017. Global "our" variables are destroyed in random - * order even without circular references. The following check will - * skip some objects that could be safely destroyed, but it's the - * best we can do. - * - * See https://rt.perl.org/Ticket/Display.html?id=32714 - */ - SV *inner = SvRV(sv); - if (!PL_dirty || SvREFCNT(inner) <= 1) { - cfish_Obj *self = INT2PTR(cfish_Obj*, SvIV(inner)); - CFISH_Obj_Destroy(self); - } - } + XSBind_destroy(aTHX_ sv); SV* get_class(self) http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/perl/t/binding/010-class.t ---------------------------------------------------------------------- diff --git a/runtime/perl/t/binding/010-class.t b/runtime/perl/t/binding/010-class.t index 21872ff..a3cc619 100644 --- a/runtime/perl/t/binding/010-class.t +++ b/runtime/perl/t/binding/010-class.t @@ -30,7 +30,7 @@ my $storage = Clownfish::Hash->new; { my $subclassed_obj = MyObj->new; - $stringified = $subclassed_obj->to_string; + $stringified = "$subclassed_obj"; isa_ok( $subclassed_obj, "MyObj", "Perl isa reports correct subclass" ); @@ -43,12 +43,13 @@ my $storage = Clownfish::Hash->new; my $resurrected = $storage->fetch("test"); isa_ok( $resurrected, "MyObj", "subclass name survived Perl destruction" ); -is( $resurrected->to_string, $stringified, - "It's the same Hash from earlier (though a different Perl object)" ); +is( "$resurrected", $stringified, "It's the same hashref from earlier" ); is( $resurrected->get_class_name, "MyObj", "subclassed object still performs correctly at the C level" ); -my $methods = Clownfish::Class::_fresh_host_methods('MyObj'); -is_deeply( $methods->to_perl, ['oodle'], "fresh_host_methods" ); +my $methods = Clownfish::Class::_fresh_host_methods('MyObj')->to_perl; +# Remove overload methods starting with '('. +$methods = [ grep { $_ !~ /^\(/ } @$methods ]; +is_deeply( $methods, ['oodle'], "fresh_host_methods" ); http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/perl/t/binding/019-obj.t ---------------------------------------------------------------------- diff --git a/runtime/perl/t/binding/019-obj.t b/runtime/perl/t/binding/019-obj.t index ee1be19..7e8ef0a 100644 --- a/runtime/perl/t/binding/019-obj.t +++ b/runtime/perl/t/binding/019-obj.t @@ -16,7 +16,8 @@ use strict; use warnings; -use Test::More tests => 27; +use Test::More tests => 33; +use Scalar::Util qw( refaddr reftype ); use Clownfish::Test; package TestObj; @@ -61,6 +62,15 @@ use base qw( Clownfish::Test::TestHost ); package SubclassFinalTestObj; use base qw( Clownfish::Vector ); +package CtorDtorTestObj; +use base qw( Clownfish::Test::TestHost ); +{ + our $num_do_init_calls; + our $num_do_destroy_calls; + sub do_init { $num_do_init_calls += 1; } + sub do_destroy { $num_do_destroy_calls += 1; } +} + package main; use Storable qw( freeze thaw ); use Clownfish::Test; @@ -71,8 +81,10 @@ ok( defined $TestObj::version, ); my $object = TestObj->new; -isa_ok( $object, "Clownfish::Obj", - "Clownfish objects can be subclassed" ); +isa_ok( $object, "Clownfish::Obj", "Subclassed Clownfish object" ); +is( reftype($object), "HASH", + "Subclassed objects without ivars are hashrefs" ); +is( $$object, refaddr($object), "Overloaded scalar deref works" ); SKIP: { skip( "Exception thrown within STORABLE hook leaks", 1 ) @@ -128,6 +140,8 @@ is( Clownfish::Test::refcount($object), $object = SonOfTestObj->new; like( $object->to_string, qr/STRING:.*?SonOfTestObj/, "overridden XS bindings can be called via SUPER" ); +is( $$object, refaddr($object), + "Overloaded scalar deref works with Perl subclasses" ); SKIP: { skip( "Exception thrown within callback leaks", 2 ) @@ -196,3 +210,13 @@ SKIP: { pass( "Created LeakyObj" ); } +$CtorDtorTestObj::num_do_init_calls = 0; +$CtorDtorTestObj::num_do_destroy_calls = 0; +{ + my $ctor_dtor_test = CtorDtorTestObj->new; + is( reftype($ctor_dtor_test), "HASH", + "ctor_dtor_test uses wrapper objects" ); +} +is ( $CtorDtorTestObj::num_do_init_calls, 1, "do_init was called" ); +is ( $CtorDtorTestObj::num_do_destroy_calls, 1, "do_destroy was called" ); + http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/perl/xs/XSBind.c ---------------------------------------------------------------------- diff --git a/runtime/perl/xs/XSBind.c b/runtime/perl/xs/XSBind.c index ffc5d20..274bf69 100644 --- a/runtime/perl/xs/XSBind.c +++ b/runtime/perl/xs/XSBind.c @@ -35,6 +35,14 @@ #include "Clownfish/Util/Atomic.h" #include "Clownfish/Util/Memory.h" +// Support older Perls. +#ifndef XS_INTERNAL + #define XS_INTERNAL XS +#endif +#ifndef HvNAMELEN + #define HvNAMELEN(hv) strlen(HvNAME(hv)) +#endif + #define XSBIND_REFCOUNT_FLAG 1 #define XSBIND_REFCOUNT_SHIFT 1 @@ -47,6 +55,22 @@ typedef struct { cfish_PtrHash *seen; } cfish_ConversionCache; +// Indicate whether the class is a descendent of `ancestor`. +static bool +S_class_is_a(cfish_Class *klass, cfish_Class *ancestor); + +// Create a new host object wrapper. +static cfish_Obj* +S_new_wrapper(cfish_Class *klass, SV *sv); + +// Defer a decref on the wrapper. +static void +S_mortalize_wrapper(pTHX_ cfish_Obj *obj); + +// Destroy host object wrapper. +static void +S_destroy_wrapper(cfish_HostObjWrapper *wrapper); + static bool S_maybe_perl_to_cfish(pTHX_ SV *sv, cfish_Class *klass, bool increment, void *allocation, cfish_ConversionCache *cache, @@ -62,39 +86,70 @@ S_perl_hash_to_cfish_hash(pTHX_ HV *phash, cfish_ConversionCache *cache); static cfish_Vector* S_perl_array_to_cfish_array(pTHX_ AV *parray, cfish_ConversionCache *cache); +static bool +S_class_is_a(cfish_Class *klass, cfish_Class *ancestor) { + while (klass != NULL) { + if (klass == ancestor) { + return true; + } + klass = klass->parent; + } + + return false; +} + cfish_Obj* XSBind_new_blank_obj(pTHX_ SV *either_sv) { - cfish_Class *klass; + HV *stash = NULL; + const char *class_name_ptr; + STRLEN class_name_len; // Get a Class. - if (sv_isobject(either_sv) - && sv_derived_from(either_sv, "Clownfish::Obj") - ) { + if (sv_isobject(either_sv)) { // Use the supplied object's Class. - IV iv_ptr = SvIV(SvRV(either_sv)); - cfish_Obj *self = INT2PTR(cfish_Obj*, iv_ptr); - klass = self->klass; + stash = SvSTASH(SvRV(either_sv)); + class_name_ptr = HvNAME(stash); + class_name_len = HvNAMELEN(stash); } else { // Use the supplied class name string to find a Class. - STRLEN len; - char *ptr = SvPVutf8(either_sv, len); - cfish_String *class_name = CFISH_SSTR_WRAP_UTF8(ptr, len); - klass = cfish_Class_singleton(class_name, NULL); + class_name_ptr = SvPVutf8(either_sv, class_name_len); } + cfish_String *class_name + = CFISH_SSTR_WRAP_UTF8(class_name_ptr, class_name_len); + cfish_Class *klass = cfish_Class_singleton(class_name, NULL); + // Use the Class to allocate a new blank object of the right size. - return CFISH_Class_Make_Obj(klass); + cfish_Obj *obj = CFISH_Class_Make_Obj(klass); + + if (klass->flags & CFISH_fHOST) { + // Mortalize host object wrapper so it will be destroyed after + // the Perl SV was extracted and returned. + S_mortalize_wrapper(aTHX_ obj); + } + + return obj; } +// Used to thaw Lucy objects. cfish_Obj* XSBind_foster_obj(pTHX_ SV *sv, cfish_Class *klass) { cfish_Obj *obj = (cfish_Obj*)cfish_Memory_wrapped_calloc(klass->obj_alloc_size, 1); - SV *inner_obj = SvRV((SV*)sv); + SV *inner_obj = SvRV(sv); obj->klass = klass; - sv_setiv(inner_obj, PTR2IV(obj)); - obj->ref.host_obj = inner_obj; + + if (klass->flags & CFISH_fHOST) { + obj->ref.count = (1 << XSBIND_REFCOUNT_SHIFT) | XSBIND_REFCOUNT_FLAG; + cfish_HostObjWrapper *wrapper = (cfish_HostObjWrapper*)obj; + wrapper->wrapped = inner_obj; + } + else { + sv_setiv(inner_obj, PTR2IV(obj)); + obj->ref.host_obj = inner_obj; + } + return obj; } @@ -150,16 +205,34 @@ S_maybe_perl_to_cfish(pTHX_ SV *sv, cfish_Class *klass, bool increment, 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 - // dangerous but should be safe. - if (sv_derived_from(sv, CFISH_Str_Get_Ptr8(class_name))) { - // Unwrap a real Clownfish object. - IV tmp = SvIV(SvRV(sv)); - cfish_Obj *obj = INT2PTR(cfish_Obj*, tmp); - if (increment) { - obj = CFISH_INCREF(obj); + // Get the Class of the SV. + SV *inner = SvRV(sv); + HV *stash = SvSTASH(inner); + cfish_String *sv_class_name + = CFISH_SSTR_WRAP_UTF8(HvNAME(stash), HvNAMELEN(stash)); + cfish_Class *sv_class = cfish_Class_fetch_class(sv_class_name); + + if (S_class_is_a(sv_class, klass)) { + cfish_Obj *obj; + + if (sv_class->flags & CFISH_fHOST) { + // Create wrapper object. + obj = S_new_wrapper(sv_class, inner); + if (increment) { + SvREFCNT_inc_simple_void_NN(inner); + } + else { + S_mortalize_wrapper(aTHX_ obj); + } + } + else { + // Unwrap a real Clownfish object. + obj = INT2PTR(cfish_Obj*, SvIV(inner)); + if (increment) { + obj = CFISH_INCREF(obj); + } } + *obj_ptr = obj; return true; } @@ -232,6 +305,42 @@ S_maybe_perl_to_cfish(pTHX_ SV *sv, cfish_Class *klass, bool increment, return false; } +static cfish_Obj* +S_new_wrapper(cfish_Class *klass, SV *sv) { + cfish_HostObjWrapper *wrapper + = (cfish_HostObjWrapper*)CFISH_CALLOCATE(klass->obj_alloc_size, 1); + wrapper->ref.count = (1 << XSBIND_REFCOUNT_SHIFT) | XSBIND_REFCOUNT_FLAG; + wrapper->klass = klass; + wrapper->wrapped = sv; + return (cfish_Obj*)wrapper; +} + +static void +S_mortalize_wrapper(pTHX_ cfish_Obj *obj) { + cfish_HostObjWrapper *wrapper = (cfish_HostObjWrapper*)obj; + + // Create a mortalized SV. Its class must not be the actual host subclass. + // Otherwise, XSBind_destroy would invoke the destructor of the host + // subclass instead of the wrapper destructor. Since wrapper objects are + // never passed to Perl and the "ref.host_obj" slot is only used for + // refcounting, it's OK to simply bless into Clownfish::Obj. + SV *mortalized = newSV(0); + sv_setref_pv(mortalized, "Clownfish::Obj", wrapper); + wrapper->ref.host_obj = mortalized; + sv_2mortal(mortalized); + + // The wrapper dtor will decref the wrapped SV, so compensate. + SvREFCNT_inc_simple_void_NN(wrapper->wrapped); +} + +static void +S_destroy_wrapper(cfish_HostObjWrapper *wrapper) { + dTHX; + SvREFCNT_dec(wrapper->wrapped); + // Don't call SUPER_DESTROY, free wrapper directly. + CFISH_FREEMEM(wrapper); +} + const char* XSBind_hash_key_to_utf8(pTHX_ HE *entry, STRLEN *size_ptr) { const char *key_str = NULL; @@ -552,6 +661,52 @@ XSBind_bootstrap(pTHX_ size_t num_classes, } } +void +XSBind_destroy(pTHX_ SV *sv) { + if (!sv_isobject(sv)) { return; } + SV *inner = SvRV(sv); + + // During global destruction, DESTROY is called in random order on + // objects remaining because of refcount leaks or circular references. + // This can cause memory corruption with Clownfish objects, so better + // leak instead of corrupting memory. + // + // Unfortunately, Perl's global destruction is still severely broken + // as of early 2017. Global "our" variables are destroyed in random + // order even without circular references. The following check will + // skip some objects that could be safely destroyed, but it's the + // best we can do. + // + // See https://rt.perl.org/Ticket/Display.html?id=32714 + if (PL_dirty && SvREFCNT(inner) > 1) { return; } + + // Find Class. + HV *stash = SvSTASH(inner); + cfish_String *class_name + = CFISH_SSTR_WRAP_UTF8(HvNAME(stash), HvNAMELEN(stash)); + cfish_Class *klass = cfish_Class_fetch_class(class_name); + if (!klass) { return; } + + if (klass->flags & CFISH_fHOST) { + cfish_Obj *wrapper = S_new_wrapper(klass, inner); + + // Find the real destructor which will also take care of + // freeing the wrapper. + for (klass = klass->parent; klass; klass = klass->parent) { + if (!(klass->flags & CFISH_fHOST)) { + CFISH_Obj_Destroy_t dtor + = CFISH_METHOD_PTR(klass, CFISH_Obj_Destroy); + dtor(wrapper); + break; + } + } + } + else { + cfish_Obj *self = INT2PTR(cfish_Obj*, SvIV(inner)); + CFISH_Obj_Destroy(self); + } +} + /*************************************************************************** * The routines below are declared within the Clownfish core but left * unimplemented and must be defined for each host language. @@ -705,19 +860,33 @@ cfish_dec_refcount(void *vself) { SV* XSBind_cfish_obj_to_sv_inc(pTHX_ cfish_Obj *obj) { if (obj == NULL) { return newSV(0); } +#if PERL_VERSION <= 8 + SV *inner; +#endif SV *perl_obj; - if (obj->ref.count & XSBIND_REFCOUNT_FLAG) { - perl_obj = S_lazy_init_host_obj(aTHX_ obj, true); + if (obj->klass->flags & CFISH_fHOST) { + cfish_HostObjWrapper *wrapper = (cfish_HostObjWrapper*)obj; + perl_obj = newRV_inc((SV*)wrapper->wrapped); +#if PERL_VERSION <= 8 + inner = (SV*)wrapper->wrapped; +#endif } else { - perl_obj = newRV_inc((SV*)obj->ref.host_obj); + if (obj->ref.count & XSBIND_REFCOUNT_FLAG) { + perl_obj = S_lazy_init_host_obj(aTHX_ obj, true); + } + else { + perl_obj = newRV_inc((SV*)obj->ref.host_obj); + } +#if PERL_VERSION <= 8 + inner = (SV*)obj->ref.host_obj; +#endif } // Enable overloading for Perl 5.8.x #if PERL_VERSION <= 8 - HV *stash = SvSTASH((SV*)obj->ref.host_obj); - if (Gv_AMG(stash)) { + if (Gv_AMG(SvSTASH(inner))) { SvAMAGIC_on(perl_obj); } #endif @@ -728,19 +897,33 @@ XSBind_cfish_obj_to_sv_inc(pTHX_ cfish_Obj *obj) { SV* XSBind_cfish_obj_to_sv_noinc(pTHX_ cfish_Obj *obj) { if (obj == NULL) { return newSV(0); } +#if PERL_VERSION <= 8 + SV *inner; +#endif SV *perl_obj; - if (obj->ref.count & XSBIND_REFCOUNT_FLAG) { - perl_obj = S_lazy_init_host_obj(aTHX_ obj, false); + if (obj->klass->flags & CFISH_fHOST) { + cfish_HostObjWrapper *wrapper = (cfish_HostObjWrapper*)obj; + perl_obj = newRV_noinc((SV*)wrapper->wrapped); +#if PERL_VERSION <= 8 + inner = (SV*)wrapper->wrapped; +#endif } else { - perl_obj = newRV_noinc((SV*)obj->ref.host_obj); + if (obj->ref.count & XSBIND_REFCOUNT_FLAG) { + perl_obj = S_lazy_init_host_obj(aTHX_ obj, false); + } + else { + perl_obj = newRV_noinc((SV*)obj->ref.host_obj); + } +#if PERL_VERSION <= 8 + inner = (SV*)obj->ref.host_obj; +#endif } // Enable overloading for Perl 5.8.x #if PERL_VERSION <= 8 - HV *stash = SvSTASH((SV*)obj->ref.host_obj); - if (Gv_AMG(stash)) { + if (Gv_AMG(SvSTASH(inner))) { SvAMAGIC_on(perl_obj); } #endif @@ -763,6 +946,32 @@ CFISH_Class_Make_Obj_IMP(cfish_Class *self) { = (cfish_Obj*)cfish_Memory_wrapped_calloc(self->obj_alloc_size, 1); obj->klass = self; obj->ref.count = (1 << XSBIND_REFCOUNT_SHIFT) | XSBIND_REFCOUNT_FLAG; + + if (self->flags & CFISH_fHOST) { + dTHX; + + // Bless an empty hashref. sv_bless only works through an RV, so + // bless manually. + SV *sv = (SV*)newHV(); + SvOBJECT_on(sv); +#if PERL_VERSION <= 16 + PL_sv_objcount++; +#endif + SvUPGRADE(sv, SVt_PVMG); + HV *stash = gv_stashpvn(CFISH_Str_Get_Ptr8(self->name), + CFISH_Str_Get_Size(self->name), GV_ADD); + SvSTASH_set(sv, (HV*)SvREFCNT_inc(stash)); +#if PERL_VERSION >= 10 && PERL_VERSION <= 16 + // Enable overloading. + if (Gv_AMG(stash)) { + SvFLAGS(sv) |= SVf_AMAGIC; + } +#endif + + cfish_HostObjWrapper *wrapper = (cfish_HostObjWrapper*)obj; + wrapper->wrapped = sv; + } + return obj; } @@ -831,6 +1040,59 @@ cfish_Class_find_parent_class(cfish_String *class_name) { return parent_class; } +XS_INTERNAL(XS_HostObjWrapper__nil) { + dXSARGS; + CFISH_UNUSED_VAR(items); + XSRETURN_EMPTY; +} + +XS_INTERNAL(XS_HostObjWrapper__deref_scalar) { + dXSARGS; + SP -= items; + if (items != 3) { + XSBind_invalid_args_error(aTHX_ cv, "self, other, swap"); + } + + // Return address of the inner HV wrapped in an RV. + ST(0) = newRV_noinc(newSViv(PTR2IV(SvRV(ST(0))))); + sv_2mortal(ST(0)); + XSRETURN(1); +} + +void +cfish_Class_adjust_host_subclass(cfish_Class *klass) { + // Override Destroy with the wrapper dtor. + CFISH_Class_Override(klass, (cfish_method_t)S_destroy_wrapper, + CFISH_Obj_Destroy_OFFSET); + + // Overload scalar dereferencing to keep deprecated inside-out objects + // working. How to install overload magic from C seems to be undocumented. + // The following is based on the code xsubpp generates if it finds an + // OVERLOAD keyword. + + dTHX; +#if PERL_VERSION <= 8 + PL_amagic_generation++; +#endif + cfish_String *class_name = CFISH_Class_Get_Name(klass); + cfish_String *name; + const char *name_ptr; + + name = cfish_Str_newf("%o::()", class_name); + name_ptr = CFISH_Str_Get_Ptr8(name); + // fallback => 1 + sv_setsv(get_sv(name_ptr, GV_ADD), &PL_sv_yes); + // A sub named '()' must be present. + newXS(name_ptr, XS_HostObjWrapper__nil, __FILE__); + CFISH_DECREF(name); + + // The internal name for overload methods starts with a '('. + name = cfish_Str_newf("%o::(${}", class_name); + name_ptr = CFISH_Str_Get_Ptr8(name); + newXS(name_ptr, XS_HostObjWrapper__deref_scalar, __FILE__); + CFISH_DECREF(name); +} + /*************************** Clownfish::Method ******************************/ cfish_String* @@ -967,12 +1229,11 @@ cfish_Err_trap(CFISH_Err_Attempt_t routine, void *context) { else { SV *dollar_at = get_sv("@", FALSE); if (SvTRUE(dollar_at)) { - if (sv_isobject(dollar_at) - && sv_derived_from(dollar_at,"Clownfish::Err") - ) { - IV error_iv = SvIV(SvRV(dollar_at)); - error = INT2PTR(cfish_Err*, error_iv); - CFISH_INCREF(error); + cfish_Obj *obj; + bool success = S_maybe_perl_to_cfish(aTHX_ dollar_at, CFISH_ERR, + true, NULL, NULL, &obj); + if (success) { + error = (cfish_Err*)obj; } else { STRLEN len; http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/perl/xs/XSBind.h ---------------------------------------------------------------------- diff --git a/runtime/perl/xs/XSBind.h b/runtime/perl/xs/XSBind.h index 32a9e69..60c1a10 100644 --- a/runtime/perl/xs/XSBind.h +++ b/runtime/perl/xs/XSBind.h @@ -222,6 +222,11 @@ cfish_XSBind_bootstrap(pTHX_ size_t num_classes, const cfish_XSBind_XSubSpec *xsub_specs, const char *file); +/** Destroy a Clownfish SV. + */ +CFISH_VISIBLE void +cfish_XSBind_destroy(pTHX_ SV *sv); + #define XSBIND_PARAM(key, required) \ { key, (int16_t)sizeof("" key) - 1, (char)required } @@ -252,6 +257,7 @@ cfish_XSBind_bootstrap(pTHX_ size_t num_classes, #define XSBind_invalid_args_error cfish_XSBind_invalid_args_error #define XSBind_undef_arg_error cfish_XSBind_undef_arg_error #define XSBind_bootstrap cfish_XSBind_bootstrap +#define XSBind_destroy cfish_XSBind_destroy /* Strip the prefix from some common ClownFish symbols where we know there's * no conflict with Perl. It's a little inconsistent to do this rather than http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/python/cfext/CFBind.c ---------------------------------------------------------------------- diff --git a/runtime/python/cfext/CFBind.c b/runtime/python/cfext/CFBind.c index e1ded4e..d08d5b2 100644 --- a/runtime/python/cfext/CFBind.c +++ b/runtime/python/cfext/CFBind.c @@ -992,6 +992,11 @@ cfish_Class_find_parent_class(cfish_String *class_name) { return NULL; } +void +cfish_Class_adjust_host_subclass(cfish_Class *klass) { + CFISH_UNUSED_VAR(klass); +} + /**** Method ***************************************************************/ cfish_String* http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/test/Clownfish/Test/TestHost.c ---------------------------------------------------------------------- diff --git a/runtime/test/Clownfish/Test/TestHost.c b/runtime/test/Clownfish/Test/TestHost.c index 6da0efa..8c137ca 100644 --- a/runtime/test/Clownfish/Test/TestHost.c +++ b/runtime/test/Clownfish/Test/TestHost.c @@ -23,7 +23,31 @@ TestHost* TestHost_new() { - return (TestHost*)Class_Make_Obj(TESTHOST); + TestHost *self = (TestHost*)Class_Make_Obj(TESTHOST); + return TestHost_init(self); +} + +TestHost* +TestHost_init(TestHost *self) { + Obj_init((Obj*)self); + TestHost_Do_Init(self); + return self; +} + +void +TestHost_Do_Init_IMP(TestHost *self) { + UNUSED_VAR(self); +} + +void +TestHost_Destroy_IMP(TestHost *self) { + TestHost_Do_Destroy(self); + SUPER_DESTROY(self, TESTHOST); +} + +void +TestHost_Do_Destroy_IMP(TestHost *self) { + UNUSED_VAR(self); } Obj* http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/test/Clownfish/Test/TestHost.cfh ---------------------------------------------------------------------- diff --git a/runtime/test/Clownfish/Test/TestHost.cfh b/runtime/test/Clownfish/Test/TestHost.cfh index 92bc272..1deb46e 100644 --- a/runtime/test/Clownfish/Test/TestHost.cfh +++ b/runtime/test/Clownfish/Test/TestHost.cfh @@ -22,6 +22,16 @@ class Clownfish::Test::TestHost { inert incremented TestHost* new(); + /** Invokes the (possibly overridden) method [](.Do_Init). + */ + inert TestHost* + init(TestHost *self); + + /** Called from constructor. + */ + void + Do_Init(TestHost *self); + Obj* Test_Obj_Pos_Arg(TestHost *self, Obj *arg); @@ -76,6 +86,17 @@ class Clownfish::Test::TestHost { incremented String* Invoke_Aliased_From_C(TestHost* self); + + /** A destructor that invokes the (possibly overridden) method + * [](.Do_Destroy). + */ + public void + Destroy(TestHost* self); + + /** Called from destructor. + */ + void + Do_Destroy(TestHost *self); }
