Ticket #146: t_oo_test.diff

File t_oo_test.diff, 42.4 KB (added by geraud, 4 years ago)

  • t/oo/mro-c3.t

     
    1 #!perl 
    2 # Copyright (C) 2007, The Perl Foundation. 
     1#!parrot 
     2# Copyright (C) 2007-2009, The Perl Foundation. 
    33# $Id$ 
    44 
    5 use strict; 
    6 use warnings; 
    7 use lib qw( . lib ../lib ../../lib ); 
    8 use Test::More; 
    9 use Parrot::Test tests => 4; 
    10  
    115=head1 NAME 
    126 
    137t/oo/mro-c3.t - test the C3 Method Resolution Order for Parrot OO 
    … …  
    2216 
    2317=cut 
    2418 
    25 pir_output_is( <<'CODE', <<'OUT', 'single parent' ); 
    26 .sub 'test' :main 
     19.sub main :main 
     20    .include 'test_more.pir' 
     21 
     22    plan(12) 
     23 
     24    single_parent() 
     25    grandparent() 
     26    multiple_inheritance() 
     27    diamond_inheritance() 
     28.end 
     29 
     30.sub method_A :method 
     31    .return('Method from A') 
     32.end 
     33 
     34.sub method_B :method 
     35    .return('Method from B') 
     36.end 
     37 
     38.sub method_C :method 
     39    .return('Method from C') 
     40.end 
     41 
     42.sub method_D :method 
     43    .return('Method from D') 
     44.end 
     45 
     46.sub single_parent 
    2747    .local pmc A, B 
    2848 
    2949    A = new 'Class' 
    30     $P0 = get_global 'testA' 
    31     A.'add_method'("foo", $P0) 
    32     A.'add_method'("bar", $P0) 
     50    $P0 = get_global 'method_A' 
     51    A.'add_method'('foo', $P0) 
     52    A.'add_method'('bar', $P0) 
    3353 
    3454    B = new 'Class' 
    3555    B.'add_parent'(A) 
    36     $P0 = get_global 'testB' 
    37     B.'add_method'("foo", $P0) 
     56    $P0 = get_global 'method_B' 
     57    B.'add_method'('foo', $P0) 
    3858 
    3959    $P0 = B.'new'() 
    40     $P0.'foo'() 
    41     $P0.'bar'() 
     60    $S0 = $P0.'foo'() 
     61    $S1 = $P0.'bar'() 
     62    is($S0, 'Method from B', 'Single Parent - Method foo overloaded in B') 
     63    is($S1, 'Method from A', 'Single Parent - Method bar inherited from A') 
    4264.end 
    4365 
    44 .sub testA :method 
    45     print "Method from A called\n" 
    46 .end 
    47 .sub testB :method 
    48     print "Method from B called\n" 
    49 .end 
    50 CODE 
    51 Method from B called 
    52 Method from A called 
    53 OUT 
    54  
    55 pir_output_is( <<'CODE', <<'OUT', 'grandparent' ); 
    56 .sub 'test' :main 
     66.sub grandparent 
    5767    .local pmc A, B, C 
    5868 
    5969    A = new 'Class' 
    60     $P0 = get_global 'testA' 
    61     A.'add_method'("foo", $P0) 
    62     A.'add_method'("bar", $P0) 
    63     A.'add_method'("baz", $P0) 
     70    $P0 = get_global 'method_A' 
     71    A.'add_method'('foo', $P0) 
     72    A.'add_method'('bar', $P0) 
     73    A.'add_method'('baz', $P0) 
    6474 
    6575    B = new 'Class' 
    6676    B.'add_parent'(A) 
    67     $P0 = get_global 'testB' 
    68     B.'add_method'("foo", $P0) 
    69     B.'add_method'("bar", $P0) 
     77    $P0 = get_global 'method_B' 
     78    B.'add_method'('foo', $P0) 
     79    B.'add_method'('bar', $P0) 
    7080 
    7181    C = new 'Class' 
    7282    C.'add_parent'(B) 
    73     $P0 = get_global 'testC' 
    74     C.'add_method'("foo", $P0) 
     83    $P0 = get_global 'method_C' 
     84    C.'add_method'('foo', $P0) 
    7585 
    7686    $P0 = C.'new'() 
    77     $P0.'foo'() 
    78     $P0.'bar'() 
    79     $P0.'baz'() 
     87    $S0 = $P0.'foo'() 
     88    $S1 = $P0.'bar'() 
     89    $S2 = $P0.'baz'() 
     90    is($S0, 'Method from C', 'Grandparent - Method foo overloaded in C') 
     91    is($S1, 'Method from B', 'Grandparent - Method bar inherited from B') 
     92    is($S2, 'Method from A', 'Grandparent - Method baz inherited from A') 
    8093.end 
    8194 
    82 .sub testA :method 
    83     print "Method from A called\n" 
    84 .end 
    85 .sub testB :method 
    86     print "Method from B called\n" 
    87 .end 
    88 .sub testC :method 
    89     print "Method from C called\n" 
    90 .end 
    91 CODE 
    92 Method from C called 
    93 Method from B called 
    94 Method from A called 
    95 OUT 
    96  
    97 pir_output_is( <<'CODE', <<'OUT', 'multiple inheritance' ); 
    98 .sub 'test' :main 
     95.sub multiple_inheritance 
    9996    .local pmc A, B, C 
    100  
    101     A = newclass 'A' 
    102     $P0 = get_global 'testA' 
    103     A.'add_method'("foo", $P0) 
    104     A.'add_method'("bar", $P0) 
    105     A.'add_method'("baz", $P0) 
    106  
    107     B = newclass 'B' 
    108     $P0 = get_global 'testB' 
    109     B.'add_method'("foo", $P0) 
    110     B.'add_method'("bar", $P0) 
    111  
    112     C = newclass 'C' 
     97  
     98    A = newclass 'MIA' 
     99    $P0 = get_global 'method_A' 
     100    A.'add_method'('foo', $P0) 
     101    A.'add_method'('bar', $P0) 
     102    A.'add_method'('baz', $P0) 
     103  
     104    B = newclass 'MIB' 
     105    $P0 = get_global 'method_B' 
     106    B.'add_method'('foo', $P0) 
     107    B.'add_method'('bar', $P0) 
     108  
     109    C = newclass 'MIC' 
    113110    C.'add_parent'(B) 
    114111    C.'add_parent'(A) 
    115     $P0 = get_global 'testC' 
    116     C.'add_method'("foo", $P0) 
    117  
     112    $P0 = get_global 'method_C' 
     113    C.'add_method'('foo', $P0) 
     114  
    118115    $P0 = C.'new'() 
    119     $P0.'foo'() 
    120     $P0.'bar'() 
    121     $P0.'baz'() 
     116    $S0 = $P0.'foo'() 
     117    $S1 = $P0.'bar'() 
     118    $S2 = $P0.'baz'() 
     119    is($S0, 'Method from C', 'Multiple Inheritance - Method foo overloaded in C') 
     120    is($S1, 'Method from B', 'Multiple Inheritance - Method bar inherited from B') 
     121    is($S2, 'Method from A', 'Multiple Inheritance - Method baz inherited from A') 
    122122.end 
    123123 
    124 .sub testA :method 
    125     print "Method from A called\n" 
    126 .end 
    127 .sub testB :method 
    128     print "Method from B called\n" 
    129 .end 
    130 .sub testC :method 
    131     print "Method from C called\n" 
    132 .end 
    133 CODE 
    134 Method from C called 
    135 Method from B called 
    136 Method from A called 
    137 OUT 
    138  
    139 pir_output_is( <<'CODE', <<'OUT', 'diamond inheritance' ); 
    140 .sub 'test' :main 
     124.sub diamond_inheritance 
    141125    .local pmc A, B, C, D 
    142126 
    143     A = newclass 'A' 
    144     $P0 = get_global 'testA' 
    145     A.'add_method'("foo", $P0) 
    146     A.'add_method'("bar", $P0) 
    147     A.'add_method'("baz", $P0) 
    148     A.'add_method'("wag", $P0) 
     127    A = newclass 'DIA' 
     128    $P0 = get_global 'method_A' 
     129    A.'add_method'('foo', $P0) 
     130    A.'add_method'('bar', $P0) 
     131    A.'add_method'('baz', $P0) 
     132    A.'add_method'('wag', $P0) 
    149133 
    150     B = newclass 'B' 
     134    B = newclass 'DIB' 
    151135    B.'add_parent'(A) 
    152     $P0 = get_global 'testB' 
    153     B.'add_method'("foo", $P0) 
    154     B.'add_method'("bar", $P0) 
    155     B.'add_method'("baz", $P0) 
     136    $P0 = get_global 'method_B' 
     137    B.'add_method'('foo', $P0) 
     138    B.'add_method'('bar', $P0) 
     139    B.'add_method'('baz', $P0) 
    156140 
    157     C = newclass 'C' 
     141    C = newclass 'DIC' 
    158142    C.'add_parent'(A) 
    159     $P0 = get_global 'testC' 
    160     C.'add_method'("foo", $P0) 
    161     C.'add_method'("bar", $P0) 
     143    $P0 = get_global 'method_C' 
     144    C.'add_method'('foo', $P0) 
     145    C.'add_method'('bar', $P0) 
    162146 
    163     D = newclass 'D' 
     147    D = newclass 'DID' 
    164148    D.'add_parent'(C) 
    165149    D.'add_parent'(B) 
    166     $P0 = get_global 'testD' 
    167     D.'add_method'("foo", $P0) 
     150    $P0 = get_global 'method_D' 
     151    D.'add_method'('foo', $P0) 
    168152 
    169153    $P0 = D.'new'() 
    170     $P0.'foo'() 
    171     $P0.'bar'() 
    172     $P0.'baz'() 
    173     $P0.'wag'() 
     154    $S0 = $P0.'foo'() 
     155    $S1 = $P0.'bar'() 
     156    $S2 = $P0.'baz'() 
     157    $S3 = $P0.'wag'() 
     158    is($S0, 'Method from D', 'Diamond Inheritance - Method foo overloaded in D') 
     159    is($S1, 'Method from C', 'Diamond Inheritance - Method bar inherited from C') 
     160    is($S2, 'Method from B', 'Diamond Inheritance - Method baz inherited from B') 
     161    is($S3, 'Method from A', 'Diamond Inheritance - Method wag inherited from A') 
    174162.end 
    175163 
    176 .sub testA :method 
    177     print "Method from A called\n" 
    178 .end 
    179 .sub testB :method 
    180     print "Method from B called\n" 
    181 .end 
    182 .sub testC :method 
    183     print "Method from C called\n" 
    184 .end 
    185 .sub testD :method 
    186     print "Method from D called\n" 
    187 .end 
    188 CODE 
    189 Method from D called 
    190 Method from C called 
    191 Method from B called 
    192 Method from A called 
    193 OUT 
    194  
    195164# Local Variables: 
    196 #   mode: cperl 
    197 #   cperl-indent-level: 4 
     165#   mode: pir 
    198166#   fill-column: 100 
    199167# End: 
    200 # vim: expandtab shiftwidth=4: 
     168# vim: expandtab shiftwidth=4 ft=pir: 

  • t/oo/composition.t

     
    1 #!perl 
    2 # Copyright (C) 2007, The Perl Foundation. 
     1#!parrot 
     2# Copyright (C) 2007-2009, The Perl Foundation. 
    33# $Id$ 
    44 
    5 use strict; 
    6 use warnings; 
    7 use lib qw( . lib ../lib ../../lib ); 
    8 use Test::More; 
    9 use Parrot::Test tests => 10; 
    10  
    115=head1 NAME 
    126 
    137t/oo/compositon.t - test role composition 
    … …  
    2216 
    2317=cut 
    2418 
    25 pir_output_is( <<'CODE', <<'OUT', 'role with no methods' ); 
    26 .sub 'test' :main 
     19.sub main :main 
     20    .include 'except_types.pasm' 
     21    .include 'test_more.pir' 
     22    plan(41) 
     23 
     24    role_with_no_methods() 
     25    role_with_one_method_no_methods_in_class() 
     26    two_roles_and_a_class_a_method_each_no_conflict() 
     27    two_roles_that_conflict() 
     28    role_that_conflicts_with_a_class_method() 
     29    conflict_resolution_by_exclusion() 
     30    conflict_resolution_by_aliasing_and_exclude() 
     31    conflict_resolution_by_resolve() 
     32    role_that_does_a_role() 
     33    conflict_from_indirect_role() 
     34.end 
     35 
     36.sub badger :method 
     37    .return('Badger!') 
     38.end 
     39.sub badger2 :method 
     40    .return('Second Badger!') 
     41.end 
     42.sub mushroom :method 
     43    .return('Mushroom!') 
     44.end 
     45.sub snake :method 
     46    .return('Snake!') 
     47.end 
     48.sub fire 
     49    .return("You're FIRED!") 
     50.end 
     51.sub fire2 
     52    .return('BURNINATION!') 
     53.end 
     54.sub give_payrise 
     55    .return('You all get a pay rise of 0.0005%.') 
     56.end 
     57 
     58.sub role_with_no_methods 
    2759    $P0 = new 'Role' 
    2860    $P1 = new 'Class' 
    2961 
    3062    $P1.'add_role'($P0) 
    31     print "ok 1 - added role\n" 
     63    ok(1, 'added role') 
    3264 
    3365    $P2 = $P1.'roles'() 
    3466    $I0 = elements $P2 
    35     if $I0 == 1 goto OK_2 
    36     print "not " 
    37 OK_2: 
    38     print "ok 2 - roles list has the role\n" 
     67    is($I0, 1, 'roles list has the role') 
    3968 
    4069    $P2 = $P1.'new'() 
    41     print "ok 3 - instantiated class with composed role\n" 
     70    ok(1, 'instantiated class with composed role') 
    4271.end 
    43 CODE 
    44 ok 1 - added role 
    45 ok 2 - roles list has the role 
    46 ok 3 - instantiated class with composed role 
    47 OUT 
    4872 
    49 pir_output_is( <<'CODE', <<'OUT', 'role with one method, no methods in class' ); 
    50 .sub 'test' :main 
     73.sub role_with_one_method_no_methods_in_class 
    5174    $P0 = new 'Role' 
    5275    $P1 = new 'Class' 
    5376 
    5477    $P2 = get_global "badger" 
    5578    $P0.'add_method'("badger", $P2) 
    56     print "ok 1 - added method to a role\n" 
     79    ok(1, 'added method to a role') 
    5780 
    5881    $P1.'add_role'($P0) 
    59     print "ok 2 - composed role into the class\n" 
     82    ok(1, 'composed role into the class') 
    6083 
    6184    $P2 = $P1.'roles'() 
    6285    $I0 = elements $P2 
    63     if $I0 == 1 goto OK_3 
    64     print "not " 
    65 OK_3: 
    66     print "ok 3 - roles list has the role\n" 
     86    is($I0, 1, 'roles list has the role') 
    6787 
    6888    $P2 = $P1.'new'() 
    69     print "ok 4 - instantiated class with composed role\n" 
     89    ok(1, 'instantiated class with composed role') 
    7090 
    71     $P2.'badger'() 
    72     print "ok 5 - called method composed from role\n" 
     91    $S0 = $P2.'badger'() 
     92    is($S0, 'Badger!', 'called method composed from role') 
    7393.end 
    7494 
    75 .sub badger :method 
    76     print "Badger!\n" 
    77 .end 
    78 CODE 
    79 ok 1 - added method to a role 
    80 ok 2 - composed role into the class 
    81 ok 3 - roles list has the role 
    82 ok 4 - instantiated class with composed role 
    83 Badger! 
    84 ok 5 - called method composed from role 
    85 OUT 
    86  
    87 pir_output_is( <<'CODE', <<'OUT', 'two roles and a class, a method each, no conflict' ); 
    88 .sub 'test' :main 
     95.sub two_roles_and_a_class_a_method_each_no_conflict 
    8996    $P0 = new 'Role' 
    9097    $P1 = new 'Role' 
    9198    $P2 = new 'Class' 
    9299 
    93100    $P3 = get_global "snake" 
    94101    $P2.'add_method'("snake", $P3) 
    95     print "ok 1 - class has a method\n" 
     102    ok(1, 'class has a method') 
    96103 
    97104    $P3 = get_global "badger" 
    98105    $P0.'add_method'("badger", $P3) 
    99106    $P2.'add_role'($P0) 
    100     print "ok 2 - composed first role into the class\n" 
     107    ok(1, 'composed first role into the class') 
    101108 
    102109    $P3 = get_global "mushroom" 
    103110    $P1.'add_method'("mushroom", $P3) 
    104111    $P2.'add_role'($P1) 
    105     print "ok 3 - composed second role into the class\n" 
     112    ok(1, 'composed second role into the class') 
    106113 
    107114    $P3 = $P2.'new'() 
    108     print "ok 4 - instantiated class\n" 
     115    ok(1, 'instantiated class') 
    109116 
    110     $P3.'badger'() 
    111     print "ok 5 - called method from first role\n" 
     117    $S0 = $P3.'badger'() 
     118    is($S0, 'Badger!', 'called method from first role') 
    112119 
    113     $P3.'mushroom'() 
    114     print "ok 6 - called method from second role\n" 
     120    $S1 = $P3.'mushroom'() 
     121    is($S1, 'Mushroom!', 'called method from second role') 
    115122 
    116     $P3.'snake'() 
    117     print "ok 7 - called method from class\n" 
     123    $S2 = $P3.'snake'() 
     124    is($S2, 'Snake!', 'called method from class') 
    118125.end 
    119126 
    120 .sub badger :method 
    121     print "Badger!\n" 
    122 .end 
    123 .sub mushroom :method 
    124     print "Mushroom!\n" 
    125 .end 
    126 .sub snake :method 
    127     print "Snake!\n" 
    128 .end 
    129 CODE 
    130 ok 1 - class has a method 
    131 ok 2 - composed first role into the class 
    132 ok 3 - composed second role into the class 
    133 ok 4 - instantiated class 
    134 Badger! 
    135 ok 5 - called method from first role 
    136 Mushroom! 
    137 ok 6 - called method from second role 
    138 Snake! 
    139 ok 7 - called method from class 
    140 OUT 
    141  
    142 pir_output_is( <<'CODE', <<'OUT', 'two roles that conflict' ); 
    143 .sub 'test' :main 
     127.sub two_roles_that_conflict 
     128    .local pmc eh 
    144129    $P0 = new 'Role' 
    145130    $P1 = new 'Role' 
    146131    $P2 = new 'Class' 
    … …  
    148133    $P3 = get_global "badger" 
    149134    $P0.'add_method'("badger", $P3) 
    150135    $P2.'add_role'($P0) 
    151     print "ok 1 - composed first role into the class\n" 
     136    ok(1, 'composed first role into the class') 
    152137 
    153138    $P3 = get_global "badger2" 
    154139    $P1.'add_method'("badger", $P3) 
    155     push_eh OK_2 
     140 
     141  try: 
     142    eh = new 'ExceptionHandler' 
     143    eh.'handle_types'(.EXCEPTION_ROLE_COMPOSITION_METH_CONFLICT) 
     144    set_addr eh, catch 
     145 
     146    push_eh eh 
    156147    $P2.'add_role'($P1) 
    157     print "not " 
     148    $I0 = 1 
     149    goto finally 
     150 
     151  catch: 
     152    $I0 = 0 
     153 
     154  finally: 
    158155    pop_eh 
    159 OK_2: 
    160     print "ok 2 - composition failed due to conflict\n" 
     156    nok($I0, 'composition failed due to conflict') 
    161157.end 
    162158 
    163 .sub badger :method 
    164     print "Badger!\n" 
    165 .end 
    166 .sub badger2 :method 
    167     print "Badger!\n" 
    168 .end 
    169 CODE 
    170 ok 1 - composed first role into the class 
    171 ok 2 - composition failed due to conflict 
    172 OUT 
    173  
    174 pir_output_is( <<'CODE', <<'OUT', 'role that conflicts with a class method' ); 
    175 .sub 'test' :main 
     159.sub role_that_conflicts_with_a_class_method 
     160    .local pmc eh 
    176161    $P0 = new 'Role' 
    177162    $P1 = new 'Class' 
    178163 
    179164    $P2 = get_global "badger" 
    180165    $P1.'add_method'("badger", $P2) 
    181     print "ok 1 - class has a method\n" 
     166    ok(1, 'class has a method') 
    182167 
    183168    $P2 = get_global "badger2" 
    184169    $P0.'add_method'("badger", $P2) 
    185     push_eh OK_2 
     170 
     171  try: 
     172    eh = new 'ExceptionHandler' 
     173    eh.'handle_types'(.EXCEPTION_ROLE_COMPOSITION_METH_CONFLICT) 
     174    set_addr eh, catch 
     175     
     176    push_eh eh 
    186177    $P1.'add_role'($P0) 
    187     print "not " 
     178    $I0 = 1 
     179    goto finally 
     180 
     181  catch: 
     182    $I0 = 0 
     183 
     184  finally: 
    188185    pop_eh 
    189 OK_2: 
    190     print "ok 2 - composition failed due to conflict\n" 
     186    nok($I0, 'composition failed due to conflict') 
    191187.end 
    192188 
    193 .sub badger :method 
    194     print "Badger!\n" 
    195 .end 
    196 .sub badger2 :method 
    197     print "Badger!\n" 
    198 .end 
    199 CODE 
    200 ok 1 - class has a method 
    201 ok 2 - composition failed due to conflict 
    202 OUT 
    203  
    204 pir_output_is( <<'CODE', <<'OUT', 'conflict resolution by exclusion' ); 
    205 .sub 'test' :main 
     189.sub conflict_resolution_by_exclusion 
    206190    $P0 = new 'Role' 
    207191    $P1 = new 'Class' 
    208192 
    209193    $P2 = get_global "badger" 
    210194    $P1.'add_method'("badger", $P2) 
    211     print "ok 1 - class has a method\n" 
     195    ok(1, 'class has a method') 
    212196 
    213197    $P2 = get_global "badger2" 
    214198    $P0.'add_method'("badger", $P2) 
    … …  
    217201    $P3 = new 'ResizableStringArray' 
    218202    push $P3, "badger" 
    219203    $P1.'add_role'($P0, 'exclude_method' => $P3) 
    220     print "ok 2 - composition worked due to exclusion\n" 
     204    ok(1, 'composition worked due to exclusion') 
    221205 
    222206    $P2 = $P1.'new'() 
    223     $P2.'badger'() 
    224     print "ok 3 - called method from class\n" 
     207    $S0 = $P2.'badger'() 
     208    is($S0, 'Badger!', 'called method from class') 
    225209 
    226     $P2.'snake'() 
    227     print "ok 4 - called method from role that wasn't excluded\n" 
     210    $S1 = $P2.'snake'() 
     211    is($S1, 'Snake!', "called method from role that wasn't excluded") 
    228212.end 
    229213 
    230 .sub badger :method 
    231     print "Badger!\n" 
    232 .end 
    233 .sub badger2 :method 
    234     print "Oops, wrong badger.\n" 
    235 .end 
    236 .sub snake :method 
    237     print "Snake!\n" 
    238 .end 
    239 CODE 
    240 ok 1 - class has a method 
    241 ok 2 - composition worked due to exclusion 
    242 Badger! 
    243 ok 3 - called method from class 
    244 Snake! 
    245 ok 4 - called method from role that wasn't excluded 
    246 OUT 
    247  
    248 pir_output_is( <<'CODE', <<'OUT', 'conflict resolution by aliasing and exclude' ); 
    249 .sub 'test' :main 
     214.sub conflict_resolution_by_aliasing_and_exclude 
    250215    $P0 = new 'Role' 
    251216    $P1 = new 'Class' 
    252217 
    253     $P2 = get_global "badger" 
    254     $P1.'add_method'("badger", $P2) 
    255     print "ok 1 - class has a method\n" 
     218    $P2 = get_global 'badger' 
     219    $P1.'add_method'('badger', $P2) 
     220    ok(1, 'class has a method') 
    256221 
    257     $P2 = get_global "badger2" 
    258     $P0.'add_method'("badger", $P2) 
    259     $P2 = get_global "snake" 
    260     $P0.'add_method'("snake", $P2) 
     222    $P2 = get_global 'badger2' 
     223    $P0.'add_method'('badger', $P2) 
     224    $P2 = get_global 'snake' 
     225    $P0.'add_method'('snake', $P2) 
    261226    $P3 = new 'Hash' 
    262     $P3["badger"] = "role_badger" 
     227    $P3['badger'] = 'role_badger' 
    263228    $P4 = new 'ResizableStringArray' 
    264     $P4[0] = "badger" 
     229    $P4[0] = 'badger' 
    265230    $P1.'add_role'($P0, 'alias_method' => $P3, 'exclude_method' => $P4) 
    266     print "ok 2 - composition worked due to aliasing and exclude\n" 
     231    ok(1, 'composition worked due to aliasing and exclude') 
    267232 
    268233    $P2 = $P1.'new'() 
    269     $P2.'badger'() 
    270     print "ok 3 - called method from class\n" 
     234    $S0 = $P2.'badger'() 
     235    is($S0, 'Badger!', 'called method from class') 
    271236 
    272     $P2.'snake'() 
    273     print "ok 4 - called method from role that wasn't aliased\n" 
     237    $S1 = $P2.'snake'() 
     238    is($S1, 'Snake!', "called method from role that wasn't aliased") 
    274239 
    275     $P2.'role_badger'() 
    276     print "ok 5 - called method from role that was aliased\n" 
     240    $S2 = $P2.'role_badger'() 
     241    is($S2, 'Second Badger!', 'called method from role that was aliased') 
    277242.end 
    278243 
    279 .sub badger :method 
    280     print "Badger!\n" 
    281 .end 
    282 .sub badger2 :method 
    283     print "Aliased badger!\n" 
    284 .end 
    285 .sub snake :method 
    286     print "Snake!\n" 
    287 .end 
    288 CODE 
    289 ok 1 - class has a method 
    290 ok 2 - composition worked due to aliasing and exclude 
    291 Badger! 
    292 ok 3 - called method from class 
    293 Snake! 
    294 ok 4 - called method from role that wasn't aliased 
    295 Aliased badger! 
    296 ok 5 - called method from role that was aliased 
    297 OUT 
    298  
    299 pir_output_is( <<'CODE', <<'OUT', 'conflict resolution by resolve' ); 
    300 .sub 'test' :main 
     244.sub conflict_resolution_by_resolve 
    301245    $P0 = new 'Role' 
    302246    $P1 = new 'Class' 
    303247 
    304248    $P3 = new 'ResizableStringArray' 
    305     push $P3, "badger" 
     249    push $P3, 'badger' 
    306250    $P1.'resolve_method'($P3) 
    307     print "ok 1 - set resolve list\n" 
     251    ok(1, 'set resolve list') 
    308252 
    309253    $P4 = $P1.'resolve_method'() 
    310254    $S0 = $P4[0] 
    311     if $S0 == "badger" goto ok_2 
    312     print "not " 
    313 ok_2: 
    314     print "ok 2 - got resolve list and it matched\n" 
     255    is($S0, 'badger', 'got resolve list and it matched') 
    315256 
    316     $P2 = get_global "badger" 
    317     $P1.'add_method'("badger", $P2) 
    318     print "ok 3 - class has a method\n" 
     257    $P2 = get_global 'badger' 
     258    $P1.'add_method'('badger', $P2) 
     259    ok(1, 'class has a method') 
    319260 
    320     $P2 = get_global "badger2" 
    321     $P0.'add_method'("badger", $P2) 
    322     $P2 = get_global "snake" 
    323     $P0.'add_method'("snake", $P2) 
     261    $P2 = get_global 'badger2' 
     262    $P0.'add_method'('badger', $P2) 
     263    $P2 = get_global 'snake' 
     264    $P0.'add_method'('snake', $P2) 
    324265    $P1.'add_role'($P0) 
    325     print "ok 4 - composition worked due to resolve\n" 
     266    ok(1, 'composition worked due to resolve') 
    326267 
    327268    $P2 = $P1.'new'() 
    328     $P2.'badger'() 
    329     print "ok 5 - called method from class\n" 
     269    $S1 = $P2.'badger'() 
     270    is($S1, 'Badger!', 'called method from class') 
    330271 
    331     $P2.'snake'() 
    332     print "ok 6 - called method from role that wasn't resolved\n" 
     272    $S2 = $P2.'snake'() 
     273    is($S2, 'Snake!', "called method from role that wasn't resolved") 
    333274.end 
    334275 
    335 .sub badger :method 
    336     print "Badger!\n" 
    337 .end 
    338 .sub badger2 :method 
    339     print "Oops, wrong badger.\n" 
    340 .end 
    341 .sub snake :method 
    342     print "Snake!\n" 
    343 .end 
    344 CODE 
    345 ok 1 - set resolve list 
    346 ok 2 - got resolve list and it matched 
    347 ok 3 - class has a method 
    348 ok 4 - composition worked due to resolve 
    349 Badger! 
    350 ok 5 - called method from class 
    351 Snake! 
    352 ok 6 - called method from role that wasn't resolved 
    353 OUT 
    354  
    355 pir_output_is( <<'CODE', <<'OUT', 'role that does a role' ); 
    356 .sub 'test' :main 
     276.sub role_that_does_a_role 
    357277    .local pmc PHB, Manage, FirePeople 
    358278 
    359279    FirePeople = new 'Role' 
    … …  
    364284    $P0 = get_global 'give_payrise' 
    365285    FirePeople.'add_method'("give_payrise", $P0) 
    366286    Manage.'add_role'(FirePeople) 
    367     print "ok 1 - adding one role to another happens\n" 
     287    ok(1, 'adding one role to another happens') 
    368288 
    369289    PHB = new 'Class' 
    370290    PHB.'add_role'(Manage) 
    371     print "ok 2 - added one rule that does another role to the class\n" 
     291    ok(1, 'added one rule that does another role to the class') 
    372292 
    373293    $P0 = PHB.'new'() 
    374     $P0.'give_payrise'() 
    375     print "ok 3 - called method from direct role\n" 
     294    $S0 = $P0.'give_payrise'() 
     295    is($S0, 'You all get a pay rise of 0.0005%.', 'called method from direct role') 
    376296 
    377     $P0.'fire'() 
    378     print "ok 4 - called method from indirect role\n" 
     297    $S1 = $P0.'fire'() 
     298    is($S1, "You're FIRED!", 'called method from indirect role') 
    379299.end 
    380300 
    381 .sub fire 
    382     print "You're FIRED!\n" 
    383 .end 
    384 .sub give_payrise 
    385     print "You all get a pay rise of 0.0005%.\n" 
    386 .end 
    387 CODE 
    388 ok 1 - adding one role to another happens 
    389 ok 2 - added one rule that does another role to the class 
    390 You all get a pay rise of 0.0005%. 
    391 ok 3 - called method from direct role 
    392 You're FIRED! 
    393 ok 4 - called method from indirect role 
    394 OUT 
     301.sub conflict_from_indirect_role 
     302    .local pmc eh, BurninatorBoss, Manage, FirePeople, Burninator 
    395303 
    396 pir_output_is( <<'CODE', <<'OUT', 'conflict from indirect role' ); 
    397 .sub 'test' :main 
    398     .local pmc BurninatorBoss, Manage, FirePeople, Burninator 
    399  
    400304    FirePeople = new 'Role' 
    401305    $P0 = get_global 'fire' 
    402     FirePeople.'add_method'("fire", $P0) 
     306    FirePeople.'add_method'('fire', $P0) 
    403307 
    404308    Manage = new 'Role' 
    405309    $P0 = get_global 'give_payrise' 
    406     FirePeople.'add_method'("give_payrise", $P0) 
     310    FirePeople.'add_method'('give_payrise', $P0) 
    407311    Manage.'add_role'(FirePeople) 
    408312 
    409313    Burninator = new 'Role' 
    410314    $P0 = get_global 'fire2' 
    411     Burninator.'add_method'("fire", $P0) 
    412     print "ok 1 - all roles created\n" 
     315    Burninator.'add_method'('fire', $P0) 
     316    ok(1, 'all roles created') 
    413317 
    414318    BurninatorBoss = new 'Class' 
    415319    BurninatorBoss.'add_role'(Manage) 
    416     print "ok 2 - added first role with indirect role\n" 
     320    ok(1, 'added first role with indirect role') 
    417321 
    418     push_eh OK_3 
     322  try: 
     323    eh = new 'ExceptionHandler' 
     324    eh.'handle_types'(.EXCEPTION_ROLE_COMPOSITION_METH_CONFLICT) 
     325    set_addr eh, catch 
     326 
     327    push_eh eh 
    419328    BurninatorBoss.'add_role'(Burninator) 
    420     print "not " 
     329    $I0 = 1 
     330    goto finally 
     331 
     332  catch: 
     333    $I0 = 0 
     334 
     335  finally: 
    421336    pop_eh 
    422 OK_3: 
    423     print "ok 3 - second role conflicts with method from indirect role\n" 
     337    nok($I0, 'second role conflicts with method from indirect role') 
    424338.end 
    425339 
    426 .sub fire 
    427     print "You're FIRED!\n" 
    428 .end 
    429 .sub fire2 
    430     print "BURNINATION!\n" 
    431 .end 
    432 .sub give_payrise 
    433     print "You all get a pay rise of 0.0005%.\n" 
    434 .end 
    435 CODE 
    436 ok 1 - all roles created 
    437 ok 2 - added first role with indirect role 
    438 ok 3 - second role conflicts with method from indirect role 
    439 OUT 
    440  
    441340# Local Variables: 
    442 #   mode: cperl 
    443 #   cperl-indent-level: 4 
     341#   mode: pir 
    444342#   fill-column: 100 
    445343# End: 
    446 # vim: expandtab shiftwidth=4: 
     344# vim: expandtab shiftwidth=4 ft=pir: 

  • t/oo/new.t

     
    1 #!perl 
    2 # Copyright (C) 2007-2008, The Perl Foundation. 
     1#!parrot 
     2# Copyright (C) 2007-2009, The Perl Foundation. 
    33# $Id$ 
    44 
    5 use strict; 
    6 use warnings; 
    7 use lib qw( . lib ../lib ../../lib ); 
    8 use Test::More; 
    9 use Parrot::Test tests => 23; 
    10  
    115=head1 NAME 
    126 
    137t/oo/new.t - Test OO instantiation 
    … …  
    2216 
    2317=cut 
    2418 
    25 pir_output_is( <<'CODE', <<'OUT', 'instantiate from class object' ); 
    2619.sub main :main 
    27     $P1 = newclass "Foo" 
    28     $S1 = typeof $P1 
    29     say $S1 
     20    .include 'except_types.pasm' 
     21    .include 'test_more.pir' 
     22    plan(111) 
    3023 
    31     $I3 = isa $P1, "Class" 
    32     print $I3 
    33     print "\n" 
     24    instantiate_from_class_object() 
     25    manually_create_anonymous_class_object() 
     26    manually_create_named_class_object() 
     27    instantiate_from_class_object_method() 
     28    instantiate_from_string_name() 
     29    instantiate_from_string_register_name() 
     30    instantiate_from_string_PMC_name() 
     31    instantiate_from_key_name() 
     32    instantiate_from_key_PMC_name() 
     33    create_and_instantiate_from_array_of_names() 
     34    only_string_arrays_work_for_creating_classes() 
     35    instantiate_from_class_object_with_init() 
     36    instantiate_from_string_name_with_init() 
     37    instantiate_from_string_register_name_with_init() 
     38    instantiate_from_string_PMC_name_with_init() 
     39    instantiate_from_array_of_names_with_init() 
     40    instantiate_from_key_name_with_init() 
     41    create_class_namespace_initializer() 
     42    regression_test_instantiate_class_within_different_namespace() 
     43    get_class_retrieves_a_high_level_class_object() 
     44    get_class_retrieves_a_proxy_class_object() 
     45    get_class_retrieves_a_class_object_that_doesnt_exist() 
     46    instantiate_class_from_invalid_key() 
     47.end 
    3448 
    35     $P2 = new $P1 
    3649 
    37     $S1 = typeof $P2 
    38     say $S1 
     50# 
     51# Utility sub 
     52# 
     53.sub _test_instance 
     54    .param pmc obj 
     55    .param string in_str  
    3956 
    40     $I3 = isa $P2, "Foo" 
    41     print $I3 
    42     print "\n" 
     57    # Set up local variables 
     58    .local pmc key_pmc 
     59    .local string class_name 
    4360 
    44     $I3 = isa $P2, "Object" 
    45     print $I3 
    46     print "\n" 
    47 .end 
    48 CODE 
    49 Class 
    50 1 
    51 Foo 
    52 1 
    53 1 
    54 OUT 
     61    key_pmc = new 'Key' 
     62    $P0 = split ' ', in_str 
     63    $S0 = shift $P0 
     64    $I1 = 1 
     65    key_pmc    = $S0 
     66    class_name = $S0 
    5567 
    56 pir_output_is( <<'CODE', <<'OUT', 'manually create anonymous class object' ); 
    57 .sub main :main 
    58     $P1 = new "Class" 
    59     $S1 = typeof $P1 
    60     say $S1 
     68  LOOP: 
     69    $I0 = elements $P0 
     70    if $I0 == 0 goto BEGIN_TEST 
     71    $S1 = shift $P0 
     72    $P1 = new 'Key' 
     73    $P1 = $S1 
     74    push key_pmc, $P1 
     75    concat class_name, ';' 
     76    concat class_name, $S1 
     77    $I1 += 1 
     78    goto LOOP 
    6179 
    62     $I3 = isa $P1, "Class" 
    63     print $I3 
    64     print "\n" 
     80    # Start testing 
     81  BEGIN_TEST: 
     82    .local string typeof_message 
     83    typeof_message = concat 'New instance is of type: ', class_name 
     84    $S1 = typeof obj 
     85    is($S1, class_name, typeof_message) 
    6586 
    66     $P2 = new $P1 
     87    isa_ok(obj, 'Object') 
    6788 
    68     $S1 = typeof $P2 
    69     print "'" 
    70     print $S1 
    71     print "'\n" 
     89    .local string keypmc_message 
     90    $S2 = get_repr key_pmc 
     91    keypmc_message = concat 'The object isa ', $S2 
     92    $I2 = isa obj, key_pmc 
     93    ok($I2, keypmc_message) 
    7294 
    73     $I3 = isa $P2, "Foo" 
    74     print $I3 
    75     print "\n" 
     95    unless $I1 == 1 goto END_TEST 
     96    isa_ok(obj, class_name) 
    7697 
    77     $I3 = isa $P2, "Object" 
    78     print $I3 
    79     print "\n" 
     98  END_TEST: 
     99    .return() 
    80100.end 
    81 CODE 
    82 Class 
    83 1 
    84 '' 
    85 0 
    86 1 
    87 OUT 
    88101 
    89 pir_output_is( <<'CODE', <<'OUT', 'manually create named class object' ); 
    90 .sub main :main 
    91     $P1 = new "Class" 
    92     $P1.'name'("Foo") 
    93     $S1 = typeof $P1 
    94     say $S1 
    95102 
    96     $I3 = isa $P1, "Class" 
    97     print $I3 
    98     print "\n" 
     103############################################################################# 
    99104 
    100     $P2 = new $P1 
    101105 
    102     $S1 = typeof $P2 
    103     say $S1 
     106.sub instantiate_from_class_object 
     107    ok(1, "Instantiate from class object") 
     108    $P1 = newclass 'Foo1' 
     109    $S1 = typeof $P1 
     110    is($S1, 'Class', '`newclass "Foo"` creates a Class PMC') 
     111    isa_ok($P1, 'Class') 
    104112 
    105     $I3 = isa $P2, "Foo" 
    106     print $I3 
    107     print "\n" 
    108  
    109     $I3 = isa $P2, "Object" 
    110     print $I3 
    111     print "\n" 
     113    $P2 = new $P1 
     114    _test_instance($P2, 'Foo1') 
    112115.end 
    113 CODE 
    114 Class 
    115 1 
    116 Foo 
    117 1 
    118 1 
    119 OUT 
    120116 
    121 pir_output_is( <<'CODE', <<'OUT', 'instantiate from class object method' ); 
    122 .sub main :main 
    123     $P1 = newclass "Foo" 
    124     $P2 = $P1.'new'() 
    125117 
     118.sub manually_create_anonymous_class_object 
     119    ok(2, "Manually create anonymous class object") 
     120    $P1 = new 'Class' 
     121    $S1 = typeof $P1 
     122    is($S1, 'Class', 'New anonymous class creates a Class PMC') 
     123    isa_ok($P1, 'Class') 
     124 
     125    $P2 = new $P1 
    126126    $S1 = typeof $P2 
    127     say $S1 
     127    is($S1, '', 'New instance is of type ""') 
     128    isa_ok($P2, 'Object') 
    128129 
    129     $I3 = isa $P2, "Foo" 
    130     print $I3 
    131     print "\n" 
    132  
    133     $I3 = isa $P2, "Object" 
    134     print $I3 
    135     print "\n" 
     130    $I3 = isa $P2, '' 
     131    is($I3, 0, '"isa" will not match an empty type') 
     132    $I3 = isa $P2, 'Foo' 
     133    is($I3, 0, '"isa" will not match a random type') 
    136134.end 
    137 CODE 
    138 Foo 
    139 1 
    140 1 
    141 OUT 
    142135 
    143 pir_output_is( <<'CODE', <<'OUT', 'instantiate from string name' ); 
    144 .sub main :main 
    145     $P1 = newclass "Foo" 
    146     $P2 = new 'Foo' 
    147136 
    148     $S1 = typeof $P2 
    149     say $S1 
     137.sub manually_create_named_class_object 
     138    ok(3, "Manually create named class object") 
     139    $P1 = new 'Class' 
     140    $P1.'name'('Foo2') 
     141    $S1 = typeof $P1 
     142    is($S1, 'Class', 'new named class creates a "Class" PMC') 
     143    isa_ok($P1, 'Class') 
    150144 
    151     $I3 = isa $P2, "Foo" 
    152     print $I3 
    153     print "\n" 
    154  
    155     $I3 = isa $P2, "Object" 
    156     print $I3 
    157     print "\n" 
     145    $P2 = new $P1 
     146    _test_instance($P2, 'Foo2') 
    158147.end 
    159 CODE 
    160 Foo 
    161 1 
    162 1 
    163 OUT 
    164148 
    165 pir_output_is( <<'CODE', <<'OUT', 'instantiate from string register name' ); 
    166 .sub main :main 
    167     $P1 = newclass "Foo" 
    168     $S1 = 'Foo' 
    169     $P2 = new $S1 
    170149 
    171     $S1 = typeof $P2 
    172     say $S1 
     150.sub instantiate_from_class_object_method 
     151    ok(4, "Instantiate from class object 'new' method") 
     152    $P1 = newclass 'Foo3' 
    173153 
    174     $I3 = isa $P2, "Foo" 
    175     print $I3 
    176     print "\n" 
    177  
    178     $I3 = isa $P2, "Object" 
    179     print $I3 
    180     print "\n" 
     154    $P2 = $P1.'new'() 
     155    _test_instance($P2, 'Foo3') 
    181156.end 
    182 CODE 
    183 Foo 
    184 1 
    185 1 
    186 OUT 
    187157 
    188 pir_output_is( <<'CODE', <<'OUT', 'instantiate from string PMC name' ); 
    189 .sub main :main 
    190     $P1 = newclass "Foo" 
    191     $P3 = new 'String' 
    192     $P3 = 'Foo' 
    193     $P2 = new $P3 
    194158 
    195     $S1 = typeof $P2 
    196     say $S1 
     159.sub instantiate_from_string_name 
     160    ok(5, "Instantiate from string name") 
     161    $P1 = newclass 'Foo4' 
    197162 
    198     $I3 = isa $P2, "Foo" 
    199     print $I3 
    200     print "\n" 
    201  
    202     $I3 = isa $P2, "Object" 
    203     print $I3 
    204     print "\n" 
     163    $P2 = new 'Foo4' 
     164    _test_instance($P2, 'Foo4') 
    205165.end 
    206 CODE 
    207 Foo 
    208 1 
    209 1 
    210 OUT 
    211166 
    212 pir_output_is( <<'CODE', <<'OUT', 'instantiate from key name' ); 
    213 .sub main :main 
    214     $P1 = newclass ['Foo';'Bar'] 
    215     $S1 = typeof $P1 
    216     say $S1 
    217167 
    218     $I3 = isa $P1, "Class" 
    219     print $I3 
    220     print "\n" 
     168.sub instantiate_from_string_register_name 
     169    ok(6, "Instantiate from string register name") 
     170    $P1 = newclass 'Foo5' 
    221171 
    222     $P2 = new ['Foo';'Bar'] 
     172    $S1 = 'Foo5' 
     173    $P2 = new $S1 
     174    _test_instance($P2, 'Foo5') 
     175.end 
    223176 
    224     $S1 = typeof $P2 
    225     say $S1 
    226177 
    227     $I3 = isa $P2, ['Foo';'Bar'] 
    228     print $I3 
    229     print "\n" 
     178.sub instantiate_from_string_PMC_name 
     179    ok(7, "Instantiate from string PMC name") 
     180    $P1 = newclass 'Foo6' 
    230181 
    231     $I3 = isa $P2, "Object" 
    232     print $I3 
    233     print "\n" 
     182    $P3 = new 'String' 
     183    $P3 = 'Foo6' 
     184    $P2 = new $P3 
     185    _test_instance($P2, 'Foo6') 
    234186.end 
    235 CODE 
    236 Class 
    237 1 
    238 Foo;Bar 
    239 1 
    240 1 
    241 OUT 
    242187 
    243 pir_output_is( 
    244     <<'CODE', <<'OUT', 'instantiate from key PMC name', todo => 'create non-constant key' ); 
    245 .sub main :main 
    246     $P1 = newclass ['Foo';'Bar'] 
     188 
     189.sub instantiate_from_key_name 
     190    ok(8, "Instantiate from Key name") 
     191    $P1 = newclass ['Foo';'Bar1'] 
    247192    $S1 = typeof $P1 
    248     say $S1 
     193    is($S1, 'Class', "`newclass ['Foo';'Bar1']` creates a Class PMC") 
     194    isa_ok($P1, 'Class') 
    249195 
    250     $I3 = isa $P1, "Class" 
    251     say $I3 
     196    $P2 = new $P1 
     197    _test_instance($P2, 'Foo Bar1') 
     198.end 
    252199 
    253     # How do you set the value of a non-constant key PMC? 
    254     $P3 = new 'Key' 
    255200 
    256     $P2 = new $P3 
     201.sub instantiate_from_key_PMC_name 
     202    ok(9, "Instantiate from Key PMC name") 
     203    $P1 = newclass ['Foo';'Bar2'] 
    257204 
    258     $S1 = typeof $P2 
    259     say $S1 
     205    $P3 = new 'Key' 
     206    $P3 = 'Foo' 
     207    $P4 = new 'Key' 
     208    $P4 = 'Bar2' 
     209    push $P3, $P4 
    260210 
    261     $I3 = isa $P2, 'Bar' 
    262     say $I3 
    263  
    264     $I3 = isa $P2, "Object" 
    265     say $I3 
     211    $P2 = new $P3 
     212    _test_instance($P2, 'Foo Bar2') 
    266213.end 
    267 CODE 
    268 Class 
    269 1 
    270 Foo;Bar 
    271 1 
    272 1 
    273 OUT 
    274214 
    275 pir_output_is( <<'CODE', <<'OUT', 'create and instantiate from array of names' ); 
    276 .sub main :main 
    277     $P0 = split " ", "Foo Bar" 
     215 
     216.sub create_and_instantiate_from_array_of_names 
     217    ok(10, "Create and instantiate from ResizableStringArray") 
     218    $P0 = split ' ', 'Foo Bar3' 
    278219    $P1 = newclass $P0 
    279220    $S1 = typeof $P1 
    280     say $S1 
     221    is($S1, 'Class', "`newclass some_string_array` creates a Class PMC") 
     222    isa_ok($P1, 'Class') 
    281223 
    282     $I3 = isa $P1, "Class" 
    283     print $I3 
    284     print "\n" 
    285  
    286224    $P2 = new $P0 
    287  
    288     $S1 = typeof $P2 
    289     say $S1 
    290  
    291     $I3 = isa $P2, ['Foo';'Bar'] 
    292     print $I3 
    293     print "\n" 
    294  
    295     $I3 = isa $P2, "Object" 
    296     print $I3 
    297     print "\n" 
     225    _test_instance($P2, 'Foo Bar3') 
    298226.end 
    299 CODE 
    300 Class 
    301 1 
    302 Foo;Bar 
    303 1 
    304 1 
    305 OUT 
    306227 
    307 pir_error_output_like( <<'CODE', <<'OUT', 'only string arrays work for creating classes' ); 
    308 .sub main :main 
    309     $P0 = new 'ResizablePMCArray' 
     228 
     229.sub only_string_arrays_work_for_creating_classes 
     230    ok(11, 'Create a class via a ResizablePMCArray') 
     231    .local pmc eh 
     232    .local string message 
     233    $P0  = new 'ResizablePMCArray' 
    310234    $P10 = new 'String' 
    311235    $P10 = 'Foo' 
    312236    $P11 = new 'String' 
    313     $P11 = 'Bar' 
     237    $P11 = 'Bar4' 
     238    $P0.'push'($P10) 
     239    $P0.'push'($P11) 
    314240 
     241  try: 
     242    eh = new 'ExceptionHandler' 
     243    eh.'handle_types'(.EXCEPTION_INVALID_OPERATION) 
     244    set_addr eh, catch 
     245 
     246    push_eh eh 
    315247    $P1 = newclass $P0 
    316     $S1 = typeof $P1 
    317     say $S1 
     248    $I0 = 1 
     249    goto finally 
    318250 
    319     $I3 = isa $P1, "Class" 
    320     print $I3 
    321     print "\n" 
     251  catch: 
     252    .local pmc exception 
     253    .get_results(exception) 
     254    message = exception['message'] 
     255    $I0 = 0 
    322256 
    323     $P2 = new $P0 
    324  
    325     $S1 = typeof $P2 
    326     say $S1 
    327  
    328     $I3 = isa $P2, ['Foo';'Bar'] 
    329     print $I3 
    330     print "\n" 
    331  
    332     $I3 = isa $P2, "Object" 
    333     print $I3 
    334     print "\n" 
     257  finally: 
     258    pop_eh 
     259    nok($I0, "Exception caught for ...") 
     260    is(message, 'Invalid class name key in init_pmc for Class', 'Invalid class name key') 
    335261.end 
    336 CODE 
    337 /Invalid class name key/ 
    338 OUT 
    339262 
    340 pir_output_is( <<'CODE', <<'OUT', 'instantiate from class object with init' ); 
    341 .sub main :main 
    342     $P1 = newclass "Foo" 
     263 
     264.sub instantiate_from_class_object_with_init 
     265    ok(12, 'Instantiate from Class object, with init') 
     266    $P1 = newclass 'Foo7' 
    343267    addattribute $P1, 'data' 
    344268    $P3 = new 'Hash' 
    345269    $P4 = new 'String' 
    346     $P4 = "data for Foo\n" 
     270    $P4 = 'data for Foo7' 
    347271    $P3['data'] = $P4 
    348272 
    349273    $P2 = new $P1, $P3 
     274    _test_instance($P2, 'Foo7') 
    350275 
    351     $S1 = typeof $P2 
    352     say $S1 
    353  
    354     $I3 = isa $P2, "Foo" 
    355     print $I3 
    356     print "\n" 
    357  
    358     $I3 = isa $P2, "Object" 
    359     print $I3 
    360     print "\n" 
    361  
    362276    $P5 = getattribute $P2, 'data' 
    363     print $P5 
     277    is($P5, 'data for Foo7', 'class attribute retrieved via the instance') 
    364278.end 
    365 CODE 
    366 Foo 
    367 1 
    368 1 
    369 data for Foo 
    370 OUT 
    371279 
    372 pir_output_is( <<'CODE', <<'OUT', 'instantiate from string name with init' ); 
    373 .sub main :main 
    374     $P1 = newclass "Foo" 
     280 
     281.sub instantiate_from_string_name_with_init 
     282    ok(13, 'Instantiate from string name, with init') 
     283    $P1 = newclass 'Foo8' 
    375284    addattribute $P1, 'data' 
    376285    $P3 = new 'Hash' 
    377286    $P4 = new 'String' 
    378     $P4 = "data for Foo\n" 
     287    $P4 = 'data for Foo8' 
    379288    $P3['data'] = $P4 
    380289 
    381     $P2 = new 'Foo', $P3 
     290    $P2 = new 'Foo8', $P3 
     291    _test_instance($P2, 'Foo8') 
    382292 
    383     $S1 = typeof $P2 
    384     say $S1 
    385  
    386     $I3 = isa $P2, "Foo" 
    387     print $I3 
    388     print "\n" 
    389  
    390     $I3 = isa $P2, "Object" 
    391     print $I3 
    392     print "\n" 
    393  
    394293    $P5 = getattribute $P2, 'data' 
    395     print $P5 
     294    is($P5, 'data for Foo8', 'class attribute retrieved via the instance') 
    396295.end 
    397 CODE 
    398 Foo 
    399 1 
    400 1 
    401 data for Foo 
    402 OUT 
    403296 
    404 pir_output_is( <<'CODE', <<'OUT', 'instantiate from string register name with init' ); 
    405 .sub main :main 
    406     $P1 = newclass "Foo" 
     297 
     298.sub instantiate_from_string_register_name_with_init 
     299    ok(14, 'Instantiate from string register name, with init') 
     300    $P1 = newclass 'Foo9' 
    407301    addattribute $P1, 'data' 
    408302    $P3 = new 'Hash' 
    409303    $P4 = new 'String' 
    410     $P4 = "data for Foo\n" 
     304    $P4 = 'data for Foo9' 
    411305    $P3['data'] = $P4 
    412306 
    413     $S1 = 'Foo' 
     307    $S1 = 'Foo9' 
    414308    $P2 = new $S1, $P3 
     309    _test_instance($P2, 'Foo9') 
    415310 
    416     $S1 = typeof $P2 
    417     say $S1 
    418  
    419     $I3 = isa $P2, "Foo" 
    420     print $I3 
    421     print "\n" 
    422  
    423     $I3 = isa $P2, "Object" 
    424     print $I3 
    425     print "\n" 
    426  
    427311    $P5 = getattribute $P2, 'data' 
    428     print $P5 
     312    is($P5, 'data for Foo9', 'class attribute retrieved via the instance') 
    429313.end 
    430 CODE 
    431 Foo 
    432 1 
    433 1 
    434 data for Foo 
    435 OUT 
    436314 
    437 pir_output_is( <<'CODE', <<'OUT', 'instantiate from string PMC name with init' ); 
    438 .sub main :main 
    439     $P1 = newclass "Foo" 
     315 
     316.sub instantiate_from_string_PMC_name_with_init 
     317    ok(15, 'Instantiate from string PMC name, with init') 
     318    $P1 = newclass 'Foo10' 
    440319    addattribute $P1, 'data' 
    441320    $P3 = new 'Hash' 
    442321    $P4 = new 'String' 
    443     $P4 = "data for Foo\n" 
     322    $P4 = 'data for Foo10' 
    444323    $P3['data'] = $P4 
    445324 
    446325    $P6 = new 'String' 
    447     $P6 = 'Foo' 
     326    $P6 = 'Foo10' 
    448327    $P2 = new $P6, $P3 
     328    _test_instance($P2, 'Foo10') 
    449329 
    450     $S1 = typeof $P2 
    451     say $S1 
    452  
    453     $I3 = isa $P2, "Foo" 
    454     print $I3 
    455     print "\n" 
    456  
    457     $I3 = isa $P2, "Object" 
    458     print $I3 
    459     print "\n" 
    460  
    461330    $P5 = getattribute $P2, 'data' 
    462     print $P5 
     331    is($P5, 'data for Foo10', 'class attribute retrieved via the instance') 
    463332.end 
    464 CODE 
    465 Foo 
    466 1 
    467 1 
    468 data for Foo 
    469 OUT 
    470333 
    471 pir_output_is( <<'CODE', <<'OUT', 'instantiate from array of names with init' ); 
    472 .sub main :main 
    473     $P0 = split " ", "Foo Bar" 
     334 
     335.sub instantiate_from_array_of_names_with_init 
     336    ok(16, 'Instantiate from string array, with init') 
     337    $P0 = split ' ', 'Foo Bar5' 
    474338    $P1 = newclass $P0 
    475339    addattribute $P1, 'data' 
    476340    $P3 = new 'Hash' 
    477341    $P4 = new 'String' 
    478     $P4 = "data for Foo;Bar\n" 
     342    $P4 = 'data for Foo;Bar5' 
    479343    $P3['data'] = $P4 
    480344 
    481345    $P2 = new $P0, $P3 
    482346 
    483347    $S1 = typeof $P2 
    484     say $S1 
     348    _test_instance($P2, 'Foo Bar5') 
    485349 
    486     $I3 = isa $P2, ["Foo";"Bar"] 
    487     print $I3 
    488     print "\n" 
    489  
    490     $I3 = isa $P2, "Object" 
    491     print $I3 
    492     print "\n" 
    493  
    494350    $P5 = getattribute $P2, 'data' 
    495     print $P5 
     351    is($P5, 'data for Foo;Bar5', 'class attribute retrieved via the instance') 
    496352.end 
    497 CODE 
    498 Foo;Bar 
    499 1 
    500 1 
    501 data for Foo;Bar 
    502 OUT 
    503353 
    504 pir_output_is( <<'CODE', <<'OUT', 'instantiate from key name with init' ); 
    505 .sub main :main 
    506     $P1 = newclass ['Foo';'Bar'] 
     354 
     355.sub instantiate_from_key_name_with_init 
     356    ok(17, 'Instantiate from Key name, with init') 
     357    $P1 = newclass ['Foo';'Bar6'] 
    507358    addattribute $P1, 'data' 
    508359 
    509360    $P3 = new 'Hash' 
    510361    $P4 = new 'String' 
    511     $P4 = "data for Foo;Bar\n" 
     362    $P4 = 'data for Foo;Bar6' 
    512363    $P3['data'] = $P4 
    513364 
    514     $P2 = new ['Foo';'Bar'], $P3 
     365    $P2 = new ['Foo';'Bar6'], $P3 
     366    _test_instance($P2, 'Foo Bar6') 
    515367 
    516     $S1 = typeof $P2 
    517     say $S1 
    518  
    519     $I3 = isa $P2, 'Bar' 
    520     print $I3 
    521     print "\n" 
    522  
    523     $I3 = isa $P2, "Object" 
    524     print $I3 
    525     print "\n" 
    526  
    527368    $P5 = getattribute $P2, 'data' 
    528     print $P5 
     369    is($P5, 'data for Foo;Bar6', 'class attribute retrieved via the instance') 
    529370.end 
    530 CODE 
    531 Foo;Bar 
    532 0 
    533 1 
    534 data for Foo;Bar 
    535 OUT 
    536371 
    537 pir_output_is( <<'CODE', <<'OUT', 'create class namespace initializer' ); 
    538 .sub main :main 
     372 
     373.sub create_class_namespace_initializer 
    539374    .local pmc ns 
    540     ns = get_namespace ['Foo';'Bar'] 
     375    ns = get_namespace ['Foo';'Bar7'] 
    541376    $P0 = new 'Class', ns 
    542377 
    543     $P1 = new ['Foo';'Bar'] 
    544     $P1.'blue'() 
     378    $P1 = new ['Foo';'Bar7'] 
     379    $S0 = $P1.'blue'() 
     380    is($S0, 'foo_bar7 blue', 'Create class namespace initializer') 
    545381.end 
    546382 
    547 .namespace [ 'Foo';'Bar' ] 
    548 .sub 'blue' :method 
    549     say 'foo blue' 
     383.namespace [ 'Foo';'Bar7' ] 
     384.sub blue :method 
     385    .return('foo_bar7 blue') 
    550386.end 
    551387 
    552 CODE 
    553 foo blue 
    554 OUT 
     388.namespace [] 
    555389 
    556 pir_output_is( <<'CODE', <<'OUT', 'regression test, instantiate class within different namespace' ); 
    557 .sub main :main 
    558     $P0 = newclass 'Foo' 
    559     $P0 = newclass 'Bar' 
    560390 
    561     $P1 = new 'Foo' 
    562     $P1.'blue'() 
     391.sub regression_test_instantiate_class_within_different_namespace 
     392    $P0 = newclass 'Foo11' 
     393    $P0 = newclass 'Bar11' 
     394 
     395    $P1 = new 'Foo11' 
     396    $S0 = $P1.'blue'() 
     397    is($S0, 'foo11 blue bar11 blue', 'Regression test: instantiate class within different namespace') 
    563398.end 
    564399 
    565 .namespace [ 'Foo' ] 
    566 .sub 'blue' :method 
    567     say 'foo blue' 
    568     $P1 = new 'Bar' 
    569     $P1.'blue'() 
     400.namespace [ 'Foo11' ] 
     401.sub blue :method 
     402    $P0 = new 'Bar11' 
     403    $S0 = $P0.'blue'() 
     404    $S0 = concat 'foo11 blue ', $S0 
     405    .return($S0) 
    570406.end 
    571407 
    572 .namespace [ 'Bar' ] 
    573 .sub 'blue' :method 
    574     say 'bar blue' 
     408.namespace [ 'Bar11' ] 
     409.sub blue :method 
     410    .return('bar11 blue') 
    575411.end 
    576 CODE 
    577 foo blue 
    578 bar blue 
    579 OUT 
    580412 
    581 pir_output_is( <<'CODE', <<'OUT', 'get_class retrieves a high-level class object' ); 
    582 .sub main :main 
    583     $P0 = newclass 'Foo' 
     413.namespace [] 
     414 
     415 
     416.sub get_class_retrieves_a_high_level_class_object 
     417    ok(20, 'get_class retrieves a high level class object') 
     418    $P0 = newclass 'Foo12' 
    584419    $S1 = typeof $P0 
    585     say $S1 
     420    is($S1, 'Class',"`newclass 'Foo12' returns a Class PMC`") 
    586421 
    587     $P1 = get_class 'Foo' 
     422    $P1 = get_class 'Foo12' 
    588423    $S1 = typeof $P1 
    589     say $S1 
     424    is($S1, 'Class',"`get_class 'Foo12' returns a Class PMC`") 
    590425 
    591426    $P2 = new $P1 
    592     $S1 = typeof $P2 
    593     say $S1 
     427    _test_instance($P2, 'Foo12') 
    594428.end 
    595 CODE 
    596 Class 
    597 Class 
    598 Foo 
    599 OUT 
    600429 
    601 pir_output_is( <<'CODE', <<'OUT', 'get_class retrieves a proxy class object' ); 
    602 .sub main :main 
     430 
     431.sub get_class_retrieves_a_proxy_class_object 
     432    ok(21, 'get_class retrieves a proxy class object') 
    603433    $P1 = get_class 'String' 
    604434    $S1 = typeof $P1 
    605     say $S1 
     435    is($S1, 'PMCProxy', "`get_class 'String'` returns a PMCProxy PMC") 
    606436 
    607437    $P2 = new $P1 
    608438    $S1 = typeof $P2 
    609     say $S1 
     439    is($S1, 'String', 'Instantiating the proxy returns a String PMC') 
    610440.end 
    611 CODE 
    612 PMCProxy 
    613 String 
    614 OUT 
    615441 
    616 pir_output_is( <<'CODE', <<'OUT', "get_class retrieves a class object that doesn't exist" ); 
    617 .sub main :main 
     442 
     443.sub get_class_retrieves_a_class_object_that_doesnt_exist 
     444    ok(22, 'get_class retrieves a class object that does not exist') 
     445    .local int murple_not_defined 
     446    murple_not_defined = 1 
    618447    $P1 = get_class 'Murple' 
    619448    if null $P1 goto not_defined 
    620     say "Class is defined. Shouldn't be." 
    621     end 
     449    murple_not_defined = 0 
     450 
    622451  not_defined: 
    623     say "Class isn't defined." 
     452    ok(murple_not_defined, '"Murple" class is not defined') 
    624453.end 
    625 CODE 
    626 Class isn't defined. 
    627 OUT 
    628454 
    629 pir_error_output_like(<<'CODE', <<'OUT', 'Instantiate class from invalid key'); 
    630 .sub 'main' :main 
     455 
     456.sub instantiate_class_from_invalid_key 
     457    ok(23, 'Instantiate a class from invalid Key PMC') 
     458    .local pmc eh 
     459    .local string message 
     460 
     461  try: 
     462    eh = new 'ExceptionHandler' 
     463    eh.'handle_types'(.EXCEPTION_NO_CLASS) 
     464    set_addr eh, catch 
     465 
     466    push_eh eh 
    631467    $P0 = new [ 'Foo'; 'Bar'; 'Baz' ] 
     468    $I0 = 1 
     469    goto finally 
     470     
     471  catch: 
     472    .local pmc exception 
     473    .get_results(exception) 
     474    message = exception['message'] 
     475    $I0 = 0 
     476 
     477  finally:    pop_eh 
     478    nok($I0, 'Exception caught for ...') 
     479    is(message, "Class '[ 'Foo' ; 'Bar' ; 'Baz' ]' not found", 'Class not found') 
    632480.end 
    633 CODE 
    634 /Class '\[ 'Foo' ; 'Bar' ; 'Baz' \]' not found/ 
    635 OUT 
    636481 
     482 
    637483# Local Variables: 
    638 #   mode: cperl 
    639 #   cperl-indent-level: 4 
     484#   mode: pir 
    640485#   fill-column: 100 
    641486# End: 
    642 # vim: expandtab shiftwidth=4: 
     487# vim: expandtab shiftwidth=4 ft=pir: