t/library/p6object.t

   1 #!./parrot
   2 # Copyright (C) 2001-2010, Parrot 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 Testing Perl 6 objects.
  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 diag ok nok is todo'
  26     test_namespace.'export_to'(curr_namespace, exports)
  27
  28     ##  set our plan
  29     plan(303)
  30
  31     ##  make sure we can load the P6object library
  32     push_eh load_fail
  33     load_bytecode 'P6object.pbc'
  34     pop_eh
  35     ok(1, 'load_bytecode')
  36     goto load_success
  37
  38   load_fail:
  39     ok(0, "load_bytecode 'P6object.pbc' failed -- skipping tests")
  40     .return ()
  41
  42   load_success:
  43     ##  test the P6metaclass protoobject itself
  44     .local pmc p6meta
  45     p6meta = get_hll_global 'P6metaclass'
  46     p6obj_tests(p6meta, 'P6metaclass', 'isa'=>'P6metaclass')
  47
  48     ##  register an existing PMCProxy-based class
  49     .local pmc hashproto, hashobj, hashns
  50     $P0 = p6meta.'register'('Hash')
  51     hashproto = get_hll_global 'Hash'
  52     hashns = get_hll_namespace ['Hash']
  53     is_same($P0, hashproto, 'return from .register =:= Hash')
  54     hashobj = p6obj_tests(hashproto, 'Hash', 'isa'=>'Hash', 'who'=>hashns)
  55     ##  make sure class of hash object is still a PMCProxy
  56     isa_nok(hashobj, 'P6object', 'Hash_obj')
  57     $P0 = typeof hashobj
  58     $S0 = typeof $P0
  59     is($S0, 'PMCProxy', '< typeof Hash_obj > returns PMCProxy instance')
  60     ##  make sure Hash objects don't get a .new method
  61     $I0 = can hashobj, 'new'
  62     nok($I0, '! < can Hash_obj, "new" >')
  63
  64     ##  create a new standalone class by name
  65     .local pmc abcproto, abcobj, abcmeta, abcns
  66     $P0 = p6meta.'new_class'('ABC')
  67     abcproto = get_hll_global 'ABC'
  68     abcns = get_hll_namespace ['ABC']
  69     is_same($P0, abcproto, 'return from .new_class =:= ABC')
  70     $P0 = split ' ', 'P6object'
  71     abcobj = p6obj_tests(abcproto, 'ABC', 'isa'=>'ABC P6object', 'can'=>'foo', 'who'=>abcns)
  72     ##  make sure negative tests for 'can' work
  73     $I0 = can abcobj, 'bar'
  74     nok($I0, '! <can ABC_obj, "bar" >')
  75     $P0 = abcobj.'HOW'()
  76     $I0 = $P0.'can'(abcobj, 'bar')
  77     nok($I0, '! ABC_obj.^can("bar")')
  78     ##  make sure abcobj didn't get a .new method
  79     $I0 = can abcobj, 'new'
  80     nok($I0, '! <can ABC_obj, "new" >')
  81
  82     ## verify .ACCEPTS method
  83     $P0 = hashproto.'ACCEPTS'(hashobj)
  84     ok($P0, 'Hash.ACCEPTS(Hash_obj)')
  85     isa_ok($P0, 'Boolean', 'Boolean')
  86     $P0 = hashproto.'ACCEPTS'(abcobj)
  87     nok($P0, 'Hash.ACCEPTS(Abc_obj)')
  88     isa_ok($P0, 'Boolean', 'Boolean')
  89     $P0 = abcproto.'ACCEPTS'(hashobj)
  90     nok($P0, 'ABC.ACCEPTS(Hash_obj)')
  91     isa_ok($P0, 'Boolean', 'Boolean')
  92     $P0 = abcproto.'ACCEPTS'(abcobj)
  93     ok($P0, 'ABCh.ACCEPTS(Abc_obj)')
  94     isa_ok($P0, 'Boolean', 'Boolean')
  95
  96     ##  create new class by namespace
  97     .local pmc ghins, ghiproto, ghiobj
  98     ghins = get_hll_namespace ['GHI']
  99     $P0 = p6meta.'new_class'(ghins)
 100     ghiproto = get_hll_global 'GHI'
 101     ghiobj = p6obj_tests(ghiproto, 'GHI', 'can'=>'foo', 'who'=>ghins)
 102
 103     ##  create a subclass called DEF1 from 'ABC'
 104     .local pmc defproto, defobj, defns
 105     $P0 = p6meta.'new_class'('DEF1', 'parent'=>'ABC')
 106     defproto = get_hll_global 'DEF1'
 107     defns    = get_hll_namespace ['DEF1']
 108     is_same($P0, defproto, 'return from .new_class =:= DEF1')
 109     defobj = p6obj_tests(defproto, 'DEF1', 'isa'=>'DEF1 ABC P6object', 'who'=>defns)
 110
 111     ##  create a subclass called DEF2 from ABC proto
 112     $P0 = p6meta.'new_class'('DEF2', 'parent'=>abcproto)
 113     defproto = get_hll_global 'DEF2'
 114     defns = get_hll_namespace ['DEF2']
 115     is_same($P0, defproto, 'return from .new_class =:= DEF2')
 116     defobj = p6obj_tests(defproto, 'DEF2', 'isa'=>'DEF2 ABC P6object', 'who'=>defns)
 117
 118     ##  create a subclass of a PMC called MyInt
 119     .local pmc myintproto, myintobj, myintmeta, myintns
 120     $P0 = p6meta.'new_class'('MyInt', 'parent'=>'Integer')
 121     myintproto = get_hll_global 'MyInt'
 122     myintns = get_hll_namespace ['MyInt']
 123     is_same($P0, myintproto, 'return from .new_class =:= MyInt')
 124     myintobj = p6obj_tests(myintproto, 'MyInt', 'isa'=>'MyInt Integer P6object', 'who'=>myintns)
 125
 126     ##  map Integer PMC objects to MyInt class, don't inherit from MyInt
 127     .local pmc integerobj, integermeta
 128     p6meta.'register'('Integer', 'protoobject'=>myintproto)
 129     integerobj = new 'Integer'
 130     $S0 = typeof integerobj
 131     is($S0, 'Integer', '< new "Integer" > still gives Integer PMC')
 132     $P0 = integerobj.'WHAT'()
 133     is_same($P0, myintproto, 'Integer_obj.WHAT =:= MyInt')
 134     integermeta = integerobj.'HOW'()
 135     myintmeta = myintobj.'HOW'()
 136     is_same(integermeta, myintmeta, 'Integer_obj.HOW =:= MyInt.HOW')
 137     $I0 = can myintobj, 'foo'
 138     ok($I0, '< can MyInt_obj, "foo" >')
 139     $I0 = can integerobj, 'foo'
 140     nok($I0, '! < can Integer_obj, "foo" >')
 141
 142     ##  map ResizablePMCArray objects to List class, inherit from List
 143     .local pmc listproto, listobj, rpaobj
 144     listproto = p6meta.'new_class'('List', 'parent'=>'ResizablePMCArray')
 145     p6meta.'register'('ResizablePMCArray', 'parent'=>listproto, 'proto'=>listproto)
 146     listobj = new 'List'
 147     $I0 = can listobj, 'foo'
 148     ok($I0, '< can List_obj, "foo" >')
 149     rpaobj = new 'ResizablePMCArray'
 150     ok($I0, '< can ResizablePMCArray_obj, "foo" >')
 151     $P0 = rpaobj.'HOW'()
 152     $I0 = $P0.'can'(rpaobj, 'foo')
 153     ok($I0, '< ResizablePMCArray_obj.^can("foo") >')
 154     $I0 = $P0.'isa'(rpaobj, listproto)
 155     todo($I0, '< ResizablePMCArray_obj.^isa(List) >', 'unimplemented: TT #1617')
 156
 157     ##  create class with a different proto name
 158     .local pmc myobjectproto
 159     $P0 = p6meta.'new_class'('MyObject', 'name'=>'Object')
 160     myobjectproto = get_hll_global 'Object'
 161     p6obj_tests(myobjectproto, 'MyObject', 'classname'=>'Object', 'isa'=>'P6object')
 162     $P0 = get_hll_global 'MyObject'
 163     $I0 = isa $P0, 'P6protoobject'
 164     nok($I0, ".new_class didn't store proto as MyObject")
 165
 166     ##  create class with ::-style name
 167     .local pmc jklproto, jklobj, jklns
 168     $P0 = p6meta.'new_class'('Foo::JKL')
 169     jklproto = get_hll_global ['Foo'], 'JKL'
 170     jklns = get_hll_namespace ['Foo';'JKL']
 171     is_same($P0, jklproto, 'return from .new_class =:= Foo::JKL')
 172     $P0 = get_hll_global 'Foo::JKL'
 173     isa_nok($P0, 'P6protoobject', '["Foo::JKL"]')
 174     jklobj = p6obj_tests(jklproto, 'Foo::JKL', 'isa'=>'P6object', 'can'=>'foo', 'who'=>jklns)
 175
 176     ##  add a method to a class
 177     $P0 = get_hll_global ['ABC'], 'foo'
 178     p6meta.'add_method'('bar', $P0, 'to'=>jklproto)
 179     jklobj = new ['Foo';'JKL']
 180     $S0 = jklobj.'bar'()
 181     is($S0, 'ABC::foo', 'JKL.bar via add_method')
 182
 183     .local pmc hll_tests
 184     hll_tests = get_root_global ['myhll'], 'hll_tests'
 185     hll_tests()
 186
 187     .local pmc omgproto, omgprotoexport
 188     $P0 = p6meta.'new_class'('OMG::Lol')
 189     omgproto = get_hll_global ['OMG'], 'Lol'
 190     omgprotoexport = get_hll_global ['OMG';'EXPORT';'ALL'], 'Lol'
 191     is_same(omgproto,omgprotoexport,'protoobject added to ["EXPORT";"ALL"] subnamespace')
 192
 193     .return ()
 194 .end
 195
 196
 197 =head1 SUBROUTINES
 198
 199 =over 4
 200
 201 =item p6obj_tests(proto, class [, options])
 202
 203 Run a sequence of standard tests on a protoobject.  As part of the
 204 tests it also creates an instance using the C<.new> method of
 205 C<proto>, does some tests on the instance, and returns it.
 206 The available options include:
 207
 208     shortname    the name expected from stringifying the protoobject
 209     typename     the name expected from C<typeof>
 210     isa          a list of classes to test for "isa" semantics
 211
 212 =cut
 213
 214 .sub 'p6obj_tests'
 215     .param pmc proto
 216     .param pmc class
 217     .param pmc options         :slurpy :named
 218
 219     .local string classname, shortname, typename
 220     classname = hash_default(options, 'classname', class)
 221     shortname = hash_default(options, 'shortname', classname)
 222     typename =  hash_default(options, 'typename',  classname)
 223
 224     .local pmc who
 225     null who
 226     who = hash_default(options, 'who', who)
 227
 228     shortname = concat shortname, '()'
 229
 230     .local string msg
 231
 232     isa_ok(proto, 'P6protoobject', classname)
 233
 234     msg = 'concat'('< get_string ', classname, ' > eq "', shortname, '"')
 235     $S0 = proto
 236     is($S0, shortname, msg)
 237
 238     msg = 'concat'('< typeof ', classname, ' > eq "', typename, '"')
 239     $S0 = typeof proto
 240     is($S0, typename, msg)
 241
 242     msg = 'concat'('< defined ', classname, ' >')
 243     $I0 = defined proto
 244     nok($I0, msg)
 245
 246     msg = 'concat'(classname, '.WHAT identity')
 247     $P0 = proto.'WHAT'()
 248     is_same(proto, $P0, msg)
 249
 250     .local pmc meta
 251     msg = 'concat'(classname, '.HOW')
 252     meta = proto.'HOW'()
 253     isa_ok(meta, 'P6metaclass', msg)
 254
 255     msg = 'concat'(classname, '.WHERE')
 256     $P0 = proto.'WHERE'()
 257     $I0 = get_addr proto
 258     is($I0, $P0, msg)
 259
 260     if null who goto proto_who_done
 261     msg = 'concat'(classname, '.WHO')
 262     $P0 = proto.'WHO'()
 263     is_same($P0, who, msg)
 264   proto_who_done:
 265
 266   obj_tests:
 267     .local pmc obj, objmeta
 268     ##  skip object creation and tests for P6metaclass
 269     null obj
 270     $I0 = isa proto, 'P6metaclass'
 271     if $I0 goto obj_done
 272
 273     .local string objname
 274     objname = 'concat'(shortname, '_obj')
 275
 276     obj = proto.'new'()
 277     isa_nok(obj, 'P6Protoobject', objname)
 278
 279     msg = 'concat'(objname, '.WHAT =:= ', classname)
 280     $P0 = obj.'WHAT'()
 281     is_same($P0, proto, msg)
 282
 283     msg = 'concat'(objname, '.HOW =:= ', classname, '.HOW')
 284     objmeta = obj.'HOW'()
 285     is_same(objmeta, meta, msg)
 286
 287     msg = 'concat'(objname, '.^isa(', classname, ')')
 288     $I0 = objmeta.'isa'(obj, proto)
 289     ok($I0, msg)
 290
 291     msg = 'concat'(objname, '.WHERE')
 292     $P0 = obj.'WHERE'()
 293     $I0 = get_addr obj
 294     is($I0, $P0, msg)
 295
 296     if null who goto obj_who_done
 297     msg = 'concat'(objname, '.WHO')
 298     $P0 = obj.'WHO'()
 299     is_same($P0, who, msg)
 300   obj_who_done:
 301
 302   obj_done:
 303
 304     ##  test 'isa' semantics
 305     .local pmc isalist
 306     $P0 = hash_default(options, 'isa', class)
 307     unless $P0 goto isa_done
 308     isalist = qw($P0)
 309     .local pmc isaiter, isatest
 310     isaiter = iter isalist
 311   isa_loop:
 312     unless isaiter goto isa_done
 313     isatest = shift isaiter
 314     isa_ok(proto, isatest, classname)
 315     msg = 'concat'(classname, '.^isa("', isatest, '")')
 316     $I0 = meta.'isa'(proto, isatest)
 317     ok($I0, msg)
 318     if null obj goto isa_loop
 319     isa_ok(obj, isatest, objname)
 320     msg = 'concat'(objname, '.^isa("', isatest, '")')
 321     $I0 = meta.'isa'(obj, isatest)
 322     ok($I0, msg)
 323     goto isa_loop
 324   isa_done:
 325
 326     ## test 'can' semantics
 327     .local pmc canlist
 328     $P0 = hash_default(options, 'can', '')
 329     unless $P0 goto can_done
 330     canlist = qw($P0)
 331     .local pmc caniter
 332     .local string cantest
 333     caniter = iter canlist
 334   can_loop:
 335     unless caniter goto can_done
 336     cantest = shift caniter
 337     msg = 'concat'('< can ', classname, ', "', cantest, '" >')
 338     $I0 = can proto, cantest
 339     ok($I0, msg)
 340     msg = 'concat'(classname, '.^can("', cantest, '")')
 341     $I0 = meta.'can'(proto, cantest)
 342     ok($I0, msg)
 343     msg = 'concat'('< can ', objname, ', "', cantest, '" >')
 344     if null obj goto can_loop
 345     $I0 = can obj, cantest
 346     ok($I0, msg)
 347     msg = 'concat'(objname, '.^can("', cantest, '")')
 348     $I0 = meta.'can'(obj, cantest)
 349     ok($I0, msg)
 350     goto can_loop
 351   can_done:
 352
 353     .return (obj)
 354 .end
 355
 356 =item concat([args])
 357
 358 Concatenate several strings into a single string.
 359
 360 =cut
 361
 362 .sub 'concat'
 363     .param pmc args :slurpy
 364     $S0 = join '', args
 365     .return ($S0)
 366 .end
 367
 368 =item qw(value)
 369
 370 If C<value> is already an array of some sort, return it, otherwise
 371 split C<value> on spaces and return that.
 372
 373 =cut
 374
 375 .sub 'qw'
 376     .param pmc value
 377     $I0 = does value, 'array'
 378     if $I0 goto done
 379     $S0 = value
 380     value = split ' ', $S0
 381   done:
 382     .return (value)
 383 .end
 384
 385
 386 =item hash_default(hash, key, default)
 387
 388 Return the entry in C<hash[key]> if it exists, otherwise return C<default>.
 389
 390 =cut
 391
 392 .sub 'hash_default'
 393     .param pmc hash
 394     .param string key
 395     .param pmc value
 396     $I0 = exists hash[key]
 397     unless $I0 goto done
 398     value = hash[key]
 399   done:
 400     .return (value)
 401 .end
 402
 403 =item is_same(x, y, message)
 404
 405 Test for x and y being the same PMC.
 406
 407 =cut
 408
 409 .sub 'is_same'
 410     .param pmc x
 411     .param pmc y
 412     .param string msg
 413     $I0 = issame x, y
 414     ok($I0, msg)
 415 .end
 416
 417 =item isa_ok(object, class, objectname)
 418
 419 =item isa_ok(object, class, objectname)
 420
 421 Test if C<object> is/isn't an instance of C<class> as reported
 422 by the C<isa> opcode.  C<objectname> is used to generate the
 423 diagnostic message in output (i.e., it's not the actual
 424 diagnostic message).
 425
 426 =cut
 427
 428 .sub 'isa_ok'
 429     .param pmc obj
 430     .param pmc class
 431     .param string objectname
 432     $S0 = 'concat'('< isa ', objectname, ', "', class, '" >')
 433     $I0 = 0
 434     if null obj goto done
 435     $I0 = isa obj, class
 436   done:
 437     ok($I0, $S0)
 438 .end
 439
 440 .sub 'isa_nok'
 441     .param pmc obj
 442     .param pmc class
 443     .param string object_name
 444     $S0 = 'concat'('! < isa ', object_name, ', "', class, '" >')
 445     $I0 = 0
 446     if null obj goto done
 447     $I0 = isa obj, class
 448   done:
 449     nok($I0, $S0)
 450 .end
 451
 452
 453 .namespace ['ABC']
 454 .sub 'foo' :method :nsentry('foo')
 455     .return ('ABC::foo')
 456 .end
 457
 458 .namespace ['GHI']
 459 .sub 'foo' :method
 460     .return ('GHI::foo')
 461 .end
 462
 463 .namespace ['MyInt']
 464 .sub 'foo' :method
 465     .return ('MyInt::foo')
 466 .end
 467
 468 .namespace ['List']
 469 .sub 'foo' :method
 470     .return ('List::foo')
 471 .end
 472
 473 .namespace ['Foo';'JKL']
 474 .sub 'foo' :method
 475     .return ('Foo::JKL::foo')
 476 .end
 477
 478 .HLL 'myhll'
 479
 480 .sub 'hll_tests'
 481     .local pmc exports, curr_namespace, root_namespace
 482     curr_namespace = get_namespace
 483     root_namespace = get_root_namespace ['parrot']
 484     exports        = split ' ', 'plan diag ok nok is todo is_same isa_ok isa_nok p6obj_tests'
 485     root_namespace.'export_to'(curr_namespace, exports)
 486
 487     .local pmc p6meta
 488     p6meta = get_root_global ['parrot'], 'P6metaclass'
 489
 490     ##  build HLL class using namespace
 491     .local pmc xyzns, xyzproto, xyzobj
 492     xyzns = get_hll_namespace ['XYZ']
 493     $P0 = p6meta.'new_class'(xyzns)
 494     xyzproto = get_hll_global 'XYZ'
 495     is_same($P0, xyzproto, 'return from .new_class =:= XYZ')
 496     $P0 = get_root_global ['parrot'], 'XYZ'
 497     $I0 = isnull $P0
 498     ok($I0, ".new_class didn't store ['parrot'], 'XYZ'")
 499     p6obj_tests(xyzproto, 'XYZ', 'isa'=>'XYZ P6object', 'can'=>'foo', 'who'=>xyzns)
 500
 501     ##  build HLL class using name
 502     .local pmc wxyproto, wxyobj, wxyns
 503     $P0 = p6meta.'new_class'('WXY')
 504     wxyproto = get_hll_global 'WXY'
 505     wxyns = get_hll_namespace ['WXY']
 506     is_same($P0, wxyproto, 'return from .new_class =:= WXY')
 507     $P0 = get_root_global ['parrot'], 'WXY'
 508     $I0 = isnull $P0
 509     ok($I0, ".new_class didn't store ['parrot'], 'WXY'")
 510     p6obj_tests(wxyproto, 'WXY', 'isa'=>'WXY P6object', 'can'=>'foo', 'who'=>wxyns)
 511
 512     ## build a Parrotclass
 513     .local pmc vwx_nsarray, vwx_ns, vwx_parrotclass, vwx_proto
 514     vwx_nsarray = new 'ResizablePMCArray'
 515     push vwx_nsarray, 'VWX'
 516     vwx_ns = get_hll_namespace vwx_nsarray
 517     vwx_parrotclass = newclass vwx_ns
 518     vwx_proto = p6meta.'register'(vwx_parrotclass)
 519     p6obj_tests(vwx_proto, 'VWX', 'can'=>'foo', 'who'=>vwx_ns)
 520 .end
 521
 522 .namespace ['XYZ']
 523 .sub 'foo' :method
 524     .return ('XYZ::foo')
 525 .end
 526
 527 .namespace ['WXY']
 528 .sub 'foo' :method
 529     .return ('WXY::foo')
 530 .end
 531
 532 .namespace ['VWX']
 533 .sub 'foo' :method
 534     .return ('WXY::foo')
 535 .end
 536
 537 =back
 538
 539 =cut
 540
 541 # Local Variables:
 542 #   mode: pir
 543 #   fill-column: 100
 544 # End:
 545 # vim: expandtab shiftwidth=4 ft=pir: