t/oo/metamodel.t

   1 #!parrot
   2 # Copyright (C) 2007-2008, Parrot Foundation.
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 t/oo/metamodel.t - test the metamodel for Parrot OO
   8
   9 =head1 SYNOPSIS
  10
  11     % prove t/oo/metamodel.t
  12
  13 =head1 DESCRIPTION
  14
  15 Tests the metamodel for the OO implementation.
  16
  17 =cut
  18
  19 .sub _main :main
  20     load_bytecode 'Test/More.pbc'
  21
  22     .local pmc exports, curr_namespace, test_namespace
  23     curr_namespace = get_namespace
  24     test_namespace = get_namespace [ 'Test'; 'More' ]
  25     exports = split " ", "plan ok is isa_ok skip todo"
  26     test_namespace.'export_to'(curr_namespace, exports)
  27
  28     plan( 12 )
  29
  30     .local pmc class, init_args1
  31     init_args1 = new 'Hash'
  32     init_args1['name'] = 'Dog'
  33
  34     class = new "Class", init_args1
  35     isa_ok(class, "Class", "created class isa Class")
  36     $P1 = class.'name'()
  37     is($P1, "Dog", "created a new class via Class")
  38     $P1 = class.'name'()
  39     is($P1, "Dog", "Class accessor doesn't destroy value")
  40
  41     class.'add_attribute'('bark')
  42     class.'add_attribute'('ear')
  43     class.'add_attribute'('tail')
  44     .local pmc attributes
  45     attributes = class.'attributes'()
  46     $I0 = exists attributes['bark']
  47     ok($I0, "added attribute to the class")
  48
  49     $I0 = exists attributes['tail']
  50     ok($I0, "added second attribute to the class")
  51     unless $I0 goto no_tail_attribute
  52     $P1 = attributes['tail']
  53     $S1 = $P1['type']
  54     $I0 = iseq $S1, 'Str'
  55     todo($I0, "tail attribute has a type", "not implemented")
  56 #    is($S1,'Str', "tail attribute has a type")
  57     goto end_tail_attrib_test
  58   no_tail_attribute:
  59     fail("tail attribute doesn't exist")
  60   end_tail_attrib_test:
  61
  62
  63     $P0 = get_class 'Dog'
  64     $I0 = issame $P0, class
  65     ok($I0, "get_class can find the class")
  66
  67     $P0 = class.'new'( 'bark' => "Wooof", 'tail' => 'long' )
  68     $P1 = getattribute $P0, "tail"
  69     $I0 = defined $P1
  70     ok($I0, "got back a tail attribute object")
  71     unless $I0 goto FAILTAIL
  72     is($P1, "long", "tail attribute has expected value")
  73     goto NEXTTAIL
  74 FAILTAIL:
  75     fail("no attribute")
  76 NEXTTAIL:
  77
  78     $P1 = getattribute $P0, "bark"
  79     $I0 = defined $P1
  80     ok($I0, "got back a bark attribute object")
  81     unless $I0 goto FAIL
  82     is($P1, "Wooof", "bark attribute has expected value")
  83     goto NEXT
  84 FAIL:
  85     fail("no attribute")
  86 NEXT:
  87
  88     todo(0, "new opcode makes working objects", "not implemented")
  89 #    $P0 = new "Dog"
  90 #    $I0 = defined $P0
  91 #    isa_ok($P0, "Dog", "new opcode makes working objects")
  92
  93 .end
  94
  95 .namespace['Dog']
  96
  97 .sub _accessor :method
  98   .param string attrib
  99   .param pmc value :optional
 100   .param int got_value
 101   unless got_value goto get_attr
 102   setattribute self, attrib, value
 103 get_attr:
 104   .local pmc rv
 105   rv = getattribute self, attrib
 106   .return(rv)
 107 .end
 108
 109 .sub init_pmc :vtable :method
 110     .param pmc init_args
 111   # Iterate over the constructor arguments, calling the accessor for each
 112     .local pmc it
 113     it = iter init_args
 114   iter_loop:
 115     unless it goto iter_end
 116     $S1 = shift it
 117     $P1 = it[$S1]
 118     self.$S1($P1)
 119     goto iter_loop
 120   iter_end:
 121 .end
 122
 123 .sub bark :method
 124   .param pmc bark :optional
 125   .param int got_bark :opt_flag
 126   .local pmc rv
 127   rv = self.'_accessor'( "bark", bark, got_bark )
 128   .return(rv)
 129 .end
 130
 131 .sub tail :method
 132   .param pmc tail :optional
 133   .param int got_tail :opt_flag
 134   .local pmc rv
 135   rv = self.'_accessor'( "tail", tail, got_tail )
 136   .return(rv)
 137 .end
 138
 139 # Local Variables:
 140 #   mode: pir
 141 #   fill-column: 100
 142 # End:
 143 # vim: expandtab shiftwidth=4 ft=pir: