Author: Whiteknight
Date: Tue Jan 20 08:45:43 2009
New Revision: 35818
Modified:
trunk/src/pmc/object.pmc
trunk/t/oo/vtableoverride.t
Log:
[does] Allow VTABLE_does to be overriddable in PIR. Add a few tests for this
feature
Modified: trunk/src/pmc/object.pmc
==============================================================================
--- trunk/src/pmc/object.pmc (original)
+++ trunk/src/pmc/object.pmc Tue Jan 20 08:45:43 2009
@@ -548,8 +548,23 @@
*/
VTABLE INTVAL does(STRING *role_name) {
+ /* If it's a null string, return false */
if (!role_name)
return 0;
+ else {
+ PMC * const classobj = VTABLE_get_class(interp, SELF);
+ STRING * meth_name = CONST_STRING(interp, "does");
+
+ PMC * const method = Parrot_oo_find_vtable_override(interp,
+ classobj, meth_name);
+
+ if (!PMC_IS_NULL(method)
+ && Parrot_run_meth_fromc_args_reti(interp, method, SELF,
meth_name, "IS", role_name))
+ return 1;
+ }
+ /* Check the superclass's vtable interface, if any. */
+ if (SUPER(role_name))
+ return 1;
/* Dispatch to the object's class */
return VTABLE_does(interp, VTABLE_get_class(interp, SELF), role_name);
Modified: trunk/t/oo/vtableoverride.t
==============================================================================
--- trunk/t/oo/vtableoverride.t (original)
+++ trunk/t/oo/vtableoverride.t Tue Jan 20 08:45:43 2009
@@ -18,29 +18,58 @@
.sub main :main
.include 'test_more.pir'
- plan(4)
-
+ plan(11)
+
+ newclass_tests()
+ subclass_tests()
+.end
+
+.sub 'newclass_tests'
$P1 = new 'MyObject'
-
+
# Test get_string
$S0 = $P1
is($S0, "[MyObject]", "get_string VTABLE override")
$P0 = getattribute $P1, "message"
$S0 = $P0
is($S0, "[MyObject]", "attribute sideeffect of get_string")
-
+
+ # Test does
+ $I0 = does $P1, 'this_dress_make...'
+ is ($I0, 1, "check first does, ok")
+ $I0 = does $P1, 'a_body_good'
+ is ($I0, 1, "check second does, ok")
+ $I0 = does $P1, 'it_better'
+ is ($I0, 0, "no it doesn't")
+
# Test morph (doesn't actually perform a morph)
morph $P1, "String"
$P0 = getattribute $P1, "message"
$S0 = $P0
is($S0, "Morphing [MyObject] to type String", "Morph VTABLE override 1")
-
+
morph $P1, "Integer"
$P0 = getattribute $P1, "message"
$S0 = $P0
is($S0, "Morphing [MyObject] to type Integer", "Morph VTABLE override 1")
.end
+.sub 'subclass_tests'
+ $P1 = new 'MySubObject'
+
+ # Test does, same as newclass.
+ $I0 = does $P1, 'this_dress_make...'
+ is ($I0, 1, "check first does, ok")
+ $I0 = does $P1, 'a_body_good'
+ is ($I0, 1, "check second does, ok")
+ $I0 = does $P1, 'it_better'
+ is ($I0, 0, "no it doesn't")
+ # Also verify we does what our parent does
+ $I0 = does $P1, 'array'
+ is ($I0, 1, "inherited does")
+.end
+
+
.namespace [ 'MyObject' ]
.sub '__onload' :anon :init
@@ -66,7 +95,43 @@
$P0 = box $S1
setattribute self, "message", $P0
.end
-
+
+.sub 'does' :vtable
+ .param string query
+ $S0 = 'does I do '
+ $S0 .= query
+ $P0 = box $S0
+ setattribute self, "message", $P0
+ if query == 'this_dress_make...' goto yes
+ if query == 'a_body_good' goto yes
+ .return(0)
+yes:
+ .return (1)
+.end
+
+.namespace [ 'MySubObject' ]
+
+.sub '__onload' :anon :init
+ $P1 = get_class 'ResizablePMCArray'
+ $P0 = subclass $P1, 'MySubObject'
+ addattribute $P0, "submessage"
+.end
+
+.sub 'does' :vtable
+ .param string query
+ $S0 = 'does I do '
+ $S0 .= query
+ $P0 = box $S0
+ setattribute self, "submessage", $P0
+ if query == 'this_dress_make...' goto yes
+ if query == 'a_body_good' goto yes
+ .return(0)
+yes:
+ .return (1)
+.end
+
+
+
# Local Variables:
# mode: pir
