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:
-
[svn:parrot] r35326 - trunk/t/oo
by cotto