Author: jonathan
Date: Sun Apr 1 14:36:26 2007
New Revision: 17935
Modified:
trunk/src/pmc/class.pmc
trunk/t/pmc/class.t
Log:
[PDD15]: Implement new(...) setting attribute values that are passed as named
parameters to it. Test it. Test currently todo'd due to apparent :named :slurpy
bug missing all but the first named parameter.
Modified: trunk/src/pmc/class.pmc
==============================================================================
--- trunk/src/pmc/class.pmc (original)
+++ trunk/src/pmc/class.pmc Sun Apr 1 14:36:26 2007
@@ -338,9 +338,10 @@
/*
-=item C<void new()>
+=item C<void new(PMC *args :slurpy :named)>
-Creates an instance of the object.
+Creates an instance of the object. Initializes any attributes specified in the
+parameter list.
=cut
@@ -348,6 +349,7 @@
PCCMETHOD void new(PMC *args :slurpy :named) {
Parrot_Class *class = PARROT_CLASS(SELF);
PMC *obj;
+ PMC *iter;
/* If we've not been instantiated before... */
if (!class->instantiated) {
@@ -367,7 +369,17 @@
/* Create object. */
obj = pmc_new_init(interp, enum_class_Object, SELF);
- /* XXX Call constructor with the supplied arguments? */
+ /* Initialize attributes with the supplied values. */
+ iter = VTABLE_get_iter(interp, args);
+ while (VTABLE_get_bool(interp, iter)) {
+ /* Get name and value. */
+ STRING *attr_name = VTABLE_get_string(interp,
+ VTABLE_shift_pmc(interp, iter));
+ PMC *attr_value = VTABLE_get_pmc_keyed_str(interp, args,
attr_name);
+
+ /* Set the attribute. */
+ VTABLE_set_attr_str(interp, obj, attr_name, attr_value);
+ }
PCCRETURN(PMC *obj)
}
Modified: trunk/t/pmc/class.t
==============================================================================
--- trunk/t/pmc/class.t (original)
+++ trunk/t/pmc/class.t Sun Apr 1 14:36:26 2007
@@ -91,7 +91,7 @@
OUT
# L<PDD15/Class PMC API/=item new>
-pir_output_is( <<'CODE', <<'OUT', 'new' );
+pir_output_is( <<'CODE', <<'OUT', 'new', todo => ':slurpy :named bug' );
.sub 'test' :main
new $P0, .Class
$P1 = $P0.'new'()
@@ -100,20 +100,31 @@
print 'not '
ok_1:
say 'ok 1 - new() with no args returns an object'
-
+
+ push_eh ok_2
$P1 = $P0.'new'('abc' => '123' )
- $I0 = isa $P1, 'Object'
- if $I0 goto ok_2
+ clear_eh
print 'not '
ok_2:
- say 'ok 2 - new() with args returns an object'
+ say 'ok 2 - new with non-attribute key fails'
+
+ $P0 = new .Class
+ $P0.'add_attribute'('foo')
+ $P0.'add_attribute'('bar')
+ $P1 = $P0.'new'('foo' => 1, 'bar' => 2)
+ $P2 = getattribute $P1, 'foo'
+ say $P2
+ $P2 = getattribute $P1, 'bar'
+ say $P2
+ say 'ok 3 - new with key/value pairs sets attributes'
.end
CODE
ok 1 - new() with no args returns an object
-ok 2 - new() with args returns an object
+ok 2 - new() with non-attribute key fails
+1
+2
+ok 3 - new with key/value pairs sets attributes
OUT
-## test what's set in the object by .'new'() in t/pmc/object.t
-## XXX Second test here should probably fail if the class has no abc attribute
# L<PDD15/Class PMC API/=item attributes>
pir_output_is( <<'CODE', <<'OUT', 'attributes' );
