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 .sub fail
  96     .param string desc
  97     'ok'(0, desc)
  98 .end
  99
 100 .namespace['Dog']
 101
 102 .sub _accessor :method
 103   .param string attrib
 104   .param pmc value :optional
 105   .param int got_value
 106   unless got_value goto get_attr
 107   setattribute self, attrib, value
 108 get_attr:
 109   .local pmc rv
 110   rv = getattribute self, attrib
 111   .return(rv)
 112 .end
 113
 114 .sub init_pmc :vtable :method
 115     .param pmc init_args
 116   # Iterate over the constructor arguments, calling the accessor for each
 117     .local pmc it
 118     it = iter init_args
 119   iter_loop:
 120     unless it goto iter_end
 121     $S1 = shift it
 122     $P1 = it[$S1]
 123     self.$S1($P1)
 124     goto iter_loop
 125   iter_end:
 126 .end
 127
 128 .sub bark :method
 129   .param pmc bark :optional
 130   .param int got_bark :opt_flag
 131   .local pmc rv
 132   rv = self.'_accessor'( "bark", bark, got_bark )
 133   .return(rv)
 134 .end
 135
 136 .sub tail :method
 137   .param pmc tail :optional
 138   .param int got_tail :opt_flag
 139   .local pmc rv
 140   rv = self.'_accessor'( "tail", tail, got_tail )
 141   .return(rv)
 142 .end
 143
 144 # Local Variables:
 145 #   mode: pir
 146 #   fill-column: 100
 147 # End:
 148 # vim: expandtab shiftwidth=4 ft=pir: