t/oo/subclass.t

   1 #!./parrot
   2 # Copyright (C) 2007-2010, Parrot Foundation.
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 t/oo/subclass.t - Test OO subclassing (instantiation)
   8
   9 =head1 SYNOPSIS
  10
  11     % prove t/oo/subclass.t
  12
  13 =head1 DESCRIPTION
  14
  15 Tests OO features related to subclassing.
  16
  17 =cut
  18
  19 .include 'except_types.pasm'
  20
  21 .sub main :main
  22     .include 'test_more.pir'
  23
  24     plan(70)
  25
  26     instance_sub_class_from_class_object()
  27     manually_create_anon_class_object()
  28     manually_create_named_class_object()
  29     instance_from_class_object_method()
  30     instance_from_string_name()
  31     instance_from_string_register()
  32     instance_from_string_pmc_name()
  33     instance_from_key_name()
  34     instance_from_key_pmc_name()
  35     instance_from_class_object_init()
  36     instance_from_string_name_init()
  37     instance_from_string_register_name_init()
  38     instance_from_string_pmc_name_init()
  39     instance_from_key_name_init()
  40     subclasses_within_other_namespaces()
  41     call_inherited_method()
  42     call_inherited_init_vtable_overrides()
  43     set_inherited_attribute_by_parent_key()
  44     can_not_add_same_parent_twice()
  45     can_not_be_own_parent()
  46     can_not_be_own_ancestor()
  47     no_loop_in_hierarchy()
  48     subclass_does_what_parent_does()
  49 .end
  50
  51 .sub instance_sub_class_from_class_object
  52     #instance_subclass_from_class_object
  53     .local pmc parent_class, foo_class, foo_object
  54
  55     parent_class = newclass "PreFoo"
  56     foo_class = subclass parent_class, "Foo"
  57
  58     $S1 = typeof foo_class
  59     is ($S1, 'Class', 'created Foo as subclass of Pre')
  60
  61     $I3 = isa foo_class, "Class"
  62     ok ($I3, 'Foo isa Class')
  63
  64     foo_object = new foo_class
  65     $S1 = typeof foo_object
  66     is ($S1, 'Foo', 'instance is typeof Foo')
  67
  68     $I3 = isa foo_object, "Foo"
  69     ok ($I3, 'instance Foo isa Foo')
  70
  71     $I3 = isa foo_object, "Object"
  72     ok ($I3, 'instance Foo isa Object')
  73
  74 .end
  75
  76 .sub manually_create_anon_class_object
  77     # manually create anonymous class object' );
  78     .local pmc parent_class, class_init_args, parent_list
  79     .local pmc anon_class, anon_object
  80
  81     parent_class = new "Class"
  82     class_init_args = new 'Hash'
  83     parent_list = new 'ResizablePMCArray'
  84
  85     push parent_list, parent_class
  86     class_init_args['parents'] = parent_list
  87
  88     anon_class = new "Class", class_init_args
  89     $S1 = typeof anon_class
  90     is ($S1, 'Class', 'create new instance of Class')
  91
  92     $I3 = isa anon_class, "Class"
  93     ok ($I3, 'new instance isa Class')
  94
  95     anon_object = new anon_class
  96
  97     $S1 = typeof anon_object
  98     is ($S1, '', 'instance has typeof empty string')
  99
 100     $I3 = isa anon_object, "Foo"
 101     nok ($I3, 'instance not isa Foo')
 102
 103     $I3 = isa anon_object, parent_class
 104     ok ($I3, 'instance isa parent')
 105
 106     $I3 = isa anon_object, "Object"
 107     ok ($I3, 'instance isa Object')
 108
 109 .end
 110
 111 .sub manually_create_named_class_object
 112     # manually create named class object
 113     .local pmc parent_class, class_init_args, parent_list
 114     .local pmc bar_class, bar_object
 115     parent_class = new "Class"
 116
 117     class_init_args = new 'Hash'
 118     parent_list = new 'ResizablePMCArray'
 119     push parent_list, parent_class
 120     class_init_args['parents'] = parent_list
 121
 122     bar_class = new "Class", class_init_args
 123     bar_class.'name'("Bar")
 124
 125     $S1 = typeof bar_class
 126     is ($S1, 'Class', 'create new instance of Class')
 127
 128     $I3 = isa bar_class, "Class"
 129     ok ($I3, 'instance isa Class')
 130
 131     bar_object = new bar_class
 132     $S1 = typeof bar_object
 133     is ($S1, 'Bar', 'instance is typeof Bar')
 134
 135     $I3 = isa bar_object, "Bar"
 136     ok ($I3, 'instance isa Bar')
 137
 138     $I3 = isa bar_object, "Object"
 139     ok ($I3, 'instance isa Object')
 140
 141 .end
 142
 143 .sub instance_from_class_object_method
 144     # instantiate from class object method
 145     .local pmc parent_class, baz_class, baz_object
 146     parent_class = newclass "PreBaz"
 147     baz_class = subclass "PreBaz", "Baz"
 148     baz_object = baz_class.'new'()
 149
 150     $S1 = typeof baz_object
 151     is ($S1, "Baz", "instance is typeof Baz")
 152
 153     $I3 = isa baz_object, "Baz"
 154     ok ($I3, "instance isa Baz")
 155
 156     $I3 = isa baz_object, "Object"
 157     ok ($I3, "instance isa Object")
 158
 159 .end
 160
 161 .sub instance_from_string_name
 162     # instantiate from string name
 163     .local pmc parent_class, qux_class, qux_object
 164     parent_class = newclass "PreQux"
 165     qux_class = subclass "PreQux", "Qux"
 166     qux_object = new 'Qux'
 167
 168     $S1 = typeof qux_object
 169     is ($S1, 'Qux', 'instance is typeof Qux')
 170
 171     $I3 = isa qux_object, "Qux"
 172     ok ($I3, 'instance isa Qux')
 173
 174     $I3 = isa qux_object, "Object"
 175     ok ($I3, 'instance isa Object')
 176
 177 .end
 178
 179 .sub instance_from_string_register
 180     # instantiate from string register name
 181     .local pmc parent_class, quux_class, quux_object
 182     parent_class = newclass "PreQuux"
 183     quux_class = subclass "PreQuux", "Quux"
 184     $S1 = 'Quux'
 185     quux_object = new $S1
 186
 187     $S1 = typeof quux_object
 188     is ($S1, 'Quux', 'instance is typeof Quux')
 189
 190     $I3 = isa quux_object, "Quux"
 191     ok ($I3, 'instance isa Quux')
 192
 193     $I3 = isa quux_object, "Object"
 194     ok ($I3, 'instance isa Object')
 195
 196 .end
 197
 198 .sub instance_from_string_pmc_name
 199     # instantiate from string PMC name
 200     .local pmc parent_class, bongo_class, bongo_object
 201     parent_class = newclass "PreBongo"
 202     bongo_class = subclass "PreBongo", "Bongo"
 203     $P3 = new 'String'
 204     $P3 = 'Bongo'
 205     bongo_object = new $P3
 206
 207     $S1 = typeof bongo_object
 208     is ($S1, 'Bongo', 'instance is typof Bongo')
 209
 210     $I3 = isa bongo_object, "Bongo"
 211     ok ($I3, 'instance isa Bongo')
 212
 213     $I3 = isa bongo_object, "Object"
 214     ok ($I3, 'instance isa Object')
 215
 216 .end
 217
 218 .sub instance_from_key_name
 219     # instantiate from key name'
 220     .local pmc parent_class, foobar_class, foobar_object
 221     parent_class = newclass "Zot"
 222     foobar_class = subclass "Zot", ['Foo';'Bar']
 223     $S1 = typeof foobar_class
 224     is ($S1, 'Class', 'new class is typeof Class')
 225
 226     $I3 = isa foobar_class, "Class"
 227     ok ($I3, 'new class isa Class')
 228
 229     foobar_object = new ['Foo';'Bar']
 230
 231     $S1 = typeof foobar_object
 232     is ($S1, 'Foo;Bar', 'instance is typeof Foo;Bar')
 233
 234     $I3 = isa foobar_object, ['Foo';'Bar']
 235     ok ($I3, 'instance isa Foo;Bar')
 236
 237     $I3 = isa foobar_object, "Object"
 238     ok ($I3, 'instance isa Object')
 239
 240 .end
 241
 242 .sub instance_from_key_pmc_name
 243     # instantiate from key PMC name
 244     .local pmc parent_class, barbaz_class, barbaz_object
 245     parent_class = newclass "Snork"
 246     barbaz_class = subclass "Snork", ['Bar';'Baz']
 247     $S1 = typeof barbaz_class
 248     is ($S1, 'Class', 'new class is typeof Class')
 249
 250     $I3 = isa barbaz_class, "Class"
 251     ok ($I3, 'new class isa Class')
 252
 253     .local pmc kbarbaz, kbaz
 254     kbarbaz = new 'Key'
 255     kbarbaz = 'Bar'
 256     kbaz = new 'Key'
 257     kbaz = 'Baz'
 258     push kbarbaz, kbaz
 259     ok (1, 'set the value of a non-constant key PMC')
 260
 261     barbaz_object = new kbarbaz
 262
 263     $S1 = typeof barbaz_object
 264     is ($S1, 'Bar;Baz', 'instance is typeof Bar;Baz')
 265
 266     $I3 = isa barbaz_object, 'Snork'
 267     ok ($I3, 'instance isa Snork')
 268
 269     $I3 = isa barbaz_object, "Object"
 270     ok ($I3, 'instance isa Object')
 271
 272 .end
 273
 274 .sub instance_from_class_object_init
 275     # instantiate from class object with init
 276     .local pmc parent_class, bork_class, bork_object
 277     parent_class = newclass "Gork"
 278     bork_class = subclass "Gork", "Bork"
 279     addattribute bork_class, 'data'
 280     $P3 = new 'Hash'
 281     $P4 = new 'String'
 282     $P4 = "data for Gork\n"
 283     $P3['data'] = $P4
 284
 285     bork_object = new bork_class, $P3
 286
 287     $S1 = typeof bork_object
 288     is ($S1, 'Bork', 'instance is typeof Bork')
 289
 290     $I3 = isa bork_object, "Gork"
 291     ok ($I3, 'instance isa Gork')
 292
 293     $I3 = isa bork_object, "Object"
 294     ok ($I3, 'instance isa Object')
 295
 296     $P5 = getattribute bork_object, 'data'
 297     is ($P5, "data for Gork\n", 'read attribute data from instance of Bork')
 298
 299 .end
 300
 301 .sub instance_from_string_name_init
 302     # instantiate from string name with init
 303     .local pmc parent_class, boogle_class, boogle_object
 304     parent_class  = newclass "Froogle"
 305     boogle_class = subclass "Froogle", "Boogle"
 306     addattribute boogle_class, 'data'
 307     $P3 = new 'Hash'
 308     $P4 = new 'String'
 309     $P4 = "data for Boogle\n"
 310     $P3['data'] = $P4
 311
 312     boogle_object = new 'Boogle', $P3
 313
 314     $S1 = typeof boogle_object
 315     is ($S1, 'Boogle', 'instance is typeof Boogle')
 316
 317     $I3 = isa boogle_object, "Boogle"
 318     ok ($I3, 'instance isa Boogle')
 319
 320     $I3 = isa boogle_object, "Object"
 321     ok ($I3, 'instance isa Object')
 322
 323     $P5 = getattribute boogle_object, 'data'
 324     is ($P5, "data for Boogle\n", 'read attribute data from instance of Boogle')
 325
 326 .end
 327
 328 .sub instance_from_string_register_name_init
 329     # instantiate from string register name with init
 330     .local pmc parent_class, eek_class, eek_object
 331     parent_class = newclass "Ook"
 332     eek_class = subclass "Ook", "Eek"
 333     addattribute eek_class, 'data'
 334     $P3 = new 'Hash'
 335     $P4 = new 'String'
 336     $P4 = "data for Eek\n"
 337     $P3['data'] = $P4
 338
 339     $S1 = 'Eek'
 340     eek_object = new $S1, $P3
 341
 342     $S1 = typeof eek_object
 343     is ($S1, 'Eek', 'instance is typeof Eek')
 344
 345     $I3 = isa eek_object, "Eek"
 346     ok ($I3, 'instance isa Eek')
 347
 348     $I3 = isa eek_object, "Object"
 349     ok ($I3, 'instance isa Object')
 350
 351     $P5 = getattribute eek_object, 'data'
 352     is ($P5, "data for Eek\n", 'read attribute data from instance of Eek')
 353
 354 .end
 355 #
 356 #pir_output_is( <<'CODE', <<'OUT', 'instantiate from string PMC name with init' );
 357 .sub instance_from_string_pmc_name_init
 358     # instantiate from string PMC name with init
 359     .local pmc parent_class, wobble_class, wobble_object
 360     parent_class = newclass "Weeble"
 361     wobble_class = subclass "Weeble", "Wobble"
 362     addattribute wobble_class, 'data'
 363     $P3 = new 'Hash'
 364     $P4 = new 'String'
 365     $P4 = "data for Wobble\n"
 366     $P3['data'] = $P4
 367
 368     $P6 = new 'String'
 369     $P6 = 'Wobble'
 370     wobble_object = new $P6, $P3
 371
 372     $S1 = typeof wobble_object
 373     is ($S1, 'Wobble', 'instance is typeof Wobble')
 374
 375     $I3 = isa wobble_object, "Wobble"
 376     ok ($I3, 'instance isa Wobble')
 377
 378     $I3 = isa wobble_object, "Object"
 379     ok ($I3, 'instance isa Object')
 380
 381     $P5 = getattribute wobble_object, 'data'
 382     is ($P5, "data for Wobble\n", 'read attribute data from instance of Wobble')
 383 .end
 384
 385 .sub instance_from_key_name_init
 386     # instantiate from key name with init
 387     .local pmc parent_class, barfoo_class, barfoo_object
 388     parent_class = newclass "Zork"
 389     barfoo_class = subclass "Zork", ['Bar';'Foo']
 390     addattribute barfoo_class, 'data'
 391
 392     $P3 = new 'Hash'
 393     $P4 = new 'String'
 394     $P4 = "data for Bar;Foo\n"
 395     $P3['data'] = $P4
 396
 397     barfoo_object = new ['Bar';'Foo'], $P3
 398
 399     $S1 = typeof barfoo_object
 400     is ($S1, 'Bar;Foo', 'instance is typeof Bar;Foo')
 401
 402     $I3 = isa barfoo_object, 'Zork'
 403     ok ($I3, 'instance isa Zork')
 404
 405     $I3 = isa barfoo_object, "Object"
 406     ok ($I3, 'instance isa Object')
 407
 408     $P5 = getattribute barfoo_object, 'data'
 409     is ($P5, "data for Bar;Foo\n", 'read attribute data from instance of Bar;Foo')
 410 .end
 411
 412 .sub subclasses_within_other_namespaces
 413     # declare subclasses within other namespaces
 414     $P0 = newclass 'Tom'
 415     $P99 = subclass 'Tom', 'Dick'
 416     $P99 = subclass 'Tom', 'Harry'
 417
 418     $P1 = new 'Dick'
 419     $S1 = $P1.'name'()
 420     is ($S1, "Richard", 'calling method on Dick' )
 421 .end
 422
 423 .namespace [ 'Dick' ]
 424 .sub 'name' :method
 425     $P1 = new 'Harry'
 426     $S1 = $P1.'name'()
 427     is ($S1, "Harold", 'calling method on Harry from Namespace Dick')
 428     .return ("Richard")
 429 .end
 430
 431
 432 .namespace [ 'Harry' ]
 433 .sub 'name' :method
 434     .return ("Harold")
 435 .end
 436 .namespace []
 437
 438 .sub call_inherited_method
 439     # call inherited methods
 440     $P0 = newclass 'Bilbo'
 441     $P0 = subclass 'Bilbo', 'Frodo'
 442
 443     $P1 = new 'Frodo'
 444     $I1 = $P1.'is_hobbit'()
 445     ok ($I1, 'calling inherited method')
 446 .end
 447
 448 .namespace [ 'Bilbo' ]
 449 .sub 'is_hobbit' :method
 450     .return (1)
 451 .end
 452 .namespace []
 453
 454 .sub call_inherited_init_vtable_overrides
 455     # call inherited init vtable overrides
 456     $P0 = newclass 'Wombat'
 457     $P1 = subclass 'Wombat', 'Frog'
 458     addattribute $P0, 'storage'
 459     $P1 = new 'Frog'
 460     $I1 = $P1.'count_strings'()
 461     is ($I1, 3, 'correct array length in vtable overriden init method')
 462 .end
 463
 464 .namespace [ 'Frog' ]
 465 .sub 'init' :method :vtable
 466     self.'add_string'('first string')
 467     self.'add_string'('second string')
 468     self.'add_string'('third string')
 469 .end
 470
 471 .namespace [ 'Wombat' ]
 472 .sub 'init' :method :vtable
 473     $P1 = new 'ResizablePMCArray'
 474     setattribute self, 'storage', $P1
 475 .end
 476
 477 .sub 'add_string' :method
 478     .param string newstring
 479     $P1 = getattribute self, 'storage'
 480     push $P1, newstring
 481 .end
 482
 483 .sub 'count_strings' :method
 484     $P1 = getattribute self, 'storage'
 485     $S3 = $P1
 486     .return ($P1)
 487 .end
 488 .namespace []
 489
 490 .sub set_inherited_attribute_by_parent_key
 491     # set inherited attributes by parent key
 492     .local pmc parent_class, child_class, child_object
 493     parent_class = newclass 'Zolar'
 494     addattribute parent_class, 'storage'
 495     child_class = subclass parent_class, 'SonOfZolar'
 496     child_object = child_class.'new'()
 497     $P2 = getattribute child_object, 'storage'
 498     is ($P2,'storage attribute value', 'retrieve attribute vale')
 499 .end
 500
 501 .namespace [ 'SonOfZolar' ]
 502 .sub 'init' :method :vtable
 503     .local pmc newstring
 504     newstring = new 'String'
 505     newstring = 'storage attribute value'
 506     setattribute self, ['Zolar'], 'storage', newstring
 507 .end
 508 .namespace []
 509
 510 .sub can_not_add_same_parent_twice
 511     # the same parent can't be added twice
 512     .local pmc eh, parent_class, child_class
 513     parent_class = newclass 'Supervisor'
 514     child_class = newclass 'Employee'
 515
 516 try:
 517     eh = new 'ExceptionHandler'
 518     eh.'handle_types'(.EXCEPTION_INVALID_OPERATION)
 519     set_addr eh, catch
 520
 521     push_eh eh
 522     # attempt to add duplicate parent
 523     addparent child_class, parent_class
 524     addparent child_class, parent_class
 525     $I0 = 1 # addparent success flag
 526     goto finally
 527
 528 catch:
 529     $I0 = 0 # addparent failure flag
 530
 531 finally:
 532     pop_eh
 533     nok ($I0, 'attempt to duplicate parent throws exception')
 534 .end
 535
 536 .sub can_not_be_own_parent
 537     # can't be own parent
 538     .local pmc eh, parent_class
 539     parent_class = newclass 'Frob'
 540
 541 try:
 542     eh = new 'ExceptionHandler'
 543     eh.'handle_types'(.EXCEPTION_INVALID_OPERATION)
 544     set_addr eh, catch
 545
 546     push_eh eh
 547     # attempt to create inheritance loop
 548     addparent parent_class, parent_class
 549     $I0 = 1 # addparent success flag
 550     goto finally
 551
 552 catch:
 553     $I0 = 0 # addparent failure flag
 554
 555 finally:
 556     pop_eh
 557     nok ($I0, 'attempt to create inheritance loop throws exception')
 558 .end
 559
 560 .sub can_not_be_own_ancestor
 561     # can't be own grandparent
 562     .local pmc eh, parent_class, child_class
 563     parent_class = newclass 'Parent'
 564     child_class = subclass 'Parent', 'Child'
 565
 566 try:
 567     eh = new 'ExceptionHandler'
 568     eh.'handle_types'(.EXCEPTION_INVALID_OPERATION)
 569     set_addr eh, catch
 570
 571     push_eh eh
 572     # attempt to create inheritance loop
 573     addparent parent_class, child_class
 574     $I0 = 1 # addparent success flag
 575     goto finally
 576
 577 catch:
 578     $I0 = 0 # addparent failure flag
 579
 580 finally:
 581     pop_eh
 582     nok ($I0, 'attempt to create inheritance loop throws exception')
 583 .end
 584
 585 .sub no_loop_in_hierarchy
 586     # can't create loop in hierarchy
 587     .local pmc eh, mutt_class, jeff_class
 588     mutt_class = newclass 'Mutt'
 589     jeff_class = newclass 'Jeff'
 590
 591 try:
 592     eh = new 'ExceptionHandler'
 593     eh.'handle_types'(.EXCEPTION_INVALID_OPERATION)
 594     set_addr eh, catch
 595
 596     push_eh eh
 597     # attempt to create inheritance loop
 598     addparent jeff_class, mutt_class
 599     addparent mutt_class, jeff_class
 600     $I0 = 1 # addparent success flag
 601     goto finally
 602
 603 catch:
 604     $I0 = 0 # addparent failure flag
 605
 606 finally:
 607     pop_eh
 608     nok ($I0, 'attempt to create inheritance loop throws exception')
 609 .end
 610
 611 .sub subclass_does_what_parent_does
 612     # subclass should do what the parent does
 613     does_pmc()
 614     does_subclass()
 615 .end
 616
 617 .sub 'does_pmc'
 618     $P0 = get_class 'ResizablePMCArray'
 619     $I0 = does $P0, 'array'
 620     ok ($I0, 'PMC that provides array does array')
 621 .end
 622
 623 .sub 'does_subclass'
 624     $P0 = subclass 'ResizablePMCArray', 'List'
 625     $I0 = does $P0, 'array'
 626     ok ($I0, 'subclass of PMC that provides array does array')
 627 .end
 628
 629 # Local Variables:
 630 #   mode: pir
 631 #   fill-column: 100
 632 # End:
 633 # vim: expandtab shiftwidth=4 ft=pir: