Index: t/oo/mro-c3.t =================================================================== --- t/oo/mro-c3.t (revision 35244) +++ t/oo/mro-c3.t (working copy) @@ -1,13 +1,7 @@ -#!perl -# Copyright (C) 2007, The Perl Foundation. +#!parrot +# Copyright (C) 2007-2009, The Perl Foundation. # $Id$ -use strict; -use warnings; -use lib qw( . lib ../lib ../../lib ); -use Test::More; -use Parrot::Test tests => 4; - =head1 NAME t/oo/mro-c3.t - test the C3 Method Resolution Order for Parrot OO @@ -22,179 +16,153 @@ =cut -pir_output_is( <<'CODE', <<'OUT', 'single parent' ); -.sub 'test' :main +.sub main :main + .include 'test_more.pir' + + plan(12) + + single_parent() + grandparent() + multiple_inheritance() + diamond_inheritance() +.end + +.sub method_A :method + .return('Method from A') +.end + +.sub method_B :method + .return('Method from B') +.end + +.sub method_C :method + .return('Method from C') +.end + +.sub method_D :method + .return('Method from D') +.end + +.sub single_parent .local pmc A, B A = new 'Class' - $P0 = get_global 'testA' - A.'add_method'("foo", $P0) - A.'add_method'("bar", $P0) + $P0 = get_global 'method_A' + A.'add_method'('foo', $P0) + A.'add_method'('bar', $P0) B = new 'Class' B.'add_parent'(A) - $P0 = get_global 'testB' - B.'add_method'("foo", $P0) + $P0 = get_global 'method_B' + B.'add_method'('foo', $P0) $P0 = B.'new'() - $P0.'foo'() - $P0.'bar'() + $S0 = $P0.'foo'() + $S1 = $P0.'bar'() + is($S0, 'Method from B', 'Single Parent - Method foo overloaded in B') + is($S1, 'Method from A', 'Single Parent - Method bar inherited from A') .end -.sub testA :method - print "Method from A called\n" -.end -.sub testB :method - print "Method from B called\n" -.end -CODE -Method from B called -Method from A called -OUT - -pir_output_is( <<'CODE', <<'OUT', 'grandparent' ); -.sub 'test' :main +.sub grandparent .local pmc A, B, C A = new 'Class' - $P0 = get_global 'testA' - A.'add_method'("foo", $P0) - A.'add_method'("bar", $P0) - A.'add_method'("baz", $P0) + $P0 = get_global 'method_A' + A.'add_method'('foo', $P0) + A.'add_method'('bar', $P0) + A.'add_method'('baz', $P0) B = new 'Class' B.'add_parent'(A) - $P0 = get_global 'testB' - B.'add_method'("foo", $P0) - B.'add_method'("bar", $P0) + $P0 = get_global 'method_B' + B.'add_method'('foo', $P0) + B.'add_method'('bar', $P0) C = new 'Class' C.'add_parent'(B) - $P0 = get_global 'testC' - C.'add_method'("foo", $P0) + $P0 = get_global 'method_C' + C.'add_method'('foo', $P0) $P0 = C.'new'() - $P0.'foo'() - $P0.'bar'() - $P0.'baz'() + $S0 = $P0.'foo'() + $S1 = $P0.'bar'() + $S2 = $P0.'baz'() + is($S0, 'Method from C', 'Grandparent - Method foo overloaded in C') + is($S1, 'Method from B', 'Grandparent - Method bar inherited from B') + is($S2, 'Method from A', 'Grandparent - Method baz inherited from A') .end -.sub testA :method - print "Method from A called\n" -.end -.sub testB :method - print "Method from B called\n" -.end -.sub testC :method - print "Method from C called\n" -.end -CODE -Method from C called -Method from B called -Method from A called -OUT - -pir_output_is( <<'CODE', <<'OUT', 'multiple inheritance' ); -.sub 'test' :main +.sub multiple_inheritance .local pmc A, B, C - - A = newclass 'A' - $P0 = get_global 'testA' - A.'add_method'("foo", $P0) - A.'add_method'("bar", $P0) - A.'add_method'("baz", $P0) - - B = newclass 'B' - $P0 = get_global 'testB' - B.'add_method'("foo", $P0) - B.'add_method'("bar", $P0) - - C = newclass 'C' + + A = newclass 'MIA' + $P0 = get_global 'method_A' + A.'add_method'('foo', $P0) + A.'add_method'('bar', $P0) + A.'add_method'('baz', $P0) + + B = newclass 'MIB' + $P0 = get_global 'method_B' + B.'add_method'('foo', $P0) + B.'add_method'('bar', $P0) + + C = newclass 'MIC' C.'add_parent'(B) C.'add_parent'(A) - $P0 = get_global 'testC' - C.'add_method'("foo", $P0) - + $P0 = get_global 'method_C' + C.'add_method'('foo', $P0) + $P0 = C.'new'() - $P0.'foo'() - $P0.'bar'() - $P0.'baz'() + $S0 = $P0.'foo'() + $S1 = $P0.'bar'() + $S2 = $P0.'baz'() + is($S0, 'Method from C', 'Multiple Inheritance - Method foo overloaded in C') + is($S1, 'Method from B', 'Multiple Inheritance - Method bar inherited from B') + is($S2, 'Method from A', 'Multiple Inheritance - Method baz inherited from A') .end -.sub testA :method - print "Method from A called\n" -.end -.sub testB :method - print "Method from B called\n" -.end -.sub testC :method - print "Method from C called\n" -.end -CODE -Method from C called -Method from B called -Method from A called -OUT - -pir_output_is( <<'CODE', <<'OUT', 'diamond inheritance' ); -.sub 'test' :main +.sub diamond_inheritance .local pmc A, B, C, D - A = newclass 'A' - $P0 = get_global 'testA' - A.'add_method'("foo", $P0) - A.'add_method'("bar", $P0) - A.'add_method'("baz", $P0) - A.'add_method'("wag", $P0) + A = newclass 'DIA' + $P0 = get_global 'method_A' + A.'add_method'('foo', $P0) + A.'add_method'('bar', $P0) + A.'add_method'('baz', $P0) + A.'add_method'('wag', $P0) - B = newclass 'B' + B = newclass 'DIB' B.'add_parent'(A) - $P0 = get_global 'testB' - B.'add_method'("foo", $P0) - B.'add_method'("bar", $P0) - B.'add_method'("baz", $P0) + $P0 = get_global 'method_B' + B.'add_method'('foo', $P0) + B.'add_method'('bar', $P0) + B.'add_method'('baz', $P0) - C = newclass 'C' + C = newclass 'DIC' C.'add_parent'(A) - $P0 = get_global 'testC' - C.'add_method'("foo", $P0) - C.'add_method'("bar", $P0) + $P0 = get_global 'method_C' + C.'add_method'('foo', $P0) + C.'add_method'('bar', $P0) - D = newclass 'D' + D = newclass 'DID' D.'add_parent'(C) D.'add_parent'(B) - $P0 = get_global 'testD' - D.'add_method'("foo", $P0) + $P0 = get_global 'method_D' + D.'add_method'('foo', $P0) $P0 = D.'new'() - $P0.'foo'() - $P0.'bar'() - $P0.'baz'() - $P0.'wag'() + $S0 = $P0.'foo'() + $S1 = $P0.'bar'() + $S2 = $P0.'baz'() + $S3 = $P0.'wag'() + is($S0, 'Method from D', 'Diamond Inheritance - Method foo overloaded in D') + is($S1, 'Method from C', 'Diamond Inheritance - Method bar inherited from C') + is($S2, 'Method from B', 'Diamond Inheritance - Method baz inherited from B') + is($S3, 'Method from A', 'Diamond Inheritance - Method wag inherited from A') .end -.sub testA :method - print "Method from A called\n" -.end -.sub testB :method - print "Method from B called\n" -.end -.sub testC :method - print "Method from C called\n" -.end -.sub testD :method - print "Method from D called\n" -.end -CODE -Method from D called -Method from C called -Method from B called -Method from A called -OUT - # Local Variables: -# mode: cperl -# cperl-indent-level: 4 +# mode: pir # fill-column: 100 # End: -# vim: expandtab shiftwidth=4: +# vim: expandtab shiftwidth=4 ft=pir: Index: t/oo/composition.t =================================================================== --- t/oo/composition.t (revision 35244) +++ t/oo/composition.t (working copy) @@ -1,13 +1,7 @@ -#!perl -# Copyright (C) 2007, The Perl Foundation. +#!parrot +# Copyright (C) 2007-2009, The Perl Foundation. # $Id$ -use strict; -use warnings; -use lib qw( . lib ../lib ../../lib ); -use Test::More; -use Parrot::Test tests => 10; - =head1 NAME t/oo/compositon.t - test role composition @@ -22,125 +16,116 @@ =cut -pir_output_is( <<'CODE', <<'OUT', 'role with no methods' ); -.sub 'test' :main +.sub main :main + .include 'except_types.pasm' + .include 'test_more.pir' + plan(41) + + role_with_no_methods() + role_with_one_method_no_methods_in_class() + two_roles_and_a_class_a_method_each_no_conflict() + two_roles_that_conflict() + role_that_conflicts_with_a_class_method() + conflict_resolution_by_exclusion() + conflict_resolution_by_aliasing_and_exclude() + conflict_resolution_by_resolve() + role_that_does_a_role() + conflict_from_indirect_role() +.end + +.sub badger :method + .return('Badger!') +.end +.sub badger2 :method + .return('Second Badger!') +.end +.sub mushroom :method + .return('Mushroom!') +.end +.sub snake :method + .return('Snake!') +.end +.sub fire + .return("You're FIRED!") +.end +.sub fire2 + .return('BURNINATION!') +.end +.sub give_payrise + .return('You all get a pay rise of 0.0005%.') +.end + +.sub role_with_no_methods $P0 = new 'Role' $P1 = new 'Class' $P1.'add_role'($P0) - print "ok 1 - added role\n" + ok(1, 'added role') $P2 = $P1.'roles'() $I0 = elements $P2 - if $I0 == 1 goto OK_2 - print "not " -OK_2: - print "ok 2 - roles list has the role\n" + is($I0, 1, 'roles list has the role') $P2 = $P1.'new'() - print "ok 3 - instantiated class with composed role\n" + ok(1, 'instantiated class with composed role') .end -CODE -ok 1 - added role -ok 2 - roles list has the role -ok 3 - instantiated class with composed role -OUT -pir_output_is( <<'CODE', <<'OUT', 'role with one method, no methods in class' ); -.sub 'test' :main +.sub role_with_one_method_no_methods_in_class $P0 = new 'Role' $P1 = new 'Class' $P2 = get_global "badger" $P0.'add_method'("badger", $P2) - print "ok 1 - added method to a role\n" + ok(1, 'added method to a role') $P1.'add_role'($P0) - print "ok 2 - composed role into the class\n" + ok(1, 'composed role into the class') $P2 = $P1.'roles'() $I0 = elements $P2 - if $I0 == 1 goto OK_3 - print "not " -OK_3: - print "ok 3 - roles list has the role\n" + is($I0, 1, 'roles list has the role') $P2 = $P1.'new'() - print "ok 4 - instantiated class with composed role\n" + ok(1, 'instantiated class with composed role') - $P2.'badger'() - print "ok 5 - called method composed from role\n" + $S0 = $P2.'badger'() + is($S0, 'Badger!', 'called method composed from role') .end -.sub badger :method - print "Badger!\n" -.end -CODE -ok 1 - added method to a role -ok 2 - composed role into the class -ok 3 - roles list has the role -ok 4 - instantiated class with composed role -Badger! -ok 5 - called method composed from role -OUT - -pir_output_is( <<'CODE', <<'OUT', 'two roles and a class, a method each, no conflict' ); -.sub 'test' :main +.sub two_roles_and_a_class_a_method_each_no_conflict $P0 = new 'Role' $P1 = new 'Role' $P2 = new 'Class' $P3 = get_global "snake" $P2.'add_method'("snake", $P3) - print "ok 1 - class has a method\n" + ok(1, 'class has a method') $P3 = get_global "badger" $P0.'add_method'("badger", $P3) $P2.'add_role'($P0) - print "ok 2 - composed first role into the class\n" + ok(1, 'composed first role into the class') $P3 = get_global "mushroom" $P1.'add_method'("mushroom", $P3) $P2.'add_role'($P1) - print "ok 3 - composed second role into the class\n" + ok(1, 'composed second role into the class') $P3 = $P2.'new'() - print "ok 4 - instantiated class\n" + ok(1, 'instantiated class') - $P3.'badger'() - print "ok 5 - called method from first role\n" + $S0 = $P3.'badger'() + is($S0, 'Badger!', 'called method from first role') - $P3.'mushroom'() - print "ok 6 - called method from second role\n" + $S1 = $P3.'mushroom'() + is($S1, 'Mushroom!', 'called method from second role') - $P3.'snake'() - print "ok 7 - called method from class\n" + $S2 = $P3.'snake'() + is($S2, 'Snake!', 'called method from class') .end -.sub badger :method - print "Badger!\n" -.end -.sub mushroom :method - print "Mushroom!\n" -.end -.sub snake :method - print "Snake!\n" -.end -CODE -ok 1 - class has a method -ok 2 - composed first role into the class -ok 3 - composed second role into the class -ok 4 - instantiated class -Badger! -ok 5 - called method from first role -Mushroom! -ok 6 - called method from second role -Snake! -ok 7 - called method from class -OUT - -pir_output_is( <<'CODE', <<'OUT', 'two roles that conflict' ); -.sub 'test' :main +.sub two_roles_that_conflict + .local pmc eh $P0 = new 'Role' $P1 = new 'Role' $P2 = new 'Class' @@ -148,67 +133,66 @@ $P3 = get_global "badger" $P0.'add_method'("badger", $P3) $P2.'add_role'($P0) - print "ok 1 - composed first role into the class\n" + ok(1, 'composed first role into the class') $P3 = get_global "badger2" $P1.'add_method'("badger", $P3) - push_eh OK_2 + + try: + eh = new 'ExceptionHandler' + eh.'handle_types'(.EXCEPTION_ROLE_COMPOSITION_METH_CONFLICT) + set_addr eh, catch + + push_eh eh $P2.'add_role'($P1) - print "not " + $I0 = 1 + goto finally + + catch: + $I0 = 0 + + finally: pop_eh -OK_2: - print "ok 2 - composition failed due to conflict\n" + nok($I0, 'composition failed due to conflict') .end -.sub badger :method - print "Badger!\n" -.end -.sub badger2 :method - print "Badger!\n" -.end -CODE -ok 1 - composed first role into the class -ok 2 - composition failed due to conflict -OUT - -pir_output_is( <<'CODE', <<'OUT', 'role that conflicts with a class method' ); -.sub 'test' :main +.sub role_that_conflicts_with_a_class_method + .local pmc eh $P0 = new 'Role' $P1 = new 'Class' $P2 = get_global "badger" $P1.'add_method'("badger", $P2) - print "ok 1 - class has a method\n" + ok(1, 'class has a method') $P2 = get_global "badger2" $P0.'add_method'("badger", $P2) - push_eh OK_2 + + try: + eh = new 'ExceptionHandler' + eh.'handle_types'(.EXCEPTION_ROLE_COMPOSITION_METH_CONFLICT) + set_addr eh, catch + + push_eh eh $P1.'add_role'($P0) - print "not " + $I0 = 1 + goto finally + + catch: + $I0 = 0 + + finally: pop_eh -OK_2: - print "ok 2 - composition failed due to conflict\n" + nok($I0, 'composition failed due to conflict') .end -.sub badger :method - print "Badger!\n" -.end -.sub badger2 :method - print "Badger!\n" -.end -CODE -ok 1 - class has a method -ok 2 - composition failed due to conflict -OUT - -pir_output_is( <<'CODE', <<'OUT', 'conflict resolution by exclusion' ); -.sub 'test' :main +.sub conflict_resolution_by_exclusion $P0 = new 'Role' $P1 = new 'Class' $P2 = get_global "badger" $P1.'add_method'("badger", $P2) - print "ok 1 - class has a method\n" + ok(1, 'class has a method') $P2 = get_global "badger2" $P0.'add_method'("badger", $P2) @@ -217,143 +201,79 @@ $P3 = new 'ResizableStringArray' push $P3, "badger" $P1.'add_role'($P0, 'exclude_method' => $P3) - print "ok 2 - composition worked due to exclusion\n" + ok(1, 'composition worked due to exclusion') $P2 = $P1.'new'() - $P2.'badger'() - print "ok 3 - called method from class\n" + $S0 = $P2.'badger'() + is($S0, 'Badger!', 'called method from class') - $P2.'snake'() - print "ok 4 - called method from role that wasn't excluded\n" + $S1 = $P2.'snake'() + is($S1, 'Snake!', "called method from role that wasn't excluded") .end -.sub badger :method - print "Badger!\n" -.end -.sub badger2 :method - print "Oops, wrong badger.\n" -.end -.sub snake :method - print "Snake!\n" -.end -CODE -ok 1 - class has a method -ok 2 - composition worked due to exclusion -Badger! -ok 3 - called method from class -Snake! -ok 4 - called method from role that wasn't excluded -OUT - -pir_output_is( <<'CODE', <<'OUT', 'conflict resolution by aliasing and exclude' ); -.sub 'test' :main +.sub conflict_resolution_by_aliasing_and_exclude $P0 = new 'Role' $P1 = new 'Class' - $P2 = get_global "badger" - $P1.'add_method'("badger", $P2) - print "ok 1 - class has a method\n" + $P2 = get_global 'badger' + $P1.'add_method'('badger', $P2) + ok(1, 'class has a method') - $P2 = get_global "badger2" - $P0.'add_method'("badger", $P2) - $P2 = get_global "snake" - $P0.'add_method'("snake", $P2) + $P2 = get_global 'badger2' + $P0.'add_method'('badger', $P2) + $P2 = get_global 'snake' + $P0.'add_method'('snake', $P2) $P3 = new 'Hash' - $P3["badger"] = "role_badger" + $P3['badger'] = 'role_badger' $P4 = new 'ResizableStringArray' - $P4[0] = "badger" + $P4[0] = 'badger' $P1.'add_role'($P0, 'alias_method' => $P3, 'exclude_method' => $P4) - print "ok 2 - composition worked due to aliasing and exclude\n" + ok(1, 'composition worked due to aliasing and exclude') $P2 = $P1.'new'() - $P2.'badger'() - print "ok 3 - called method from class\n" + $S0 = $P2.'badger'() + is($S0, 'Badger!', 'called method from class') - $P2.'snake'() - print "ok 4 - called method from role that wasn't aliased\n" + $S1 = $P2.'snake'() + is($S1, 'Snake!', "called method from role that wasn't aliased") - $P2.'role_badger'() - print "ok 5 - called method from role that was aliased\n" + $S2 = $P2.'role_badger'() + is($S2, 'Second Badger!', 'called method from role that was aliased') .end -.sub badger :method - print "Badger!\n" -.end -.sub badger2 :method - print "Aliased badger!\n" -.end -.sub snake :method - print "Snake!\n" -.end -CODE -ok 1 - class has a method -ok 2 - composition worked due to aliasing and exclude -Badger! -ok 3 - called method from class -Snake! -ok 4 - called method from role that wasn't aliased -Aliased badger! -ok 5 - called method from role that was aliased -OUT - -pir_output_is( <<'CODE', <<'OUT', 'conflict resolution by resolve' ); -.sub 'test' :main +.sub conflict_resolution_by_resolve $P0 = new 'Role' $P1 = new 'Class' $P3 = new 'ResizableStringArray' - push $P3, "badger" + push $P3, 'badger' $P1.'resolve_method'($P3) - print "ok 1 - set resolve list\n" + ok(1, 'set resolve list') $P4 = $P1.'resolve_method'() $S0 = $P4[0] - if $S0 == "badger" goto ok_2 - print "not " -ok_2: - print "ok 2 - got resolve list and it matched\n" + is($S0, 'badger', 'got resolve list and it matched') - $P2 = get_global "badger" - $P1.'add_method'("badger", $P2) - print "ok 3 - class has a method\n" + $P2 = get_global 'badger' + $P1.'add_method'('badger', $P2) + ok(1, 'class has a method') - $P2 = get_global "badger2" - $P0.'add_method'("badger", $P2) - $P2 = get_global "snake" - $P0.'add_method'("snake", $P2) + $P2 = get_global 'badger2' + $P0.'add_method'('badger', $P2) + $P2 = get_global 'snake' + $P0.'add_method'('snake', $P2) $P1.'add_role'($P0) - print "ok 4 - composition worked due to resolve\n" + ok(1, 'composition worked due to resolve') $P2 = $P1.'new'() - $P2.'badger'() - print "ok 5 - called method from class\n" + $S1 = $P2.'badger'() + is($S1, 'Badger!', 'called method from class') - $P2.'snake'() - print "ok 6 - called method from role that wasn't resolved\n" + $S2 = $P2.'snake'() + is($S2, 'Snake!', "called method from role that wasn't resolved") .end -.sub badger :method - print "Badger!\n" -.end -.sub badger2 :method - print "Oops, wrong badger.\n" -.end -.sub snake :method - print "Snake!\n" -.end -CODE -ok 1 - set resolve list -ok 2 - got resolve list and it matched -ok 3 - class has a method -ok 4 - composition worked due to resolve -Badger! -ok 5 - called method from class -Snake! -ok 6 - called method from role that wasn't resolved -OUT - -pir_output_is( <<'CODE', <<'OUT', 'role that does a role' ); -.sub 'test' :main +.sub role_that_does_a_role .local pmc PHB, Manage, FirePeople FirePeople = new 'Role' @@ -364,83 +284,61 @@ $P0 = get_global 'give_payrise' FirePeople.'add_method'("give_payrise", $P0) Manage.'add_role'(FirePeople) - print "ok 1 - adding one role to another happens\n" + ok(1, 'adding one role to another happens') PHB = new 'Class' PHB.'add_role'(Manage) - print "ok 2 - added one rule that does another role to the class\n" + ok(1, 'added one rule that does another role to the class') $P0 = PHB.'new'() - $P0.'give_payrise'() - print "ok 3 - called method from direct role\n" + $S0 = $P0.'give_payrise'() + is($S0, 'You all get a pay rise of 0.0005%.', 'called method from direct role') - $P0.'fire'() - print "ok 4 - called method from indirect role\n" + $S1 = $P0.'fire'() + is($S1, "You're FIRED!", 'called method from indirect role') .end -.sub fire - print "You're FIRED!\n" -.end -.sub give_payrise - print "You all get a pay rise of 0.0005%.\n" -.end -CODE -ok 1 - adding one role to another happens -ok 2 - added one rule that does another role to the class -You all get a pay rise of 0.0005%. -ok 3 - called method from direct role -You're FIRED! -ok 4 - called method from indirect role -OUT +.sub conflict_from_indirect_role + .local pmc eh, BurninatorBoss, Manage, FirePeople, Burninator -pir_output_is( <<'CODE', <<'OUT', 'conflict from indirect role' ); -.sub 'test' :main - .local pmc BurninatorBoss, Manage, FirePeople, Burninator - FirePeople = new 'Role' $P0 = get_global 'fire' - FirePeople.'add_method'("fire", $P0) + FirePeople.'add_method'('fire', $P0) Manage = new 'Role' $P0 = get_global 'give_payrise' - FirePeople.'add_method'("give_payrise", $P0) + FirePeople.'add_method'('give_payrise', $P0) Manage.'add_role'(FirePeople) Burninator = new 'Role' $P0 = get_global 'fire2' - Burninator.'add_method'("fire", $P0) - print "ok 1 - all roles created\n" + Burninator.'add_method'('fire', $P0) + ok(1, 'all roles created') BurninatorBoss = new 'Class' BurninatorBoss.'add_role'(Manage) - print "ok 2 - added first role with indirect role\n" + ok(1, 'added first role with indirect role') - push_eh OK_3 + try: + eh = new 'ExceptionHandler' + eh.'handle_types'(.EXCEPTION_ROLE_COMPOSITION_METH_CONFLICT) + set_addr eh, catch + + push_eh eh BurninatorBoss.'add_role'(Burninator) - print "not " + $I0 = 1 + goto finally + + catch: + $I0 = 0 + + finally: pop_eh -OK_3: - print "ok 3 - second role conflicts with method from indirect role\n" + nok($I0, 'second role conflicts with method from indirect role') .end -.sub fire - print "You're FIRED!\n" -.end -.sub fire2 - print "BURNINATION!\n" -.end -.sub give_payrise - print "You all get a pay rise of 0.0005%.\n" -.end -CODE -ok 1 - all roles created -ok 2 - added first role with indirect role -ok 3 - second role conflicts with method from indirect role -OUT - # Local Variables: -# mode: cperl -# cperl-indent-level: 4 +# mode: pir # fill-column: 100 # End: -# vim: expandtab shiftwidth=4: +# vim: expandtab shiftwidth=4 ft=pir: Index: t/oo/new.t =================================================================== --- t/oo/new.t (revision 35244) +++ t/oo/new.t (working copy) @@ -1,13 +1,7 @@ -#!perl -# Copyright (C) 2007-2008, The Perl Foundation. +#!parrot +# Copyright (C) 2007-2009, The Perl Foundation. # $Id$ -use strict; -use warnings; -use lib qw( . lib ../lib ../../lib ); -use Test::More; -use Parrot::Test tests => 23; - =head1 NAME t/oo/new.t - Test OO instantiation @@ -22,621 +16,472 @@ =cut -pir_output_is( <<'CODE', <<'OUT', 'instantiate from class object' ); .sub main :main - $P1 = newclass "Foo" - $S1 = typeof $P1 - say $S1 + .include 'except_types.pasm' + .include 'test_more.pir' + plan(111) - $I3 = isa $P1, "Class" - print $I3 - print "\n" + instantiate_from_class_object() + manually_create_anonymous_class_object() + manually_create_named_class_object() + instantiate_from_class_object_method() + instantiate_from_string_name() + instantiate_from_string_register_name() + instantiate_from_string_PMC_name() + instantiate_from_key_name() + instantiate_from_key_PMC_name() + create_and_instantiate_from_array_of_names() + only_string_arrays_work_for_creating_classes() + instantiate_from_class_object_with_init() + instantiate_from_string_name_with_init() + instantiate_from_string_register_name_with_init() + instantiate_from_string_PMC_name_with_init() + instantiate_from_array_of_names_with_init() + instantiate_from_key_name_with_init() + create_class_namespace_initializer() + regression_test_instantiate_class_within_different_namespace() + get_class_retrieves_a_high_level_class_object() + get_class_retrieves_a_proxy_class_object() + get_class_retrieves_a_class_object_that_doesnt_exist() + instantiate_class_from_invalid_key() +.end - $P2 = new $P1 - $S1 = typeof $P2 - say $S1 +# +# Utility sub +# +.sub _test_instance + .param pmc obj + .param string in_str - $I3 = isa $P2, "Foo" - print $I3 - print "\n" + # Set up local variables + .local pmc key_pmc + .local string class_name - $I3 = isa $P2, "Object" - print $I3 - print "\n" -.end -CODE -Class -1 -Foo -1 -1 -OUT + key_pmc = new 'Key' + $P0 = split ' ', in_str + $S0 = shift $P0 + $I1 = 1 + key_pmc = $S0 + class_name = $S0 -pir_output_is( <<'CODE', <<'OUT', 'manually create anonymous class object' ); -.sub main :main - $P1 = new "Class" - $S1 = typeof $P1 - say $S1 + LOOP: + $I0 = elements $P0 + if $I0 == 0 goto BEGIN_TEST + $S1 = shift $P0 + $P1 = new 'Key' + $P1 = $S1 + push key_pmc, $P1 + concat class_name, ';' + concat class_name, $S1 + $I1 += 1 + goto LOOP - $I3 = isa $P1, "Class" - print $I3 - print "\n" + # Start testing + BEGIN_TEST: + .local string typeof_message + typeof_message = concat 'New instance is of type: ', class_name + $S1 = typeof obj + is($S1, class_name, typeof_message) - $P2 = new $P1 + isa_ok(obj, 'Object') - $S1 = typeof $P2 - print "'" - print $S1 - print "'\n" + .local string keypmc_message + $S2 = get_repr key_pmc + keypmc_message = concat 'The object isa ', $S2 + $I2 = isa obj, key_pmc + ok($I2, keypmc_message) - $I3 = isa $P2, "Foo" - print $I3 - print "\n" + unless $I1 == 1 goto END_TEST + isa_ok(obj, class_name) - $I3 = isa $P2, "Object" - print $I3 - print "\n" + END_TEST: + .return() .end -CODE -Class -1 -'' -0 -1 -OUT -pir_output_is( <<'CODE', <<'OUT', 'manually create named class object' ); -.sub main :main - $P1 = new "Class" - $P1.'name'("Foo") - $S1 = typeof $P1 - say $S1 - $I3 = isa $P1, "Class" - print $I3 - print "\n" +############################################################################# - $P2 = new $P1 - $S1 = typeof $P2 - say $S1 +.sub instantiate_from_class_object + ok(1, "Instantiate from class object") + $P1 = newclass 'Foo1' + $S1 = typeof $P1 + is($S1, 'Class', '`newclass "Foo"` creates a Class PMC') + isa_ok($P1, 'Class') - $I3 = isa $P2, "Foo" - print $I3 - print "\n" - - $I3 = isa $P2, "Object" - print $I3 - print "\n" + $P2 = new $P1 + _test_instance($P2, 'Foo1') .end -CODE -Class -1 -Foo -1 -1 -OUT -pir_output_is( <<'CODE', <<'OUT', 'instantiate from class object method' ); -.sub main :main - $P1 = newclass "Foo" - $P2 = $P1.'new'() +.sub manually_create_anonymous_class_object + ok(2, "Manually create anonymous class object") + $P1 = new 'Class' + $S1 = typeof $P1 + is($S1, 'Class', 'New anonymous class creates a Class PMC') + isa_ok($P1, 'Class') + + $P2 = new $P1 $S1 = typeof $P2 - say $S1 + is($S1, '', 'New instance is of type ""') + isa_ok($P2, 'Object') - $I3 = isa $P2, "Foo" - print $I3 - print "\n" - - $I3 = isa $P2, "Object" - print $I3 - print "\n" + $I3 = isa $P2, '' + is($I3, 0, '"isa" will not match an empty type') + $I3 = isa $P2, 'Foo' + is($I3, 0, '"isa" will not match a random type') .end -CODE -Foo -1 -1 -OUT -pir_output_is( <<'CODE', <<'OUT', 'instantiate from string name' ); -.sub main :main - $P1 = newclass "Foo" - $P2 = new 'Foo' - $S1 = typeof $P2 - say $S1 +.sub manually_create_named_class_object + ok(3, "Manually create named class object") + $P1 = new 'Class' + $P1.'name'('Foo2') + $S1 = typeof $P1 + is($S1, 'Class', 'new named class creates a "Class" PMC') + isa_ok($P1, 'Class') - $I3 = isa $P2, "Foo" - print $I3 - print "\n" - - $I3 = isa $P2, "Object" - print $I3 - print "\n" + $P2 = new $P1 + _test_instance($P2, 'Foo2') .end -CODE -Foo -1 -1 -OUT -pir_output_is( <<'CODE', <<'OUT', 'instantiate from string register name' ); -.sub main :main - $P1 = newclass "Foo" - $S1 = 'Foo' - $P2 = new $S1 - $S1 = typeof $P2 - say $S1 +.sub instantiate_from_class_object_method + ok(4, "Instantiate from class object 'new' method") + $P1 = newclass 'Foo3' - $I3 = isa $P2, "Foo" - print $I3 - print "\n" - - $I3 = isa $P2, "Object" - print $I3 - print "\n" + $P2 = $P1.'new'() + _test_instance($P2, 'Foo3') .end -CODE -Foo -1 -1 -OUT -pir_output_is( <<'CODE', <<'OUT', 'instantiate from string PMC name' ); -.sub main :main - $P1 = newclass "Foo" - $P3 = new 'String' - $P3 = 'Foo' - $P2 = new $P3 - $S1 = typeof $P2 - say $S1 +.sub instantiate_from_string_name + ok(5, "Instantiate from string name") + $P1 = newclass 'Foo4' - $I3 = isa $P2, "Foo" - print $I3 - print "\n" - - $I3 = isa $P2, "Object" - print $I3 - print "\n" + $P2 = new 'Foo4' + _test_instance($P2, 'Foo4') .end -CODE -Foo -1 -1 -OUT -pir_output_is( <<'CODE', <<'OUT', 'instantiate from key name' ); -.sub main :main - $P1 = newclass ['Foo';'Bar'] - $S1 = typeof $P1 - say $S1 - $I3 = isa $P1, "Class" - print $I3 - print "\n" +.sub instantiate_from_string_register_name + ok(6, "Instantiate from string register name") + $P1 = newclass 'Foo5' - $P2 = new ['Foo';'Bar'] + $S1 = 'Foo5' + $P2 = new $S1 + _test_instance($P2, 'Foo5') +.end - $S1 = typeof $P2 - say $S1 - $I3 = isa $P2, ['Foo';'Bar'] - print $I3 - print "\n" +.sub instantiate_from_string_PMC_name + ok(7, "Instantiate from string PMC name") + $P1 = newclass 'Foo6' - $I3 = isa $P2, "Object" - print $I3 - print "\n" + $P3 = new 'String' + $P3 = 'Foo6' + $P2 = new $P3 + _test_instance($P2, 'Foo6') .end -CODE -Class -1 -Foo;Bar -1 -1 -OUT -pir_output_is( - <<'CODE', <<'OUT', 'instantiate from key PMC name', todo => 'create non-constant key' ); -.sub main :main - $P1 = newclass ['Foo';'Bar'] + +.sub instantiate_from_key_name + ok(8, "Instantiate from Key name") + $P1 = newclass ['Foo';'Bar1'] $S1 = typeof $P1 - say $S1 + is($S1, 'Class', "`newclass ['Foo';'Bar1']` creates a Class PMC") + isa_ok($P1, 'Class') - $I3 = isa $P1, "Class" - say $I3 + $P2 = new $P1 + _test_instance($P2, 'Foo Bar1') +.end - # How do you set the value of a non-constant key PMC? - $P3 = new 'Key' - $P2 = new $P3 +.sub instantiate_from_key_PMC_name + ok(9, "Instantiate from Key PMC name") + $P1 = newclass ['Foo';'Bar2'] - $S1 = typeof $P2 - say $S1 + $P3 = new 'Key' + $P3 = 'Foo' + $P4 = new 'Key' + $P4 = 'Bar2' + push $P3, $P4 - $I3 = isa $P2, 'Bar' - say $I3 - - $I3 = isa $P2, "Object" - say $I3 + $P2 = new $P3 + _test_instance($P2, 'Foo Bar2') .end -CODE -Class -1 -Foo;Bar -1 -1 -OUT -pir_output_is( <<'CODE', <<'OUT', 'create and instantiate from array of names' ); -.sub main :main - $P0 = split " ", "Foo Bar" + +.sub create_and_instantiate_from_array_of_names + ok(10, "Create and instantiate from ResizableStringArray") + $P0 = split ' ', 'Foo Bar3' $P1 = newclass $P0 $S1 = typeof $P1 - say $S1 + is($S1, 'Class', "`newclass some_string_array` creates a Class PMC") + isa_ok($P1, 'Class') - $I3 = isa $P1, "Class" - print $I3 - print "\n" - $P2 = new $P0 - - $S1 = typeof $P2 - say $S1 - - $I3 = isa $P2, ['Foo';'Bar'] - print $I3 - print "\n" - - $I3 = isa $P2, "Object" - print $I3 - print "\n" + _test_instance($P2, 'Foo Bar3') .end -CODE -Class -1 -Foo;Bar -1 -1 -OUT -pir_error_output_like( <<'CODE', <<'OUT', 'only string arrays work for creating classes' ); -.sub main :main - $P0 = new 'ResizablePMCArray' + +.sub only_string_arrays_work_for_creating_classes + ok(11, 'Create a class via a ResizablePMCArray') + .local pmc eh + .local string message + $P0 = new 'ResizablePMCArray' $P10 = new 'String' $P10 = 'Foo' $P11 = new 'String' - $P11 = 'Bar' + $P11 = 'Bar4' + $P0.'push'($P10) + $P0.'push'($P11) + try: + eh = new 'ExceptionHandler' + eh.'handle_types'(.EXCEPTION_INVALID_OPERATION) + set_addr eh, catch + + push_eh eh $P1 = newclass $P0 - $S1 = typeof $P1 - say $S1 + $I0 = 1 + goto finally - $I3 = isa $P1, "Class" - print $I3 - print "\n" + catch: + .local pmc exception + .get_results(exception) + message = exception['message'] + $I0 = 0 - $P2 = new $P0 - - $S1 = typeof $P2 - say $S1 - - $I3 = isa $P2, ['Foo';'Bar'] - print $I3 - print "\n" - - $I3 = isa $P2, "Object" - print $I3 - print "\n" + finally: + pop_eh + nok($I0, "Exception caught for ...") + is(message, 'Invalid class name key in init_pmc for Class', 'Invalid class name key') .end -CODE -/Invalid class name key/ -OUT -pir_output_is( <<'CODE', <<'OUT', 'instantiate from class object with init' ); -.sub main :main - $P1 = newclass "Foo" + +.sub instantiate_from_class_object_with_init + ok(12, 'Instantiate from Class object, with init') + $P1 = newclass 'Foo7' addattribute $P1, 'data' $P3 = new 'Hash' $P4 = new 'String' - $P4 = "data for Foo\n" + $P4 = 'data for Foo7' $P3['data'] = $P4 $P2 = new $P1, $P3 + _test_instance($P2, 'Foo7') - $S1 = typeof $P2 - say $S1 - - $I3 = isa $P2, "Foo" - print $I3 - print "\n" - - $I3 = isa $P2, "Object" - print $I3 - print "\n" - $P5 = getattribute $P2, 'data' - print $P5 + is($P5, 'data for Foo7', 'class attribute retrieved via the instance') .end -CODE -Foo -1 -1 -data for Foo -OUT -pir_output_is( <<'CODE', <<'OUT', 'instantiate from string name with init' ); -.sub main :main - $P1 = newclass "Foo" + +.sub instantiate_from_string_name_with_init + ok(13, 'Instantiate from string name, with init') + $P1 = newclass 'Foo8' addattribute $P1, 'data' $P3 = new 'Hash' $P4 = new 'String' - $P4 = "data for Foo\n" + $P4 = 'data for Foo8' $P3['data'] = $P4 - $P2 = new 'Foo', $P3 + $P2 = new 'Foo8', $P3 + _test_instance($P2, 'Foo8') - $S1 = typeof $P2 - say $S1 - - $I3 = isa $P2, "Foo" - print $I3 - print "\n" - - $I3 = isa $P2, "Object" - print $I3 - print "\n" - $P5 = getattribute $P2, 'data' - print $P5 + is($P5, 'data for Foo8', 'class attribute retrieved via the instance') .end -CODE -Foo -1 -1 -data for Foo -OUT -pir_output_is( <<'CODE', <<'OUT', 'instantiate from string register name with init' ); -.sub main :main - $P1 = newclass "Foo" + +.sub instantiate_from_string_register_name_with_init + ok(14, 'Instantiate from string register name, with init') + $P1 = newclass 'Foo9' addattribute $P1, 'data' $P3 = new 'Hash' $P4 = new 'String' - $P4 = "data for Foo\n" + $P4 = 'data for Foo9' $P3['data'] = $P4 - $S1 = 'Foo' + $S1 = 'Foo9' $P2 = new $S1, $P3 + _test_instance($P2, 'Foo9') - $S1 = typeof $P2 - say $S1 - - $I3 = isa $P2, "Foo" - print $I3 - print "\n" - - $I3 = isa $P2, "Object" - print $I3 - print "\n" - $P5 = getattribute $P2, 'data' - print $P5 + is($P5, 'data for Foo9', 'class attribute retrieved via the instance') .end -CODE -Foo -1 -1 -data for Foo -OUT -pir_output_is( <<'CODE', <<'OUT', 'instantiate from string PMC name with init' ); -.sub main :main - $P1 = newclass "Foo" + +.sub instantiate_from_string_PMC_name_with_init + ok(15, 'Instantiate from string PMC name, with init') + $P1 = newclass 'Foo10' addattribute $P1, 'data' $P3 = new 'Hash' $P4 = new 'String' - $P4 = "data for Foo\n" + $P4 = 'data for Foo10' $P3['data'] = $P4 $P6 = new 'String' - $P6 = 'Foo' + $P6 = 'Foo10' $P2 = new $P6, $P3 + _test_instance($P2, 'Foo10') - $S1 = typeof $P2 - say $S1 - - $I3 = isa $P2, "Foo" - print $I3 - print "\n" - - $I3 = isa $P2, "Object" - print $I3 - print "\n" - $P5 = getattribute $P2, 'data' - print $P5 + is($P5, 'data for Foo10', 'class attribute retrieved via the instance') .end -CODE -Foo -1 -1 -data for Foo -OUT -pir_output_is( <<'CODE', <<'OUT', 'instantiate from array of names with init' ); -.sub main :main - $P0 = split " ", "Foo Bar" + +.sub instantiate_from_array_of_names_with_init + ok(16, 'Instantiate from string array, with init') + $P0 = split ' ', 'Foo Bar5' $P1 = newclass $P0 addattribute $P1, 'data' $P3 = new 'Hash' $P4 = new 'String' - $P4 = "data for Foo;Bar\n" + $P4 = 'data for Foo;Bar5' $P3['data'] = $P4 $P2 = new $P0, $P3 $S1 = typeof $P2 - say $S1 + _test_instance($P2, 'Foo Bar5') - $I3 = isa $P2, ["Foo";"Bar"] - print $I3 - print "\n" - - $I3 = isa $P2, "Object" - print $I3 - print "\n" - $P5 = getattribute $P2, 'data' - print $P5 + is($P5, 'data for Foo;Bar5', 'class attribute retrieved via the instance') .end -CODE -Foo;Bar -1 -1 -data for Foo;Bar -OUT -pir_output_is( <<'CODE', <<'OUT', 'instantiate from key name with init' ); -.sub main :main - $P1 = newclass ['Foo';'Bar'] + +.sub instantiate_from_key_name_with_init + ok(17, 'Instantiate from Key name, with init') + $P1 = newclass ['Foo';'Bar6'] addattribute $P1, 'data' $P3 = new 'Hash' $P4 = new 'String' - $P4 = "data for Foo;Bar\n" + $P4 = 'data for Foo;Bar6' $P3['data'] = $P4 - $P2 = new ['Foo';'Bar'], $P3 + $P2 = new ['Foo';'Bar6'], $P3 + _test_instance($P2, 'Foo Bar6') - $S1 = typeof $P2 - say $S1 - - $I3 = isa $P2, 'Bar' - print $I3 - print "\n" - - $I3 = isa $P2, "Object" - print $I3 - print "\n" - $P5 = getattribute $P2, 'data' - print $P5 + is($P5, 'data for Foo;Bar6', 'class attribute retrieved via the instance') .end -CODE -Foo;Bar -0 -1 -data for Foo;Bar -OUT -pir_output_is( <<'CODE', <<'OUT', 'create class namespace initializer' ); -.sub main :main + +.sub create_class_namespace_initializer .local pmc ns - ns = get_namespace ['Foo';'Bar'] + ns = get_namespace ['Foo';'Bar7'] $P0 = new 'Class', ns - $P1 = new ['Foo';'Bar'] - $P1.'blue'() + $P1 = new ['Foo';'Bar7'] + $S0 = $P1.'blue'() + is($S0, 'foo_bar7 blue', 'Create class namespace initializer') .end -.namespace [ 'Foo';'Bar' ] -.sub 'blue' :method - say 'foo blue' +.namespace [ 'Foo';'Bar7' ] +.sub blue :method + .return('foo_bar7 blue') .end -CODE -foo blue -OUT +.namespace [] -pir_output_is( <<'CODE', <<'OUT', 'regression test, instantiate class within different namespace' ); -.sub main :main - $P0 = newclass 'Foo' - $P0 = newclass 'Bar' - $P1 = new 'Foo' - $P1.'blue'() +.sub regression_test_instantiate_class_within_different_namespace + $P0 = newclass 'Foo11' + $P0 = newclass 'Bar11' + + $P1 = new 'Foo11' + $S0 = $P1.'blue'() + is($S0, 'foo11 blue bar11 blue', 'Regression test: instantiate class within different namespace') .end -.namespace [ 'Foo' ] -.sub 'blue' :method - say 'foo blue' - $P1 = new 'Bar' - $P1.'blue'() +.namespace [ 'Foo11' ] +.sub blue :method + $P0 = new 'Bar11' + $S0 = $P0.'blue'() + $S0 = concat 'foo11 blue ', $S0 + .return($S0) .end -.namespace [ 'Bar' ] -.sub 'blue' :method - say 'bar blue' +.namespace [ 'Bar11' ] +.sub blue :method + .return('bar11 blue') .end -CODE -foo blue -bar blue -OUT -pir_output_is( <<'CODE', <<'OUT', 'get_class retrieves a high-level class object' ); -.sub main :main - $P0 = newclass 'Foo' +.namespace [] + + +.sub get_class_retrieves_a_high_level_class_object + ok(20, 'get_class retrieves a high level class object') + $P0 = newclass 'Foo12' $S1 = typeof $P0 - say $S1 + is($S1, 'Class',"`newclass 'Foo12' returns a Class PMC`") - $P1 = get_class 'Foo' + $P1 = get_class 'Foo12' $S1 = typeof $P1 - say $S1 + is($S1, 'Class',"`get_class 'Foo12' returns a Class PMC`") $P2 = new $P1 - $S1 = typeof $P2 - say $S1 + _test_instance($P2, 'Foo12') .end -CODE -Class -Class -Foo -OUT -pir_output_is( <<'CODE', <<'OUT', 'get_class retrieves a proxy class object' ); -.sub main :main + +.sub get_class_retrieves_a_proxy_class_object + ok(21, 'get_class retrieves a proxy class object') $P1 = get_class 'String' $S1 = typeof $P1 - say $S1 + is($S1, 'PMCProxy', "`get_class 'String'` returns a PMCProxy PMC") $P2 = new $P1 $S1 = typeof $P2 - say $S1 + is($S1, 'String', 'Instantiating the proxy returns a String PMC') .end -CODE -PMCProxy -String -OUT -pir_output_is( <<'CODE', <<'OUT', "get_class retrieves a class object that doesn't exist" ); -.sub main :main + +.sub get_class_retrieves_a_class_object_that_doesnt_exist + ok(22, 'get_class retrieves a class object that does not exist') + .local int murple_not_defined + murple_not_defined = 1 $P1 = get_class 'Murple' if null $P1 goto not_defined - say "Class is defined. Shouldn't be." - end + murple_not_defined = 0 + not_defined: - say "Class isn't defined." + ok(murple_not_defined, '"Murple" class is not defined') .end -CODE -Class isn't defined. -OUT -pir_error_output_like(<<'CODE', <<'OUT', 'Instantiate class from invalid key'); -.sub 'main' :main + +.sub instantiate_class_from_invalid_key + ok(23, 'Instantiate a class from invalid Key PMC') + .local pmc eh + .local string message + + try: + eh = new 'ExceptionHandler' + eh.'handle_types'(.EXCEPTION_NO_CLASS) + set_addr eh, catch + + push_eh eh $P0 = new [ 'Foo'; 'Bar'; 'Baz' ] + $I0 = 1 + goto finally + + catch: + .local pmc exception + .get_results(exception) + message = exception['message'] + $I0 = 0 + + finally: pop_eh + nok($I0, 'Exception caught for ...') + is(message, "Class '[ 'Foo' ; 'Bar' ; 'Baz' ]' not found", 'Class not found') .end -CODE -/Class '\[ 'Foo' ; 'Bar' ; 'Baz' \]' not found/ -OUT + # Local Variables: -# mode: cperl -# cperl-indent-level: 4 +# mode: pir # fill-column: 100 # End: -# vim: expandtab shiftwidth=4: +# vim: expandtab shiftwidth=4 ft=pir: