Mailing List Archive

Author: creamyg
Date: 2008-09-09 19:53:54 -0700 (Tue, 09 Sep 2008)
New Revision: 3856

Modified:
trunk/c_src/KinoSearch/Obj/VTable.bp
trunk/c_src/KinoSearch/Obj/VTable.c
trunk/perl/lib/KinoSearch.pm
trunk/perl/lib/KinoSearch/Obj.pm
trunk/perl/lib/KinoSearch/Obj/VTable.pm
trunk/perl/t/021-vtable.t
Log:
Fix a subtle bug in the native-method-overriding-vtable-method mechanism: in
the inheritance chain KinoSearch::Obj -> OnceRemoved -> TwiceRemoved, if
OnceRemoved is never instantiated, the parent for TwiceRemoved was being
considered KinoSearch::Obj, and overridden methods in OnceRemoved were not
discovered. Fortunately, the fixed code is simpler than the original, and so
this bug will probably go away forever.


Modified: trunk/c_src/KinoSearch/Obj/VTable.bp
===================================================================
--- trunk/c_src/KinoSearch/Obj/VTable.bp 2008-09-10 01:27:26 UTC (rev 3855)
+++ trunk/c_src/KinoSearch/Obj/VTable.bp 2008-09-10 02:53:54 UTC (rev 3856)
@@ -25,7 +25,7 @@
* be created using [parent] as a base.
*
* If [parent] is null, an attempt will be made to find it using
- * VTable_find_parent_vtable(). If the attempt fails, an error will
+ * VTable_find_parent_class(). If the attempt fails, an error will
* result.
*/
static VTable*
@@ -49,11 +49,11 @@
static VTable*
fetch_vtable(const CharBuf *class_name);

- /** Given a class name, return the vtable belonging to a parent class, or
- * NULL if such a vtable can't be found.
+ /** Given a class name, return the name of a parent class which descends
+ * from KinoSearch::Obj, or NULL if such a class can't be found.
*/
- static VTable*
- find_parent_vtable(const CharBuf *class_name);
+ static CharBuf*
+ find_parent_class(const CharBuf *class_name);

/** List all of the methods that a class has overridden via the host
* language.

Modified: trunk/c_src/KinoSearch/Obj/VTable.c
===================================================================
--- trunk/c_src/KinoSearch/Obj/VTable.c 2008-09-10 01:27:26 UTC (rev 3855)
+++ trunk/c_src/KinoSearch/Obj/VTable.c 2008-09-10 02:53:54 UTC (rev 3856)
@@ -98,15 +98,17 @@
VArray *novel_native_methods;

if (parent == NULL) {
- /* (implicit refcount inc) */
- parent = VTable_find_parent_vtable(subclass_name);
- if (parent == NULL) {
- CONFESS("Can't find a parent vtable for '%o'", subclass_name);
+ CharBuf *parent_class = VTable_find_parent_class(subclass_name);
+ if (parent_class == NULL) {
+ CONFESS("Class '%o' doesn't descend from %o", subclass_name,
+ OBJ.name);
}
+ else {
+ parent = VTable_singleton(parent_class, NULL);
+ REFCOUNT_DEC(parent_class);
+ }
}
- else {
- REFCOUNT_INC(parent);
- }
+ REFCOUNT_INC(parent);

/* Copy source vtable. */
singleton = VTable_Clone(parent);
@@ -226,11 +228,11 @@
"novel_native_methods", 1, ARG_STR("class_name", class_name));
}

-VTable*
-VTable_find_parent_vtable(const CharBuf *class_name)
+CharBuf*
+VTable_find_parent_class(const CharBuf *class_name)
{
- return (VTable*)Native_callback_obj(&VTABLE,
- "find_parent_vtable", 1, ARG_STR("class_name", class_name));
+ return Native_callback_str(&VTABLE, "find_parent_class", 1,
+ ARG_STR("class_name", class_name));
}

static void

Modified: trunk/perl/lib/KinoSearch/Obj/VTable.pm
===================================================================
--- trunk/perl/lib/KinoSearch/Obj/VTable.pm 2008-09-10 01:27:26 UTC (rev 3855)
+++ trunk/perl/lib/KinoSearch/Obj/VTable.pm 2008-09-10 02:53:54 UTC (rev 3856)
@@ -8,6 +8,7 @@

{ "KinoSearch::Obj::VTable" => {
bind_methods => [qw( Get_Name )],
+ make_getters => [qw( parent name )],
}
}


Modified: trunk/perl/lib/KinoSearch/Obj.pm
===================================================================
--- trunk/perl/lib/KinoSearch/Obj.pm 2008-09-10 01:27:26 UTC (rev 3855)
+++ trunk/perl/lib/KinoSearch/Obj.pm 2008-09-10 02:53:54 UTC (rev 3856)
@@ -125,6 +125,7 @@
qw( Get_RefCount
Inc_RefCount
Dec_RefCount
+ Get_VTable
To_String
Clone
Equals

Modified: trunk/perl/lib/KinoSearch.pm
===================================================================
--- trunk/perl/lib/KinoSearch.pm 2008-09-10 01:27:26 UTC (rev 3855)
+++ trunk/perl/lib/KinoSearch.pm 2008-09-10 02:53:54 UTC (rev 3856)
@@ -190,24 +190,13 @@
{
package KinoSearch::Obj::VTable;

- sub find_parent_vtable {
- my ( $ignore, $package ) = @_;
- return _find_parent_vtable($package);
- }
-
- # Depth-first recursive search of @ISA.
- sub _find_parent_vtable {
- my $package = shift;
- my $registry = KinoSearch::Obj::VTable::_get_registry();
- my $vtable;
+ sub find_parent_class {
+ my ( undef, $package ) = @_;
no strict 'refs';
for my $parent ( @{"$package\::ISA"} ) {
- $vtable = $registry->fetch($parent);
- last if defined $vtable;
- $vtable = _find_parent_vtable($parent);
- last if defined $vtable;
+ return $parent if $parent->isa('KinoSearch::Obj');
}
- return $vtable;
+ return;
}

sub novel_native_methods {

Modified: trunk/perl/t/021-vtable.t
===================================================================
--- trunk/perl/t/021-vtable.t 2008-09-10 01:27:26 UTC (rev 3855)
+++ trunk/perl/t/021-vtable.t 2008-09-10 02:53:54 UTC (rev 3856)
@@ -14,15 +14,37 @@
die "Sweet, sweet death.";
}

+package OnceRemoved;
+use base qw( KinoSearch::Obj );
+
+our $serialize_was_called = 0;
+sub serialize {
+ my ( $self, $outstream ) = @_;
+ $serialize_was_called++;
+ $self->SUPER::serialize($outstream);
+}
+
+package TwiceRemoved;
+use base qw( OnceRemoved );
+
package main;

-use Test::More tests => 8;
+use KinoSearch::Test;
+use Test::More tests => 9;
+use Storable qw( nfreeze );

-use KinoSearch::Obj::VTable;
+{
+ my $twice_removed = TwiceRemoved->new;
+ # This triggers a call to Obj_Serialize() via the VTable dispatch.
+ my $frozen = nfreeze($twice_removed);
+ ok( $serialize_was_called,
+ "Overridden method in intermediate class recognized" );
+ my $vtable = $twice_removed->get_vtable;
+ is( $vtable->get_name, "TwiceRemoved", "correct class" );
+ my $parent_vtable = $vtable->get_parent;
+ is( $parent_vtable->get_name, "OnceRemoved", "correct parent class" )
+}

-use KinoSearch::Util::Hash;
-use KinoSearch::Util::CharBuf;
-
my $stringified;
my $storage = KinoSearch::Util::Hash->new;

@@ -50,12 +72,6 @@
is( $resurrected->fetch("ooga")->to_string,
"booga", "subclassed object still performs correctly at the C level" );

-my $vtable = KinoSearch::Obj::VTable->find_parent_vtable("nope");
-ok( !defined $vtable, "Can't find_parent_vtable for non-existent class" );
-$vtable = KinoSearch::Obj::VTable->find_parent_vtable("MyHash");
-is( $vtable->get_name, "KinoSearch::Util::Hash",
- "find_parent_vtable for custom subclass" );
-
my $methods
= KinoSearch::Obj::VTable->novel_native_methods('MyHash');
is_deeply( $methods->to_perl, ['oodle'], "novel_native_methods" );


_______________________________________________
kinosearch-commits mailing list
kinosearch-commits@rectangular.com
http://www.rectangular.com/mailman/listinfo/kinosearch-commits