t/library/p6object.t

   1 #!./parrot
   2 # Copyright (C) 2001-2008, The Perl Foundation.
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 t/library/p6object.t -- P6object tests
   8
   9 =head1 SYNOPSIS
  10
  11     % prove t/library/p6object.t
  12
  13 =head1 DESCRIPTION
  14
  15 =cut
  16
  17 .sub 'main' :main
  18     load_bytecode 'library/Test/More.pbc'
  19
  20     .local pmc exports, curr_namespace, test_namespace
  21     curr_namespace = get_namespace
  22     test_namespace = get_namespace ['Test';'More']
  23     exports        = split ' ', 'plan diag ok nok is isa_ok'
  24
  25     test_namespace.'export_to'(curr_namespace, exports)
  26
  27     ##  set our plan
  28     .local int plan_tests
  29     plan(107)
  30
  31     ##  make sure we can load the P6object library
  32     push_eh load_failed
  33     load_bytecode 'P6object.pbc'
  34     pop_eh
  35     ok(1, 'load_bytecode')
  36
  37     ##  test the P6metaclass protoobject itself
  38     .local pmc metaproto
  39     metaproto = get_hll_global 'P6metaclass'
  40     isa_ok(metaproto, 'P6metaclass', 'P6metaclass protoobject')
  41     isa_ok(metaproto, 'P6protoobject', 'P6metaclass protoobject')
  42     $P0 = metaproto.'WHAT'()
  43     $I0 = issame metaproto, $P0
  44     ok($I0, 'P6metaclass.WHAT identity')
  45     $S0 = metaproto
  46     is($S0, 'P6metaclass', 'P6metaclass.WHAT eq "P6metaclass"')
  47     $S0 = typeof metaproto
  48     is($S0, 'P6metaclass', 'typeof P6metaclass proto eq "P6metaclass"')
  49     $P0 = metaproto.'HOW'()
  50     isa_ok($P0, 'P6metaclass', 'P6metaclass.HOW()')
  51     $I0 = defined metaproto
  52     nok($I0, 'P6metaclass protoobject undefined')
  53
  54     ##  register an existing PMCProxy-based class
  55     .local pmc hashproto
  56     $P0 = metaproto.register('Hash')
  57     hashproto = get_hll_global 'Hash'
  58     $I0 = issame hashproto, $P0
  59     ok($I0, 'Hash proto =:= return value from .register()')
  60     isa_ok(hashproto, 'Hash', 'Hash proto')
  61     isa_ok(hashproto, 'P6protoobject', 'Hash proto')
  62     $P0 = hashproto.'WHAT'()
  63     $I0 = issame hashproto, $P0
  64     ok($I0, 'Hash proto .WHAT identity')
  65     $S0 = hashproto
  66     is($S0, 'Hash', 'Hash.WHAT eq "Hash"')
  67     $S0 = typeof hashproto
  68     is($S0, 'Hash', 'typeof Hash proto eq "Hash"')
  69     $P0 = hashproto.'HOW'()
  70     isa_ok($P0, 'P6metaclass', 'Hash proto .HOW')
  71     $I0 = defined metaproto
  72     nok($I0, 'Hash proto undefined')
  73
  74     ##  instantiate from the Hash protoobject
  75     .local pmc hash
  76     hash = hashproto.'new'()
  77     isa_ok(hash, 'Hash', 'return from Hash.new()')
  78     $I0 = isa hash, 'P6object'
  79     nok($I0, 'hash object not isa P6object')
  80     $I0 = isa hash, 'P6protoobject'
  81     nok($I0, 'hash object not isa P6protoobject')
  82     ##  verify that it really is a Hash (PMCProxy) and not some subclass
  83     $P0 = typeof hash
  84     $S0 = typeof $P0
  85     is($S0, 'PMCProxy', 'hash object class is PMCProxy')
  86     $S0 = typeof hash
  87     is($S0, 'Hash', 'typeof hash object eq "Hash"')
  88     $P0 = hash.'WHAT'()
  89     $I0 = issame hashproto, $P0
  90     ok($I0, 'hash object .WHAT =:= Hash proto')
  91     $P0 = hash.'HOW'()
  92     $P1 = hashproto.'HOW'()
  93     $I0 = issame $P0, $P1
  94     ok($I0, 'hash object .HOW =:= Hash proto .HOW')
  95     $I0 = defined hash
  96     ok($I0, 'hash object defined')
  97     $I0 = can hash, 'new'
  98     nok($I0, 'hash .new method undefined')
  99
 100     ##  create a new standalone class (derived from P6object)
 101     .local pmc abcproto
 102     $P0 = metaproto.'new_class'('ABC')
 103     abcproto = get_hll_global 'ABC'
 104     $I0 = issame abcproto, $P0
 105     ok($I0, 'ABC proto =:= return value from .new_class()')
 106     isa_ok(abcproto, 'ABC', 'ABC proto')
 107     isa_ok(abcproto, 'P6object', 'ABC proto')
 108     isa_ok(abcproto, 'P6protoobject', 'ABC proto')
 109     $P0 = abcproto.'WHAT'()
 110     $I0 = issame abcproto, $P0
 111     ok($I0, 'ABC proto .WHAT identity')
 112     $S0 = abcproto
 113     is($S0, 'ABC', 'ABC.WHAT eq "ABC"')
 114     $S0 = typeof abcproto
 115     is($S0, 'ABC', 'typeof ABC proto eq "ABC"')
 116     $P0 = abcproto.'HOW'()
 117     isa_ok($P0, 'P6metaclass', 'ABC proto .HOW')
 118     $I0 = $P0.'can'('foo')
 119     ok($I0, "ABC.HOW.can('foo')")
 120     $I0 = $P0.'can'('bar')
 121     nok($I0, "ABC.HOW.can('bar')")
 122     $I0 = defined metaproto
 123     nok($I0, 'ABC proto undefined')
 124
 125     ##  try the default .new method on ABC protoobject
 126     .local pmc abc
 127     abc = abcproto.'new'()
 128     isa_ok(abc, 'ABC', 'return from ABC.new()')
 129     isa_ok(abc, 'P6object', 'return from ABC.new()')
 130     $I0 = isa abc, 'P6protoobject'
 131     nok($I0, 'hash object not isa P6protoobject')
 132     $P0 = abc.'WHAT'()
 133     $I0 = issame abcproto, $P0
 134     ok($I0, 'abc object .WHAT =:= ABC proto')
 135     $S0 = typeof $P0
 136     is($S0, 'ABC', 'typeof ABC object eq "ABC"')
 137     $P0 = abc.'HOW'()
 138     $P1 = abcproto.'HOW'()
 139     $I0 = issame $P0, $P1
 140     ok($I0, 'abc.HOW =:= ABC.HOW')
 141     $I0 = defined abc
 142     ok($I0, 'abc defined')
 143     $I0 = can abc, 'new'
 144     nok($I0, 'abc .new method undefined')
 145
 146     ##  use P6metaclass to create a subclass of ABC
 147     .local pmc defproto
 148     $P0 = metaproto.'new_class'('DEF', 'parent'=>'ABC')
 149     defproto = get_hll_global 'DEF'
 150     $I0 = issame defproto, $P0
 151     ok($I0, 'DEF proto =:= return value from .new_class()')
 152     isa_ok(defproto, 'DEF', 'DEF proto')
 153     isa_ok(defproto, 'ABC', 'DEF proto')
 154     isa_ok(defproto, 'P6object', 'DEF proto')
 155     isa_ok(defproto, 'P6protoobject', 'DEF proto')
 156     $P0 = defproto.'WHAT'()
 157     $I0 = issame defproto, $P0
 158     ok($I0, 'DEF proto .WHAT identity')
 159     $S0 = defproto
 160     is($S0, 'DEF', 'DEF.WHAT eq "DEF"')
 161     $P0 = defproto.'HOW'()
 162     isa_ok($P0, 'P6metaclass', 'DEF proto .HOW')
 163     $I0 = defined defproto
 164     nok($I0, 'DEF proto undefined')
 165
 166     ##  create a DEF object
 167     .local pmc def
 168     def = defproto.'new'()
 169     isa_ok(def, 'DEF', 'return from DEF.new()')
 170     isa_ok(def, 'ABC', 'return from DEF.new()')
 171     isa_ok(def, 'P6object', 'return from DEF.new()')
 172     $I0 = isa def, 'P6protoobject'
 173     nok($I0, 'def object not isa P6protoobject')
 174     $P0 = def.'WHAT'()
 175     $I0 = issame defproto, $P0
 176     ok($I0, 'def object .WHAT =:= DEF proto')
 177     $P0 = def.'HOW'()
 178     $P1 = defproto.'HOW'()
 179     $I0 = issame $P0, $P1
 180     ok($I0, 'def.HOW =:= DEF.HOW')
 181     $I0 = defined def
 182     ok($I0, 'def defined')
 183     $I0 = can def, 'new'
 184     nok($I0, 'def .new method undefined')
 185
 186     ##  check that 'new' method in class overrides P6protoobject::new
 187     .local pmc ghiproto
 188     ghiproto = metaproto.'new_class'('GHI')
 189     $P0 = ghiproto.'new'()
 190     is($P0, 'GHI::new', 'GHI::new overrides P6protoobject::new')
 191
 192     ##  check that 'new' method in subclass overrides P6protoobject::new
 193     .local pmc ghi2proto
 194     ghi2proto = metaproto.'new_class'('GHI2', 'parent'=>ghiproto)
 195     $P0 = ghi2proto.'new'()
 196     is($P0, 'GHI::new', 'GHI::new overrides P6protoobject::new (in subclass)')
 197
 198     ##  create MyInt subclass from Integer PMC class
 199     .local pmc myintproto
 200     $P0 = metaproto.'new_class'('MyInt', 'parent'=>'Integer')
 201     myintproto = get_hll_global 'MyInt'
 202     $I0 = issame myintproto, $P0
 203     ok($I0, 'MyInt proto =:= return value from .new_class()')
 204     isa_ok(myintproto, 'MyInt', 'MyInt proto')
 205     isa_ok(myintproto, 'Integer', 'MyInt proto')
 206     isa_ok(myintproto, 'P6object', 'MyInt proto')
 207     isa_ok(myintproto, 'P6protoobject', 'MyInt proto')
 208
 209     ##  test MyInt objects
 210     .local pmc myint
 211     myint = myintproto.'new'()
 212     isa_ok(myint, 'MyInt', 'return from MyInt.new()')
 213     isa_ok(myint, 'Integer', 'return from MyInt.new()')
 214     isa_ok(myint, 'P6object', 'return from MyInt.new()')
 215     $I0 = isa myint, 'P6protoobject'
 216     nok($I0, 'myint object not isa P6protoobject')
 217     $P0 = myint.'WHAT'()
 218     $I0 = issame myintproto, $P0
 219     ok($I0, 'myint object .WHAT =:= MyInt proto')
 220
 221     ##  map Integer objects to MyInt
 222     .local pmc integerproto
 223     metaproto.'register'('Integer', 'protoobject'=>myintproto)
 224     .local pmc integer
 225     integer = new 'Integer'
 226     $S0 = typeof integer
 227     is($S0, 'Integer', 'Integer object creation')
 228     $P0 = integer.'WHAT'()
 229     $I0 = issame $P0, myintproto
 230     ok($I0, 'integer object .WHAT =:= MyInt proto')
 231     $S0 = integer.'WHAT'()
 232     is($S0, 'MyInt', 'integer.WHAT() eq "MyInt"')
 233     $P0 = integer.'HOW'()
 234     $P1 = myintproto.'HOW'()
 235     $I0 = issame $P0, $P1
 236     ok($I0, 'integer.HOW() =:= MyInt.HOW()')
 237
 238     ##  create a class with attributes
 239     .local pmc jklproto, jkl
 240     jklproto = metaproto.'new_class'('JKL', 'attr'=>'$a $b')
 241     jkl = jklproto.'new'()
 242     $P0 = new 'Integer'
 243     setattribute jkl, '$a', $P0
 244     setattribute jkl, '$b', $P0
 245     $P0 = 1
 246     $P1 = getattribute jkl, '$a'
 247     ok($P1, 'attribute $a creation')
 248     $P1 = getattribute jkl, '$b'
 249     ok($P1, 'attribute $b creation')
 250
 251     ##  create a class with multiple parent classes
 252     .local pmc mnoproto, mno
 253     metaproto.'new_class'('MNO', 'parent'=>'Float ABC')
 254     mnoproto = get_hll_global 'MNO'
 255     isa_ok(mnoproto, 'Float', 'MNO proto')
 256     isa_ok(mnoproto, 'ABC', 'MNO proto')
 257     isa_ok(mnoproto, 'P6object', 'MNO proto')
 258     isa_ok(mnoproto, 'P6protoobject', 'MNO proto')
 259     mno = mnoproto.'new'()
 260     isa_ok(mno, 'Float', 'MNO object')
 261     isa_ok(mno, 'ABC', 'MNO object')
 262     isa_ok(mno, 'P6object', 'MNO object')
 263     $I0 = isa mno, 'P6protoobject'
 264     nok($I0, 'MNO object not isa P6protoobject')
 265
 266     ##  create a subclass from a protoobject reference
 267     .local pmc pqrproto, pqr
 268     metaproto.'new_class'('PQR', 'parent'=>mnoproto)
 269     pqrproto = get_hll_global 'PQR'
 270     isa_ok(pqrproto, 'PQR', 'PQR proto')
 271     isa_ok(pqrproto, 'MNO', 'PQR proto')
 272     isa_ok(pqrproto, 'Float', 'PQR proto')
 273
 274     ##  use the :name option to set a class name
 275     .local pmc p6objproto, p6obj
 276     metaproto.'new_class'('Perl6Object', 'name'=>'Object')
 277     p6objproto = get_hll_global 'Object'
 278     isa_ok(p6objproto, 'Perl6Object', 'Object proto')
 279     isa_ok(p6objproto, 'P6object', 'Object proto')
 280     isa_ok(p6objproto, 'P6protoobject', 'Object proto')
 281     $S0 = p6objproto
 282     is($S0, 'Object', 'Object.WHAT eq "Object"')
 283     $P0 = get_hll_global 'Perl6Object'
 284     $I0 = isa $P0, 'P6protoobject'
 285     nok($I0, "Didn't store proto into Perl6Object")
 286     p6obj = p6objproto.'new'()
 287     isa_ok(p6obj, 'Perl6Object', 'Object instance')
 288     $P0 = p6obj.'WHAT'()
 289     $I0 = issame $P0, p6objproto
 290     ok($I0, 'obj.WHAT =:= Object.WHAT')
 291
 292     ## make sure it works for array-based names
 293     .local pmc stuproto
 294     $P0 = split '::', 'Foo::STU'
 295     $P0 = metaproto.'new_class'($P0)
 296     stuproto = get_hll_global ['Foo'], 'STU'
 297     $I0 = issame stuproto, $P0
 298     ok($I0, 'Foo::STU proto =:= return value from .new_class()')
 299     $P0 = get_class ['Foo';'STU']
 300     isa_ok(stuproto, $P0, 'Foo::STU proto')
 301     isa_ok(stuproto, 'P6object', 'Foo::STU proto')
 302     isa_ok(stuproto, 'P6protoobject', 'Foo::STU proto')
 303     $P0 = stuproto.'WHAT'()
 304     $I0 = issame stuproto, $P0
 305     ok($I0, 'Foo::STU proto .WHAT identity')
 306     $S0 = stuproto
 307     is($S0, 'STU', 'Foo::STU.WHAT eq "STU"')
 308     $P0 = stuproto.'HOW'()
 309     isa_ok($P0, 'P6metaclass', 'Foo::STU proto .HOW')
 310     $I0 = defined stuproto
 311     nok($I0, 'Foo::STU proto undefined')
 312
 313     ##  remapping ResizablePMCArray to List
 314     .local pmc listproto
 315     listproto = metaproto.'new_class'('List', 'parent'=>'ResizablePMCArray')
 316     metaproto.'register'('ResizablePMCArray', 'parent'=>listproto, 'protoobject'=>listproto)
 317     $P0 = new 'List'
 318     $I0 = can $P0, 'elems'
 319     ok($I0, 'List can elems')
 320     $P0 = new 'ResizablePMCArray'
 321     $I0 = can $P0, 'elems'
 322     ok($I0, 'ResizablePMCArray inherits List methods')
 323
 324     .return ()
 325   load_failed:
 326     ok(0, "load_bytecode 'P6object.pir' failed -- skipping tests")
 327     .return ()
 328 .end
 329
 330
 331 .namespace ['ABC']
 332 .sub 'foo' :method
 333     .return ('ABC::foo')
 334 .end
 335
 336
 337 .namespace ['GHI']
 338 .sub 'new' :method
 339     .return ('GHI::new')
 340 .end
 341
 342 .namespace ['List']
 343 .sub 'elems' :method
 344     .return ('List::elems')
 345 .end