develooper Front page | perl.cvs.parrot | Postings from January 2009

[svn:parrot] r35326 - trunk/t/oo

From:
cotto
Date:
January 9, 2009 18:02
Subject:
[svn:parrot] r35326 - trunk/t/oo
Message ID:
20090110020159.97407CB9F9@x12.develooper.com
Author: cotto
Date: Fri Jan  9 18:01:58 2009
New Revision: 35326

Modified:
   trunk/t/oo/composition.t
   trunk/t/oo/mro-c3.t
   trunk/t/oo/new.t

Log:
[t] convert perl OO tests to pure pir
patch courtesy of GeJ++


Modified: trunk/t/oo/composition.t
==============================================================================
--- trunk/t/oo/composition.t	(original)
+++ trunk/t/oo/composition.t	Fri Jan  9 18:01:58 2009
@@ -1,13 +1,7 @@
-#!perl
+#! parrot
 # Copyright (C) 2007, 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"
-.end
-
-.sub badger :method
-    print "Badger!\n"
+    $S2 = $P3.'snake'()
+    is($S2, 'Snake!', 'called method from class')
 .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 "
-    pop_eh
-OK_2:
-    print "ok 2 - composition failed due to conflict\n"
-.end
+    $I0 = 1
+    goto finally
 
-.sub badger :method
-    print "Badger!\n"
-.end
-.sub badger2 :method
-    print "Badger!\n"
+  catch:
+    $I0 = 0
+
+  finally:
+    pop_eh
+    nok($I0, 'composition failed due to conflict')
 .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 "
-    pop_eh
-OK_2:
-    print "ok 2 - composition failed due to conflict\n"
-.end
+    $I0 = 1
+    goto finally
 
-.sub badger :method
-    print "Badger!\n"
-.end
-.sub badger2 :method
-    print "Badger!\n"
+  catch:
+    $I0 = 0
+
+  finally:
+    pop_eh
+    nok($I0, 'composition failed due to conflict')
 .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"
-.end
-
-.sub badger :method
-    print "Badger!\n"
+    $S1 = $P2.'snake'()
+    is($S1, 'Snake!', "called method from role that wasn't excluded")
 .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 "badger2"
-    $P0.'add_method'("badger", $P2)
-    $P2 = get_global "snake"
-    $P0.'add_method'("snake", $P2)
+    $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)
     $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"
-
-    $P2.'snake'()
-    print "ok 4 - called method from role that wasn't aliased\n"
+    $S0 = $P2.'badger'()
+    is($S0, 'Badger!', 'called method from class')
 
-    $P2.'role_badger'()
-    print "ok 5 - called method from role that was aliased\n"
-.end
+    $S1 = $P2.'snake'()
+    is($S1, 'Snake!', "called method from role that wasn't aliased")
 
-.sub badger :method
-    print "Badger!\n"
-.end
-.sub badger2 :method
-    print "Aliased badger!\n"
-.end
-.sub snake :method
-    print "Snake!\n"
+    $S2 = $P2.'role_badger'()
+    is($S2, 'Second Badger!', 'called method from role that was aliased')
 .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"
-
-    $P2 = get_global "badger"
-    $P1.'add_method'("badger", $P2)
-    print "ok 3 - class has a method\n"
+    is($S0, 'badger', 'got resolve list and it matched')
 
-    $P2 = get_global "badger2"
-    $P0.'add_method'("badger", $P2)
-    $P2 = get_global "snake"
-    $P0.'add_method'("snake", $P2)
+    $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)
     $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"
-
-    $P2.'snake'()
-    print "ok 6 - called method from role that wasn't resolved\n"
-.end
+    $S1 = $P2.'badger'()
+    is($S1, 'Badger!', 'called method from class')
 
-.sub badger :method
-    print "Badger!\n"
-.end
-.sub badger2 :method
-    print "Oops, wrong badger.\n"
-.end
-.sub snake :method
-    print "Snake!\n"
+    $S2 = $P2.'snake'()
+    is($S2, 'Snake!', "called method from role that wasn't resolved")
 .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'
@@ -362,85 +282,63 @@
 
     Manage = new 'Role'
     $P0 = get_global 'give_payrise'
-    FirePeople.'add_method'("give_payrise", $P0)
+    Manage.'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
-
-pir_output_is( <<'CODE', <<'OUT', 'conflict from indirect role' );
-.sub 'test' :main
-    .local pmc BurninatorBoss, Manage, FirePeople, Burninator
+.sub conflict_from_indirect_role
+    .local pmc eh, 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')
+
+  try:
+    eh = new 'ExceptionHandler'
+    eh.'handle_types'(.EXCEPTION_ROLE_COMPOSITION_METH_CONFLICT)
+    set_addr eh, catch
 
-    push_eh OK_3
+    push_eh eh
     BurninatorBoss.'add_role'(Burninator)
-    print "not "
-    pop_eh
-OK_3:
-    print "ok 3 - second role conflicts with method from indirect role\n"
-.end
+    $I0 = 1
+    goto finally
 
-.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"
+  catch:
+    $I0 = 0
+
+  finally:
+    pop_eh
+    nok($I0, 'second role conflicts with method from indirect role')
 .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:

Modified: trunk/t/oo/mro-c3.t
==============================================================================
--- trunk/t/oo/mro-c3.t	(original)
+++ trunk/t/oo/mro-c3.t	Fri Jan  9 18:01:58 2009
@@ -1,13 +1,7 @@
-#!perl
+#! parrot
 # Copyright (C) 2007, 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'()
-.end
-
-.sub testA :method
-    print "Method from A called\n"
-.end
-.sub testB :method
-    print "Method from B called\n"
+    $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
-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'()
-.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
+    $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
 
 # Local Variables:
-#   mode: cperl
-#   cperl-indent-level: 4
+#   mode: pir
 #   fill-column: 100
 # End:
-# vim: expandtab shiftwidth=4:
+# vim: expandtab shiftwidth=4 ft=pir:

Modified: trunk/t/oo/new.t
==============================================================================
--- trunk/t/oo/new.t	(original)
+++ trunk/t/oo/new.t	Fri Jan  9 18:01:58 2009
@@ -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"
+    .include 'except_types.pasm'
+    .include 'test_more.pir'
+    plan(111)
+
+    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
+
+
+#
+# Utility sub
+#
+.sub _test_instance
+    .param pmc obj
+    .param string in_str 
+
+    # Set up local variables
+    .local pmc key_pmc
+    .local string class_name
+
+    key_pmc = new 'Key'
+    $P0 = split ' ', in_str
+    $S0 = shift $P0
+    $I1 = 1
+    key_pmc    = $S0
+    class_name = $S0
+
+  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
+
+    # 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)
+
+    isa_ok(obj, 'Object')
+
+    .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)
+
+    unless $I1 == 1 goto END_TEST
+    isa_ok(obj, class_name)
+
+  END_TEST:
+    .return()
+.end
+
+
+#############################################################################
+
+
+.sub instantiate_from_class_object
+    ok(1, "Instantiate from class object")
+    $P1 = newclass 'Foo1'
     $S1 = typeof $P1
-    say $S1
-
-    $I3 = isa $P1, "Class"
-    print $I3
-    print "\n"
+    is($S1, 'Class', '`newclass "Foo"` creates a Class PMC')
+    isa_ok($P1, 'Class')
 
     $P2 = new $P1
+    _test_instance($P2, 'Foo1')
+.end
 
-    $S1 = typeof $P2
-    say $S1
-
-    $I3 = isa $P2, "Foo"
-    print $I3
-    print "\n"
-
-    $I3 = isa $P2, "Object"
-    print $I3
-    print "\n"
-.end
-CODE
-Class
-1
-Foo
-1
-1
-OUT
 
-pir_output_is( <<'CODE', <<'OUT', 'manually create anonymous class object' );
-.sub main :main
-    $P1 = new "Class"
+.sub manually_create_anonymous_class_object
+    ok(2, "Manually create anonymous class object")
+    $P1 = new 'Class'
     $S1 = typeof $P1
-    say $S1
-
-    $I3 = isa $P1, "Class"
-    print $I3
-    print "\n"
+    is($S1, 'Class', 'New anonymous class creates a Class PMC')
+    isa_ok($P1, 'Class')
 
     $P2 = new $P1
-
     $S1 = typeof $P2
-    print "'"
-    print $S1
-    print "'\n"
-
-    $I3 = isa $P2, "Foo"
-    print $I3
-    print "\n"
-
-    $I3 = isa $P2, "Object"
-    print $I3
-    print "\n"
-.end
-CODE
-Class
-1
-''
-0
-1
-OUT
+    is($S1, '', 'New instance is of type ""')
+    isa_ok($P2, 'Object')
+
+    $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
 
-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"
+.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')
 
     $P2 = new $P1
+    _test_instance($P2, 'Foo2')
+.end
 
-    $S1 = typeof $P2
-    say $S1
 
-    $I3 = isa $P2, "Foo"
-    print $I3
-    print "\n"
-
-    $I3 = isa $P2, "Object"
-    print $I3
-    print "\n"
-.end
-CODE
-Class
-1
-Foo
-1
-1
-OUT
+.sub instantiate_from_class_object_method
+    ok(4, "Instantiate from class object 'new' method")
+    $P1 = newclass 'Foo3'
 
-pir_output_is( <<'CODE', <<'OUT', 'instantiate from class object method' );
-.sub main :main
-    $P1 = newclass "Foo"
     $P2 = $P1.'new'()
+    _test_instance($P2, 'Foo3')
+.end
 
-    $S1 = typeof $P2
-    say $S1
 
-    $I3 = isa $P2, "Foo"
-    print $I3
-    print "\n"
-
-    $I3 = isa $P2, "Object"
-    print $I3
-    print "\n"
-.end
-CODE
-Foo
-1
-1
-OUT
+.sub instantiate_from_string_name
+    ok(5, "Instantiate from string name")
+    $P1 = newclass 'Foo4'
 
-pir_output_is( <<'CODE', <<'OUT', 'instantiate from string name' );
-.sub main :main
-    $P1 = newclass "Foo"
-    $P2 = new 'Foo'
+    $P2 = new 'Foo4'
+    _test_instance($P2, 'Foo4')
+.end
 
-    $S1 = typeof $P2
-    say $S1
 
-    $I3 = isa $P2, "Foo"
-    print $I3
-    print "\n"
-
-    $I3 = isa $P2, "Object"
-    print $I3
-    print "\n"
-.end
-CODE
-Foo
-1
-1
-OUT
+.sub instantiate_from_string_register_name
+    ok(6, "Instantiate from string register name")
+    $P1 = newclass 'Foo5'
 
-pir_output_is( <<'CODE', <<'OUT', 'instantiate from string register name' );
-.sub main :main
-    $P1 = newclass "Foo"
-    $S1 = 'Foo'
+    $S1 = 'Foo5'
     $P2 = new $S1
+    _test_instance($P2, 'Foo5')
+.end
 
-    $S1 = typeof $P2
-    say $S1
 
-    $I3 = isa $P2, "Foo"
-    print $I3
-    print "\n"
-
-    $I3 = isa $P2, "Object"
-    print $I3
-    print "\n"
-.end
-CODE
-Foo
-1
-1
-OUT
+.sub instantiate_from_string_PMC_name
+    ok(7, "Instantiate from string PMC name")
+    $P1 = newclass 'Foo6'
 
-pir_output_is( <<'CODE', <<'OUT', 'instantiate from string PMC name' );
-.sub main :main
-    $P1 = newclass "Foo"
     $P3 = new 'String'
-    $P3 = 'Foo'
+    $P3 = 'Foo6'
     $P2 = new $P3
+    _test_instance($P2, 'Foo6')
+.end
 
-    $S1 = typeof $P2
-    say $S1
-
-    $I3 = isa $P2, "Foo"
-    print $I3
-    print "\n"
-
-    $I3 = isa $P2, "Object"
-    print $I3
-    print "\n"
-.end
-CODE
-Foo
-1
-1
-OUT
 
-pir_output_is( <<'CODE', <<'OUT', 'instantiate from key name' );
-.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"
-    print $I3
-    print "\n"
-
-    $P2 = new ['Foo';'Bar']
-
-    $S1 = typeof $P2
-    say $S1
-
-    $I3 = isa $P2, ['Foo';'Bar']
-    print $I3
-    print "\n"
-
-    $I3 = isa $P2, "Object"
-    print $I3
-    print "\n"
-.end
-CODE
-Class
-1
-Foo;Bar
-1
-1
-OUT
+    $P2 = new $P1
+    _test_instance($P2, 'Foo Bar1')
+.end
 
-pir_output_is(
-    <<'CODE', <<'OUT', 'instantiate from key PMC name', todo => 'create non-constant key' );
-.sub main :main
-    $P1 = newclass ['Foo';'Bar']
-    $S1 = typeof $P1
-    say $S1
 
-    $I3 = isa $P1, "Class"
-    say $I3
+.sub instantiate_from_key_PMC_name
+    ok(9, "Instantiate from Key PMC name")
+    $P1 = newclass ['Foo';'Bar2']
 
-    # How do you set the value of a non-constant key PMC?
     $P3 = new 'Key'
+    $P3 = 'Foo'
+    $P4 = new 'Key'
+    $P4 = 'Bar2'
+    push $P3, $P4
 
     $P2 = new $P3
-
-    $S1 = typeof $P2
-    say $S1
-
-    $I3 = isa $P2, 'Bar'
-    say $I3
-
-    $I3 = isa $P2, "Object"
-    say $I3
+    _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
-
-    $I3 = isa $P1, "Class"
-    print $I3
-    print "\n"
+    is($S1, 'Class', "`newclass some_string_array` creates a Class PMC")
+    isa_ok($P1, 'Class')
 
     $P2 = new $P0
+    _test_instance($P2, 'Foo Bar3')
+.end
 
-    $S1 = typeof $P2
-    say $S1
-
-    $I3 = isa $P2, ['Foo';'Bar']
-    print $I3
-    print "\n"
-
-    $I3 = isa $P2, "Object"
-    print $I3
-    print "\n"
-.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
-
-    $S1 = typeof $P2
-    say $S1
-
-    $I3 = isa $P2, "Foo"
-    print $I3
-    print "\n"
-
-    $I3 = isa $P2, "Object"
-    print $I3
-    print "\n"
+    _test_instance($P2, 'Foo7')
 
     $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
-
-    $S1 = typeof $P2
-    say $S1
-
-    $I3 = isa $P2, "Foo"
-    print $I3
-    print "\n"
-
-    $I3 = isa $P2, "Object"
-    print $I3
-    print "\n"
+    $P2 = new 'Foo8', $P3
+    _test_instance($P2, 'Foo8')
 
     $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
-
-    $S1 = typeof $P2
-    say $S1
-
-    $I3 = isa $P2, "Foo"
-    print $I3
-    print "\n"
-
-    $I3 = isa $P2, "Object"
-    print $I3
-    print "\n"
+    _test_instance($P2, 'Foo9')
 
     $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
-
-    $S1 = typeof $P2
-    say $S1
-
-    $I3 = isa $P2, "Foo"
-    print $I3
-    print "\n"
-
-    $I3 = isa $P2, "Object"
-    print $I3
-    print "\n"
+    _test_instance($P2, 'Foo10')
 
     $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
-
-    $I3 = isa $P2, ["Foo";"Bar"]
-    print $I3
-    print "\n"
-
-    $I3 = isa $P2, "Object"
-    print $I3
-    print "\n"
+    _test_instance($P2, 'Foo Bar5')
 
     $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
-
-    $S1 = typeof $P2
-    say $S1
-
-    $I3 = isa $P2, 'Bar'
-    print $I3
-    print "\n"
-
-    $I3 = isa $P2, "Object"
-    print $I3
-    print "\n"
+    $P2 = new ['Foo';'Bar6'], $P3
+    _test_instance($P2, 'Foo Bar6')
 
     $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:



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About