t/oo/vtableoverride.t

   1 #!./parrot
   2 # Copyright (C) 2007-2009, Parrot Foundation.
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 t/oo/vtableoverride.t - test various vtable overrides from PIR
   8
   9 =head1 SYNOPSIS
  10
  11     % prove t/oo/vtableoverride.t
  12
  13 =head1 DESCRIPTION
  14
  15 Tests the behavior of VTABLE interfaces that have been overriden from PIR.
  16
  17 =cut
  18
  19 .sub main :main
  20     .include 'test_more.pir'
  21     plan(15)
  22
  23     newclass_tests()
  24     subclass_tests()
  25     vtable_implies_self_tests()
  26     anon_vtable_tests()
  27     invalid_vtable()
  28     get_pmc_keyed_int_Null()
  29 .end
  30
  31 .sub invalid_vtable
  32     throws_substring(<<'CODE',' but was used with ', 'invalid :vtable throws an exception')
  33     .namespace [ "Test" ]
  34     .sub monkey :method :vtable("not_in_the_vtable")
  35         .param int key
  36         .return("monkey")
  37     .end
  38 CODE
  39 .end
  40
  41 .sub 'newclass_tests'
  42     $P1 = new 'MyObject'
  43
  44     # Test get_string
  45     $S0 = $P1
  46     is($S0, "[MyObject]", "get_string VTABLE override")
  47     $P0 = getattribute $P1, "message"
  48     $S0 = $P0
  49     is($S0, "[MyObject]", "attribute sideeffect of get_string")
  50
  51     # Test does
  52     $I0 = does $P1, 'this_dress_make...'
  53     is ($I0, 1, "check first does, ok")
  54     $I0 = does $P1, 'a_body_good'
  55     is ($I0, 1, "check second does, ok")
  56     $I0 = does $P1, 'it_better'
  57     is ($I0, 0, "no it doesn't")
  58
  59     # Test morph (doesn't actually perform a morph)
  60     $P2 = get_class 'String'
  61     morph $P1, $P2
  62     $P0 = getattribute $P1, "message"
  63     $S0 = $P0
  64     is($S0, "Morphing [MyObject] to type String", "Morph VTABLE override 1")
  65
  66     $P2 = get_class 'Integer'
  67     morph $P1, $P2
  68     $P0 = getattribute $P1, "message"
  69     $S0 = $P0
  70     is($S0, "Morphing [MyObject] to type Integer", "Morph VTABLE override 1")
  71
  72     # Test invoke. Doesn't currently work so we need to fix that.
  73     #$P0 = $P1("invoked!")
  74     #$S0 = $P0
  75     #is($S0, "invoked!", "Invoke VTABLE override return value")
  76
  77     #$P0 = getattribute $P1, "message"
  78     #$S0 = $P0
  79     #is($S0, "invoked!", "Invoke VTABLE override sideeffects")
  80 .end
  81
  82 .sub 'subclass_tests'
  83     $P1 = new 'MySubObject'
  84
  85     # Test does, same as newclass.
  86     $I0 = does $P1, 'this_dress_make...'
  87     is ($I0, 1, "check first does, ok")
  88     $I0 = does $P1, 'a_body_good'
  89     is ($I0, 1, "check second does, ok")
  90     $I0 = does $P1, 'it_better'
  91     is ($I0, 0, "no it doesn't")
  92     # Also verify we does what our parent does
  93     $I0 = does $P1, 'array'
  94     is ($I0, 1, "inherited does")
  95 .end
  96
  97 .sub 'vtable_implies_self_tests'
  98   $P1 = get_class 'MyVtableObject'
  99   $P2 = $P1.'new'()
 100   $I0 = does $P2, 'frobulate'
 101   ok( $I0, ':vtable should imply the self parameter' )
 102 .end
 103
 104
 105 .sub 'anon_vtable_tests'
 106     $P0 = newclass "AnonVtableType"
 107     $P1 = new 'AnonVtableType'
 108     push_eh anon_does_not_work
 109     $S0 = $P1
 110     is($S0, "foo", "can have :vtable :anon")
 111     goto anon_end
 112   anon_does_not_work:
 113     ok(0, "can not have :anon :vtable")
 114   anon_end:
 115     pop_eh
 116 .end
 117
 118 .sub 'get_pmc_keyed_int_Null'
 119     $P0 = newclass [ 'NoReturn_get_pmc_keyed_int' ]
 120     $P1 = new $P0
 121     $P2 = $P1[0]
 122     $I0 = isnull $P2
 123     ok($I0, "Override get_pmc_keyed_int without .return - TT #1593")
 124 .end
 125
 126 .namespace [ 'MyObject' ]
 127
 128 .sub '__onload' :anon :init
 129     $P0 = newclass "MyObject"
 130     addattribute $P0, "message"
 131 .end
 132
 133 .sub 'get_string' :vtable
 134     $S0 = "[MyObject]"
 135     $P0 = box $S0
 136     setattribute self, "message", $P0
 137     .return($S0)
 138 .end
 139
 140 .sub 'morph' :vtable
 141     .param pmc class
 142     .local string type
 143     $S0 = self
 144     $S1 = "Morphing " . $S0
 145     $S1 = $S1 . " to type "
 146     type = class.'name'()
 147     $S1 = $S1 . type
 148     $P0 = box $S1
 149     setattribute self, "message", $P0
 150 .end
 151
 152 .sub 'does' :vtable
 153     .param string query
 154     $S0 = 'does I do '
 155     $S0 .= query
 156     $P0 = box $S0
 157     setattribute self, "message", $P0
 158     if query == 'this_dress_make...'   goto yes
 159     if query == 'a_body_good' goto yes
 160     .return(0)
 161 yes:
 162     .return (1)
 163 .end
 164
 165 .sub 'invoke' :vtable
 166     .param string msg
 167     $P0 = box msg
 168     setattribute self, "message", $P0
 169     .return($P0)
 170 .end
 171
 172 .namespace [ 'MySubObject' ]
 173
 174 .sub '__onload' :anon :init
 175     $P1 = get_class 'ResizablePMCArray'
 176     $P0 = subclass $P1, 'MySubObject'
 177     addattribute $P0, "submessage"
 178 .end
 179
 180 .sub 'does' :vtable
 181     .param string query
 182     $S0 = 'does I do '
 183     $S0 .= query
 184     $P0 = box $S0
 185     setattribute self, "submessage", $P0
 186     if query == 'this_dress_make...'   goto yes
 187     if query == 'a_body_good' goto yes
 188     .return(0)
 189 yes:
 190     .return (1)
 191 .end
 192
 193 .namespace [ 'MyVtableObject' ]
 194
 195 .sub '__onload' :anon :init
 196   $P1 = get_class 'String'
 197   $P2 = subclass $P1, 'MyVtableObject'
 198 .end
 199
 200 .sub 'does' :vtable
 201     .param string what
 202     eq what, 'frobulate', true
 203     .return( 0 )
 204
 205   true:
 206     .return( 1 )
 207 .end
 208
 209
 210 .namespace [ 'AnonVtableType' ]
 211
 212 .sub '' :vtable('get_string') :method :anon
 213     .return("foo")
 214 .end
 215
 216
 217 .namespace [ 'NoReturn_get_pmc_keyed_int' ]
 218
 219 .sub 'get_pmc_keyed_int' :vtable
 220     .param int i
 221     # No .return
 222 .end
 223
 224 # Local Variables:
 225 #   mode: pir
 226 #   fill-column: 100
 227 # End:
 228 # vim: expandtab shiftwidth=4 ft=pir: