Author: chromatic
Date: Tue Apr 17 00:16:09 2007
New Revision: 18258
Modified:
trunk/src/pmc/class.pmc
trunk/t/pmc/class.t
trunk/t/pmc/role.t
Log:
[PMC] Implemented does() method on Class. This will need more tests once the
subclass() method works.
Cleaned up some whitespace in the role tests.
Modified: trunk/src/pmc/class.pmc
==============================================================================
--- trunk/src/pmc/class.pmc (original)
+++ trunk/src/pmc/class.pmc Tue Apr 17 00:16:09 2007
@@ -1046,6 +1046,39 @@
PCCRETURN(INTVAL isa);
}
+
+/*
+
+=item C<void does(STRING *role_name)>
+
+Returns true if this object or one of its parents performs the named role,
+false otherwise.
+
+=cut
+
+*/
+ PCCMETHOD void does(STRING *role_name) {
+ INTVAL i, role_count;
+ PMC *role_list = ((Parrot_Class *)PMC_data(SELF))->roles;
+
+ /* not a coding standards violation; the macro expands greatly! */
+ if (!role_list) {
+ PCCRETURN(INTVAL 0);
+ }
+
+ role_count = VTABLE_elements(interp, role_list);
+
+ for (i = 0; i < role_count; i++) {
+ STRING *r_name;
+ PMC *role = VTABLE_get_pmc_keyed_int(interp, role_list, i);
+ (STRING *r_name) = PCCINVOKE(interp, role, "name");
+
+ if (string_compare(interp, role_name, r_name))
+ PCCRETURN(INTVAL 1);
+ }
+
+ PCCRETURN(INTVAL 0);
+ }
} /* END pmclass */
/*
Modified: trunk/t/pmc/class.t
==============================================================================
--- trunk/t/pmc/class.t (original)
+++ trunk/t/pmc/class.t Tue Apr 17 00:16:09 2007
@@ -6,7 +6,7 @@
use warnings;
use lib qw( . lib ../lib ../../lib );
use Test::More;
-use Parrot::Test tests => 14;
+use Parrot::Test tests => 15;
=head1 NAME
@@ -494,6 +494,65 @@
Not a Foo
OUT
+# L<PDD15/Class PMC API/=item does>
+pir_output_is( <<'CODE', <<'OUT', 'does()' );
+.sub 'test' :main
+ .local pmc attrs
+ attrs = new 'Hash'
+
+ .local pmc red, green, blue
+ attrs['name'] = 'Red'
+ red = new 'Role', attrs
+
+ attrs['name'] = 'Green'
+ green = new 'Role', attrs
+
+ attrs['name'] = 'Blue'
+ blue = new 'Role', attrs
+
+ green.'add_role'( blue )
+
+ .local pmc color
+ color = new 'Class'
+
+ test_does( color, 'Red' )
+
+ color.'add_role'( red )
+ test_does( color, 'Red' )
+
+ color.'add_role'( green )
+ test_does( color, 'Green' )
+ test_does( color, 'Blue' )
+
+ test_does( color, 'Class' )
+.end
+
+.sub 'test_does'
+ .param pmc obj
+ .param string role_name
+
+ $I0 = obj.'does'( role_name )
+ if $I0 goto does_role
+ print "Doesn't "
+ print role_name
+ print "\n"
+ .return()
+
+ does_role:
+ print "Does "
+ print role_name
+ print "\n"
+
+ .return()
+.end
+CODE
+Doesn't Red
+Does Red
+Does Green
+Does Blue
+Does Class
+OUT
+
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
Modified: trunk/t/pmc/role.t
==============================================================================
--- trunk/t/pmc/role.t (original)
+++ trunk/t/pmc/role.t Tue Apr 17 00:16:09 2007
@@ -33,7 +33,7 @@
plan(5)
-
+
$P0 = new 'Role'
ok(1, 'Role type exists') # or we've already died.
