t/oo/metamodel.t

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