1#!./parrot 2# Copyright (C) 2001-2010, Parrot Foundation. 3 4=head1 NAME 5 6t/oo/objects.t - Objects 7 8=head1 SYNOPSIS 9 10 % prove t/oo/objects.t 11 12=head1 DESCRIPTION 13 14Tests the object/class subsystem. 15 16=cut 17 18.sub main :main 19 .include 'test_more.pir' 20 .include "iglobals.pasm" 21 .include "interpinfo.pasm" 22 23 plan(191) 24 25 get_classname_from_class() 26 test_get_class() 27 test_isa() 28 does_scalar() 29 does_array() 30 new_object() 31 new_object__isa_test() 32 new_object__classname() 33 isa_subclass() 34 isa_subclass__objects() 35 test_addmethod() 36 test_addattribute() 37 addattribute_subclass() 38 addattribute_subclass__same_name() 39 set_and_get_object_attribs() 40 set_and_get_multiple_object_attribs() 41 attribute_values_are_specific_to_objects() 42 attribute_values_and_subclassing() 43 attribute_values_and_subclassing_2() 44 PMC_as_classes__overridden_mmd_methods() 45 typeof_class() 46 typeof_objects() 47 multiple_inheritance__with_attributes() 48 attributes_two_levels_of_inheritance() 49 class_op_test() 50 anon_subclass_has_no_name() 51 get_attrib_by_name() 52 get_attrib_by_name_subclass() 53 set_attrib_by_name_subclass() 54 PMC_as_classes() 55 PMC_as_classes__subclass() 56 PMC_as_classes__instantiate() 57 PMC_as_classes__methods() 58 PMC_as_classes__mmd_methods() 59 PMC_as_classes__derived_1() 60 PMC_as_classes__derived_2() 61 PMC_as_classes__derived_3() 62 subclassing_Class() 63 namespace_vs_name() 64 multiple_anon_classes() 65 subclassed_Integer_bug() 66 equality_of_subclassed_Integer() 67 short_name_attributes() 68 init_with_and_without_arg() 69 newclass_bracket_parsing() 70 verify_namespace_types() 71 verify_data_type() 72 new_keyed() 73 new_keyed_2() 74 new_keyed_3() 75 subclass_keyed() 76 test_class_name_multipart_name() 77 test_get_class_multipart_name() 78 isa_bug() 79 new_nested_ordering() 80 vtable_override_once_removed() 81 vtable_fails_for_subclasses_of_core_classes() 82 super___init_called_twice() 83 using_class_object_from_typeof_op_with_new() 84 setting_non_existent_attribute() 85 setting_non_existent_attribute_by_name() 86 getting_null_attribute() 87 getting_non_existent_attribute() 88 addparent_exceptions_1() 89 addparent_exceptions_2() 90 subclassing_a_non_existent_class() 91 anon_subclass_of_non_existent_class() 92 addattribute_duplicate() 93 wrong_way_to_create_new_objects() 94 attribute_values__subclassing_access_meths() 95 attribute_values__inherited_access_meths() 96 97 # END_OF_TESTS 98.end 99 100.sub get_classname_from_class 101 newclass $P1, "Foo5" 102 set $S0, $P1 103 is( $S0, "Foo5", "got classname Foo5" ) 104 105 subclass $P2, $P1, "Bar5" 106 set $S1, $P2 107 is( $S1, "Bar5", "got subclass Bar5" ) 108 109 subclass $P3, "Foo5", "Baz5" 110 set $S2, $P3 111 is( $S2, "Baz5", "got subclass Baz5" ) 112.end 113 114.sub test_get_class 115 newclass $P1, "Foo6" 116 get_class $P2, "Foo6" 117 set $S2, $P2 118 is( $S2, "Foo6", 'get_class for Foo6' ) 119 120 subclass $P3, $P1, "FooBar6" 121 get_class $P4, "FooBar6" 122 set $S4, $P4 123 is( $S4, 'FooBar6', 'get_class for FooBar6' ) 124 125 get_class $P3, "NoSuch6" 126 isnull $I0, $P3 127 ok( $I0, "no class for 'NoSuch6'" ) 128.end 129 130.sub test_isa 131 new $P1, ['Boolean'] 132 133 isa $I0, $P1, "Boolean" 134 is( $I0, 1, 'Boolean isa Boolean' ) 135 136 isa $I0, $P1, "Bool" 137 is( $I0, 0, 'Boolean !isa Bool' ) 138 139 isa $I0, $P1, "scalar" 140 is( $I0, 1, 'Boolean isa scalar' ) 141 142 isa $I0, $P1, "calar" 143 is( $I0, 0, 'Boolean !isa calar' ) 144 145 isa $I0, $P1, " " 146 is( $I0, 0, 'Boolean !isa " "' ) 147 148 isa $I0, $P1, "" 149 is( $I0, 0, 'Boolean !isa ""' ) 150 151 null $S0 152 isa $I0, $P1, $S0 153 is( $I0, 0, 'Boolean !isa null $S0' ) 154 155 set $S0, "scalar" 156 isa $I0, $P1, $S0 157 is( $I0, 1, 'Boolean isa scalar $S0' ) 158.end 159 160.sub does_scalar 161 new $P1, ['Boolean'] 162 163 does $I0, $P1, "Boolean" 164 is( $I0, 0, 'Boolean !does Boolean' ) 165 166 does $I0, $P1, "Bool" 167 is( $I0, 0, 'Boolean !does Bool' ) 168 169 does $I0, $P1, "scalar" 170 is( $I0, 1, 'Boolean does scalar' ) 171.end 172 173.sub does_array 174 new $P1, ['OrderedHash'] 175 176 does $I0, $P1, "Boolean" 177 is( $I0, 0, 'OrderedHash !does Boolean' ) 178 179 does $I0, $P1, "Bool" 180 is( $I0, 0, 'OrderedHash !does Bool' ) 181 182 does $I0, $P1, "hash" 183 is( $I0, 1, 'OrderedHash does hash' ) 184 185 does $I0, $P1, "array" 186 is( $I0, 1, 'OrderedHash does array' ) 187.end 188 189.sub new_object 190 newclass $P1, "Foo7" 191 new $P2, "Foo7" 192 ok( 1, 'created new object from Foo7 class' ) 193.end 194 195.sub new_object__isa_test 196 newclass $P1, "Foo8" 197 new $P2, $P1 198 ok( 1, 'created new object from Foo8 class' ) 199 200 isa $I0, $P2, "Foo8" 201 ok( $I0, 'new object isa Foo8' ) 202.end 203 204.sub new_object__classname 205 newclass $P1, "Foo9" 206 new $P2, $P1 207 set $S0, $P1 # class 208 is( $S0, "Foo9", 'new object from Foo9 class as a string is Foo9' ) 209 210 typeof $S0, $P2 # object 211 is( $S0, 'Foo9', 'typeof obj is Foo9' ) 212 213 class $P3, $P1 214 set $S0, $P1 # class 215 is( $S0, 'Foo9', 'class of obj is Foo9' ) 216 217 typeof $S0, $P2 # object 218 is( $S0, 'Foo9', 'typeof obj is Foo9' ) 219 220.end 221 222.sub isa_subclass 223 newclass $P1, "Foo10" 224 subclass $P2, $P1, "Bar10" 225 226 isa_ok( $P2, "Foo10", 'newclass isa Foo10' ) 227 isa_ok( $P2, "Bar10", 'new subclass isa Bar10' ) 228 isa_ok( $P2, "Foo10", 'new subclass isa parent' ) 229 isa_ok( $P2, "Class", 'new subclass isa Class' ) 230 231 isa $I0, $P2, "Object" 232 is( $I0, 0, 'new subclass !isa Object' ) 233.end 234 235.sub isa_subclass__objects 236 newclass $P3, "Foo30" 237 subclass $P4, $P3, "Bar30" 238 $P1 = $P3.'new'() 239 $P2 = $P4.'new'() 240 241 isa_ok( $P1, "Foo30", 'obj isa its class' ) 242 isa_ok( $P2, "Bar30", 'obj isa its class' ) 243 isa_ok( $P2, "Foo30", 'obj isa its parent class' ) 244 isa_ok( $P2, "Object", 'obj isa Object' ) 245 isa_ok( $P2, "Class", 'obj isa Class' ) 246.end 247 248.sub test_addmethod 249 newclass $P0, 'Foo31' 250 $P2 = get_hll_global 'sayFoo31' 251 252 # add a method BEFORE creating a Foo object 253 addmethod $P0, 'foo31', $P2 254 $P1 = new 'Foo31' 255 $P1.'foo31'() 256 257 # get a method from some other namespace 258 $P2 = get_hll_global ['Bar31'], 'sayBar31' 259 260 # add a method AFTER creating the object 261 addmethod $P0, 'bar31', $P2 262 $P1.'bar31'() 263.end 264 265.sub sayFoo31 266 ok( 1, 'called method added before creating obj' ) 267.end 268 269.namespace ['Bar31'] 270.sub sayBar31 271 ok( 1, 'called method added after created obj' ) 272.end 273 274.namespace [] # Reset to root namespace for next test 275 276.sub test_addattribute 277 newclass $P1, "Foo11" 278 279 addattribute $P1, "foo_i" 280 ok( 1, 'addattribute did not blow up' ) 281 282 set $S0, $P1 283 is( $S0, "Foo11", '$P1 is still the same class as PMC' ) 284 285 # Check that we can add multiple attributes 286 set $I0, 0 287l1: 288 set $S0, $I0 289 addattribute $P1, $S0 290 inc $I0 291 lt $I0, 1000, l1 292 ok( 1, 'addattribute 1000x without blow up' ) 293.end 294 295.sub addattribute_subclass 296 newclass $P1, "Foo12" 297 addattribute $P1, "foo_i" 298 ok( 1, 'addattribute to Foo12' ) 299 300 subclass $P2, $P1, "Bar12" 301 addattribute $P2, "bar_i" 302 ok( 1, 'addattribute to subclass of Foo12' ) 303.end 304 305.sub addattribute_subclass__same_name 306 newclass $P1, "Foo32" 307 addattribute $P1, "i" 308 addattribute $P1, "j" 309 310 subclass $P2, $P1, "Bar32" 311 addattribute $P2, "j" 312 addattribute $P2, "k" 313 314 ok( 1, 'created class and subclass and added attributes' ) 315 316 .local pmc o 317 o = $P2.'new'() 318 $P0 = getattribute o, 'i' 319 is( $P0, 'Foo32.i', 'parent attrib initialized in init' ) 320 $P0 = getattribute o, ['Foo32'], 'j' 321 is( $P0, 'Foo32.j', 'parent attrib initialized in init' ) 322 $P0 = getattribute o, ['Bar32'], 'j' 323 is( $P0, 'Bar32.j', 'subclass attrib initialized in init' ) 324 $P0 = getattribute o, 'k' 325 is( $P0, 'Bar32.k', 'subclass attrib initialized in init' ) 326 327 $P0 = getattribute o, 'i' 328 is( $P0, 'Foo32.i', 'parent attrib init-ed' ) 329 $P0 = getattribute o, ['Foo32'], "j" 330 is( $P0, 'Foo32.j', 'parent attrib init-ed' ) 331 $P0 = getattribute o, 'j' 332 is( $P0, 'Bar32.j', 'subclass attrib returned over parent' ) 333 $P0 = getattribute o, 'k' 334 is( $P0, 'Bar32.k', 'subclass attrib init-ed' ) 335.end 336 337.namespace ['Bar32'] 338 339.sub init :vtable :method 340 $P0 = new ['String'] 341 $P0 = 'Foo32.i' 342 setattribute self, ['Foo32'], "i", $P0 343 $P0 = new ['String'] 344 $P0 = 'Foo32.j' 345 setattribute self, ["Foo32"], "j", $P0 346 $P0 = new ['String'] 347 $P0 = 'Bar32.j' 348 setattribute self, ["Bar32"], "j", $P0 349 $P0 = new ['String'] 350 $P0 = 'Bar32.k' 351 setattribute self, ["Bar32"], "k", $P0 352.end 353 354.namespace [] # Reset to root namespace for next test 355 356.sub set_and_get_object_attribs 357 newclass $P1, "Foo13" 358 addattribute $P1, "i" 359 new $P2, $P1 360 361 new $P3, ['Integer'] 362 set $P3, 1024 363 setattribute $P2, "i", $P3 364 365 new $P4, ['Integer'] 366 getattribute $P4, $P2, "i" 367 368 is( $P4, 1024, 'set/get Integer attribute' ) 369.end 370 371.sub set_and_get_multiple_object_attribs 372 newclass $P1, "Foo14" 373 addattribute $P1, "i" 374 addattribute $P1, "j" 375 new $P2, "Foo14" 376 377 new $P3, ['Integer'] 378 set $P3, 4201 379 new $P4, ['Hash'] 380 set $P4["Key"], "Value" 381 382 setattribute $P2, "i", $P3 383 setattribute $P2, "j", $P4 384 385 getattribute $P5, $P2, "i" 386 is( $P5, '4201', 'set/get Integer attribute' ) 387 388 getattribute $P6, $P2, "j" 389 set $S0, $P6["Key"] 390 is( $S0, 'Value', 'set/get Hash attribute on same obj' ) 391.end 392 393.sub attribute_values_are_specific_to_objects 394 newclass $P1, "Foo15" 395 addattribute $P1, "i" 396 new $P2, $P1 397 new $P3, $P1 398 399 new $P4, ['Integer'] 400 set $P4, 100 401 setattribute $P2, "i", $P4 402 new $P5, ['String'] 403 set $P5, "One hundred" 404 setattribute $P3, "i", $P5 405 406 getattribute $P6, $P2, "i" 407 is( $P6, 100, 'attribute value on 1st object is specific to obj' ) 408 409 getattribute $P6, $P3, "i" 410 is( $P6, 'One hundred', 'attribute value on 2nd obj is specific to obj' ) 411.end 412 413.sub attribute_values_and_subclassing 414 newclass $P1, "Foo16" 415 addattribute $P1, "i" 416 addattribute $P1, "j" 417 subclass $P2, $P1, "Bar16" 418 addattribute $P2, "k" 419 addattribute $P2, "l" 420 421 new $P2, "Bar16" 422 new $P3, "Bar16" 423 424 # Note that setattribute holds the actual PMC, not a copy, so 425 # in this test both attributes get the PMC from $P4, and should 426 # both have the same value, despite the C<inc>. 427 new $P4, ['Integer'] 428 set $P4, 10 429 setattribute $P2, "i", $P4 430 inc $P4 431 setattribute $P2, "j", $P4 432 433 new $P5, ['Integer'] 434 set $P5, 100 435 setattribute $P3, "i", $P5 436 inc $P5 437 setattribute $P3, "j", $P5 438 439 getattribute $P6, $P2, "i" 440 is( $P6, 11, 'setattrib with a PMC holds actual PMC not copy' ) 441 442 getattribute $P6, $P2, "j" 443 is( $P6, 11, '...so changes to the PMC appear through the attrib' ) 444 445 getattribute $P6, $P3, "i" 446 is( $P6, 101, '...and second test on new objects' ) 447 448 getattribute $P6, $P3, "j" 449 is( $P6, 101, '...should have same result' ) 450.end 451 452.sub attribute_values_and_subclassing_2 453 newclass $P1, "Foo17" 454 # must add attributes before object instantiation 455 addattribute $P1, ".i" 456 addattribute $P1, ".j" 457 458 subclass $P2, $P1, "Bar17" 459 addattribute $P2, ".k" 460 addattribute $P2, ".l" 461 462 # subclass is preferred for the SI case over 463 # newclass $P2, "Bar" 464 # addattrib ... 465 # addparent $P2, $P1 466 # which is suitable for adding multiple parents to one class 467 468 # instantiate a Bar object 469 new $P3, "Bar17" 470 471 # Set the attribute values 472 new $P10, ['String'] # set attribute values 473 set $P10, "i" # attribute slots have reference semantics 474 setattribute $P3, ".i", $P10 # so always put new PMCs in 475 # if you have unique values 476 new $P10, ['String'] 477 set $P10, "j" 478 setattribute $P3, ".j", $P10 479 480 new $P10, ['String'] 481 set $P10, "k" 482 setattribute $P3, ".k", $P10 483 484 new $P10, ['String'] 485 set $P10, "l" 486 setattribute $P3, ".l", $P10 487 488 # retrieve attribs 489 getattribute $P11, $P3, ".i" 490 is( $P11, "i", 'string attribute get/set on parent' ) 491 492 getattribute $P11, $P3, ".j" 493 is( $P11, "j", 'string attribute get/set on parent' ) 494 495 getattribute $P11, $P3, ".k" 496 is( $P11, "k", 'string attribute get/set on subclass' ) 497 498 getattribute $P11, $P3, ".l" 499 is( $P11, "l", 'string attribute get/set on subclass' ) 500.end 501 502.sub PMC_as_classes__overridden_mmd_methods 503 .local pmc myint, i, j, k 504 505 get_class $P0, "Integer" 506 subclass myint, $P0, "MyInt1" 507 508 i = new 'MyInt1' 509 j = new 'MyInt1' 510 k = new 'MyInt1' 511 i = 6 512 j = 7 513 k = i + j 514 515 is( k, 13, 'added two MyInt1' ) 516 517 j = new ['Integer'] 518 j = 100 519 k = i + j 520 521 is( k, 106, 'added MyInt1 and an Integer' ) 522.end 523 524.namespace ["MyInt1"] 525 526.sub add :multi(MyInt1, MyInt1, MyInt1) 527 .param pmc self 528 .param pmc right 529 .param pmc dest 530 ok( 1, 'in the add method' ) 531 $P0 = getattribute self, ['Integer'], "proxy" 532 $I0 = $P0 533 $I1 = right 534 $I2 = $I0 + $I1 535 dest = $I2 536 .return(dest) 537.end 538 539.namespace [] # Reset to root namespace for next test 540 541.sub typeof_class 542 newclass $P0, "Foo21" 543 typeof $S0, $P0 544 is( $S0, "Class", 'typeof for a Class PMC is "Class"' ) 545.end 546 547.sub typeof_objects 548 newclass $P0, "A" 549 newclass $P1, "B" 550 551 new $P0, ['A'] 552 new $P1, ['B'] 553 554 typeof $S0, $P0 555 typeof $S1, $P1 556 557 is( $S0, 'A', 'typeof object of class A is "A"' ) 558 is( $S1, 'B', 'typeof object of class B is "B"' ) 559.end 560 561.sub multiple_inheritance__with_attributes 562 newclass $P1, "Star" 563 addattribute $P1, "Spectral Type" 564 565 newclass $P2, "Company" 566 addattribute $P2, "Annual Profit" 567 568 subclass $P3, $P1, "Sun" 569 addparent $P3, $P2 570 571 new $P4, ['Sun'] 572 573 new $P5, ['String'] 574 set $P5, "G" 575 setattribute $P4, "Spectral Type", $P5 576 577 new $P6, ['String'] 578 set $P6, "$100,000,000" 579 setattribute $P4, "Annual Profit", $P6 580 581 getattribute $P7, $P4, "Spectral Type" 582 is( $P7, 'G', 'direct parents attribute' ) 583 584 getattribute $P8, $P4, "Annual Profit" 585 is( $P8, '$100,000,000', "addparent's attribute" ) 586.end 587 588.sub attributes_two_levels_of_inheritance 589 newclass $P0, "Astronomical Object" 590 addattribute $P0, "Location" 591 592 subclass $P1, $P0, "Star2" 593 addattribute $P1, "Spectral Type" 594 595 newclass $P2, "Sun2" 596 addparent $P2, $P1 597 addparent $P2, $P0 598 599 new $P4, "Sun2" 600 601 new $P5, ['String'] 602 set $P5, "Taurus" 603 setattribute $P4, "Location", $P5 604 getattribute $P6, $P4, "Location" 605 is( $P6, 'Taurus', 'attributes with two levels of inheritance' ) 606.end 607 608.sub class_op_test 609 newclass $P0, "City1" 610 new $P1, "City1" 611 612 class $P2, $P1 613 set $S0, $P2 614 is( $S0, 'City1', 'class op works' ) 615.end 616 617.sub anon_subclass_has_no_name 618 newclass $P0, "City2" 619 subclass $P1, $P0 620 set $S0, $P1 621 is( $S0, '', 'anonymous subclass has no name' ) 622.end 623 624.sub get_attrib_by_name 625 newclass $P1, "Foo18" 626 addattribute $P1, "i" 627 new $P2, "Foo18" 628 new $P3, ['String'] 629 set $P3, "ok" 630 setattribute $P2, "i", $P3 631 632 getattribute $P4, $P2, ["Foo18"], "i" 633 is( $P4, 'ok', 'get attrib by name' ) 634.end 635 636.sub get_attrib_by_name_subclass 637 newclass $P0, "Bar19" 638 addattribute $P0, "j" 639 640 subclass $P1, $P0, "Foo19" 641 addattribute $P1, "i" 642 643 new $P2, "Foo19" 644 645 new $P3, ['String'] 646 set $P3, "foo i" 647 setattribute $P2, "i", $P3 648 649 new $P3, ['String'] 650 set $P3, "bar j" 651 setattribute $P2, "j", $P3 652 653 getattribute $P4, $P2, ["Foo19"], "i" 654 is( $P4, 'foo i', 'attribute from subclass get by name' ) 655 656 getattribute $P4, $P2, ["Bar19"], "j" 657 is( $P4, 'bar j', 'attribute from parent class get by name' ) 658.end 659 660.sub set_attrib_by_name_subclass 661 newclass $P0, "Bar20" 662 addattribute $P0, "j" 663 664 subclass $P1, $P0, "Foo20" 665 addattribute $P1, "i" 666 667 new $P2, "Foo20" 668 669 new $P3, ['String'] 670 set $P3, "foo i" 671 setattribute $P2, ["Foo20"], "i", $P3 672 673 new $P3, ['String'] 674 set $P3, "bar j" 675 setattribute $P2, ["Bar20"], "j", $P3 676 677 getattribute $P4, $P2, "i" 678 is( $P4, 'foo i', 'attribute from subclass set by name' ) 679 680 getattribute $P4, $P2, "j" 681 is( $P4, 'bar j', 'attribute from parent class set by name' ) 682.end 683 684.sub PMC_as_classes 685 get_class $P0, "Integer" 686 ok( 1, "get_class of Integer didn't croak" ) 687 688 get_class $P0, "Integer" 689 ok( 1, "get_class of Integer didn't croak second time" ) 690 691 typeof $S0, $P0 692 is( $S0, 'PMCProxy', 'typeof PMCProxy' ) 693.end 694 695.sub PMC_as_classes__subclass 696 .local pmc MyInt3 697 get_class $P0, "Integer" 698 ok( 1, "get_class on Integer didn't blow up" ) 699 700 subclass MyInt3, $P0, "MyInt3" 701 ok( 1, "subclassing didn't blow up" ) 702 703 $S0 = typeof MyInt3 704 is( $S0, 'Class', 'new subclass is typeof Class' ) 705 706 $I0 = isa MyInt3, "MyInt3" 707 ok( $I0, 'new subclass isa MyInt' ) 708 709 $I0 = isa MyInt3, "Integer" 710 ok( $I0, 'new subclass isa parent class' ) 711.end 712 713.sub PMC_as_classes__instantiate 714 .local pmc MyInt4 715 get_class $P0, "Integer" 716 ok( 1, 'able to get_class of Integer' ) 717 718 subclass MyInt4, $P0, "MyInt4" 719 addattribute MyInt4, ".i" 720 ok( 1, 'able to addattribute to subclass' ) 721 722 .local pmc i 723 i = new "MyInt4" 724 ok( 1, 'able to instantiate obj of subclass w/ attribute' ) 725.end 726 727.sub PMC_as_classes__methods 728 .local pmc MyInt5 729 get_class $P0, "Integer" 730 731 subclass MyInt5, $P0, "MyInt5" 732 addattribute MyInt5, "intval" 733 734 .local pmc i, i2 735 i = new "MyInt5" 736 i2 = new ['Integer'] 737 i2 = 43 738 739 i = 42 # set_integer is inherited from Integer 740 ok( 1, 'able to assign int to MyInt' ) 741 742 $I0 = i # get_integer is overridden below 743 is( $I0, 42, 'get_integer is overridden for MyInt5' ) 744 745 $S0 = i # get_string is overridden below 746 is( $S0, 'MyInt5(42)', 'get_string is overridden for MyInt5' ) 747.end 748 749.namespace ["MyInt5"] 750 751.sub set_integer_native :vtable :method 752 .param int new_value 753 $P1 = new ['Integer'] 754 $P1 = new_value 755 setattribute self, "intval", $P1 756.end 757 758.sub get_integer :vtable :method 759 $P0 = getattribute self, "intval" 760 $I0 = $P0 761 .return ($I0) 762.end 763 764.sub get_string :vtable :method 765 $P0 = getattribute self, "intval" 766 $I0 = $P0 767 $S1 = $I0 768 $S0 = "MyInt5(" 769 $S0 .= $S1 770 $S0 .= ")" 771 .return ($S0) 772.end 773 774.namespace [] # Reset to root namespace for next test 775 776.sub PMC_as_classes__mmd_methods 777 .local pmc MyInt6 778 get_class $P0, "Integer" 779 subclass MyInt6, $P0, "MyInt6" 780 .local pmc i 781 .local pmc j 782 .local pmc k 783 i = new "MyInt6" 784 j = new "MyInt6" 785 k = new "MyInt6" 786 i = 6 787 j = 7 788 k = i * j 789 $I0 = k 790 is( $I0, 42, 'MyInt6 defaults to Integer class for mult' ) 791 792 $S0 = k # get_string is overridden below 793 is( $S0, 'MyInt6(42)', 'get_string is overridden for MyInt6' ) 794.end 795 796.namespace ["MyInt6"] 797 798.sub get_string :vtable :method 799 $I0 = self # get_integer is not overridden 800 $S1 = $I0 801 $S0 = "MyInt6(" 802 $S0 .= $S1 803 $S0 .= ")" 804 .return ($S0) 805.end 806 807.namespace [] # Reset to root namespace for next test 808 809.sub PMC_as_classes__derived_1 810 .local pmc MyInt8 811 .local pmc MyInt8_2 812 get_class $P0, "Integer" 813 814 subclass MyInt8, $P0, "MyInt8" 815 addattribute MyInt8, 'intval' 816 get_class $P1, "MyInt8" 817 subclass MyInt8_2, $P1, "MyInt8_2" 818 819 .local pmc i 820 i = new "MyInt8_2" 821 $I0 = isa i, "Integer" 822 ok( $I0, 'obj isa grandparent (Integer)' ) 823 824 $I0 = isa i, "MyInt8" 825 ok( $I0, 'obj isa parent (MyInt8)' ) 826 827 $I0 = isa i, "MyInt8_2" 828 ok( $I0, 'obj isa its class (MyInt8_2)' ) 829 830 i = 42 # set_integer is overridden below 831 $I0 = i # get_integer is overridden below 832 is( $I0, 42, 'set/get_integer overridden' ) 833 834 $S0 = i # get_string is overridden below 835 is( $S0, 'MyInt8_2(42)', 'set/get_string overridden' ) 836.end 837 838.namespace ["MyInt8"] 839.sub 'set_integer_native' :vtable :method 840 .param int val 841 $P1 = new ['Integer'] 842 $P1 = val 843 setattribute self, "intval", $P1 844 .return () 845.end 846.sub get_integer :vtable :method 847 $P0 = getattribute self, 'intval' 848 $I0 = $P0 849 .return ($I0) 850.end 851.sub get_string :vtable :method 852 $P0 = getattribute self, 'intval' 853 $I0 = $P0 854 $S1 = $I0 855 $S0 = typeof self 856 $S0 .= "(" 857 $S0 .= $S1 858 $S0 .= ")" 859 .return ($S0) 860.end 861 862.namespace [] # Reset to root namespace for next test 863 864.sub PMC_as_classes__derived_2 865 .local pmc MyInt9 866 .local pmc MyInt9_2 867 get_class $P0, "Integer" 868 869 subclass MyInt9, $P0, "MyInt9" 870 addattribute MyInt9, 'intval' 871 get_class $P1, "MyInt9" 872 subclass MyInt9_2, $P1, "MyInt9_2" 873 874 .local pmc i 875 i = new "MyInt9_2" 876 $I0 = isa i, "Integer" 877 ok( $I0, 'obj isa grandparent (Integer)' ) 878 $I0 = isa i, "MyInt9" 879 ok( $I0, 'obj isa parent (MyInt9)' ) 880 $I0 = isa i, "MyInt9_2" 881 ok( $I0, 'obj isa its class (MyInt9_2)' ) 882 883 i = 42 # set_integer is overridden below 884 $I0 = i # get_integer is overridden below 885 is( $I0, 43, 'set/get_integer overridden' ) 886 887 $S0 = i # get_string is overridden below 888 is( $S0, 'MyInt9_2(42)', 'set/get_string overridden' ) 889.end 890 891.namespace ["MyInt9_2"] 892# subclassing methods from MyInt9 is ok 893# this one changes the value a bit 894.sub get_integer :vtable :method 895 $P0 = getattribute self, 'intval' 896 $I0 = $P0 897 inc $I0 # <<<<< 898 .return ($I0) 899.end 900.namespace ["MyInt9"] 901.sub 'set_integer_native' :vtable :method 902 .param int val 903 $P1 = new ['Integer'] 904 $P1 = val 905 setattribute self, "intval", $P1 906 .return () 907.end 908.sub get_integer :vtable :method 909 $P0 = getattribute self, 'intval' 910 $I0 = $P0 911 .return ($I0) 912.end 913.sub get_string :vtable :method 914 $P0 = getattribute self, 'intval' 915 $I0 = $P0 916 $S1 = $I0 917 $S0 = typeof self 918 $S0 .= "(" 919 $S0 .= $S1 920 $S0 .= ")" 921 .return ($S0) 922.end 923 924.namespace [] # Reset to root namespace for next test 925 926.sub PMC_as_classes__derived_3 927 .local pmc MyInt10 928 .local pmc MyInt10_2 929 get_class $P0, "Integer" 930 931 subclass MyInt10, $P0, "MyInt10" 932 addattribute MyInt10, 'intval' 933 get_class $P1, "MyInt10" 934 subclass MyInt10_2, $P1, "MyInt10_2" 935 936 .local pmc i 937 i = new "MyInt10_2" 938 $I0 = isa i, "Integer" 939 ok( $I0, 'obj isa grandparent (Integer)' ) 940 $I0 = isa i, "MyInt10" 941 ok( $I0, 'obj isa parent (MyInt10)' ) 942 $I0 = isa i, "MyInt10_2" 943 ok( $I0, 'obj isa its class (MyInt102)' ) 944 945 i = 42 # set_integer is overridden below 946 $I0 = i # get_integer is overridden below 947 is( $I0, 42, 'set/get_integer overridden' ) 948 949 $S0 = i # get_string is overridden below 950 is( $S0, 'MyInt10_2(42)', 'set/get_string overridden' ) 951.end 952 953.namespace ["MyInt10_2"] 954.sub get_integer :vtable :method 955 $P0 = getattribute self, 'intval' 956 $I0 = $P0 957 .return ($I0) 958.end 959.sub get_string :vtable :method 960 $P0 = getattribute self, 'intval' 961 $I0 = $P0 962 $S1 = $I0 963 $S0 = typeof self 964 $S0 .= "(" 965 $S0 .= $S1 966 $S0 .= ")" 967 .return ($S0) 968.end 969.namespace ['MyInt10'] 970.sub 'set_integer_native' :vtable :method 971 .param int val 972 $P1 = new ['Integer'] 973 $P1 = val 974 setattribute self, "intval", $P1 975 .return () 976.end 977 978.namespace [] # Reset to root namespace for next test 979 980.sub subclassing_Class 981 .local pmc cl 982 .local pmc parent 983 parent = get_class "Class" 984 cl = subclass parent, "Foo33" 985 ok( 1, 'able to subclass Class' ) 986 987 .local pmc o 988 o = new "Foo33" 989 ok( 1, 'able to instantiate subclass of Class' ) 990 991 $S0 = typeof o 992 is( $S0, 'Foo33', 'object returns correct class' ) 993.end 994 995.sub namespace_vs_name 996 .local pmc o, cl, f 997 newclass cl, "Foo34" 998 o = new "Foo34" 999 is( o, 'Foo34::get_string', 'found Foo34 namespace' ) 1000 1001 o = Foo34() 1002 is( o, 'Foo34', 'found global Foo34' ) 1003 1004 f = get_global "Foo34" 1005 o = f() 1006 is( o, 'Foo34', 'found global Foo34 explicitly' ) 1007 1008 f = get_global ["Foo34"], "Foo34" 1009 o = f() 1010 is( o, 'Foo34::Foo34', 'found method in Foo34 namespace' ) 1011.end 1012 1013.sub Foo34 1014 .return("Foo34") 1015.end 1016 1017.namespace [ "Foo34" ] 1018 1019.sub get_string :vtable :method 1020 .return("Foo34::get_string") 1021.end 1022 1023.sub Foo34 1024 .return("Foo34::Foo34") 1025.end 1026 1027.namespace [] # Reset to root namespace for next test 1028 1029.sub multiple_anon_classes 1030 newclass $P0, "City3" 1031 subclass $P1, $P0 1032 newclass $P2, "State3" 1033 subclass $P3, $P2 1034 ok( 1, "multiple anon classes didn't croak (bug #33103)" ) 1035.end 1036 1037.sub subclassed_Integer_bug 1038 .local pmc class 1039 .local pmc a 1040 .local pmc b 1041 1042 subclass class, "Integer", "LispInteger1" 1043 1044 a = new "LispInteger1" 1045 b = new "LispInteger1" 1046 1047 a = 1 1048 b = 1 1049 1050 set $S0, a 1051 is( $S0, '1', 'subclassed Integer is 1' ) 1052 set $S0, b 1053 is( $S0, '1', 'subclassed Integer is 1' ) 1054 1055 a = a * b 1056 set $S0, a 1057 is( $S0, '1', 'multiply and reassign to subclassed Integer is 1' ) 1058.end 1059 1060.sub equality_of_subclassed_Integer 1061 .local pmc class 1062 class = subclass "Integer", "LispInteger2" 1063 1064 .local pmc a 1065 a = new 'LispInteger2' 1066 a = 123 1067 1068 .local pmc b 1069 b = new 'LispInteger2' 1070 b = 123 1071 1072 $I0 = a == b 1073 ok( $I0, '123 is equal to 123' ) 1074 1075.end 1076 1077.sub short_name_attributes 1078 newclass $P1, "Foo22" 1079 addattribute $P1, "i" 1080 addattribute $P1, "j" 1081 1082 subclass $P2, $P1, "Bar22" 1083 addattribute $P2, "k" 1084 addattribute $P2, "l" 1085 1086 new $P2, "Bar22" 1087 1088 # set a bunch of attribs 1089 new $P4, ['Integer'] 1090 set $P4, 10 1091 setattribute $P2, "i", $P4 1092 1093 new $P4, ['Integer'] 1094 set $P4, 11 1095 setattribute $P2, "j", $P4 1096 1097 new $P4, ['Integer'] 1098 set $P4, 20 1099 setattribute $P2, "k", $P4 1100 1101 new $P4, ['Integer'] 1102 set $P4, 21 1103 setattribute $P2, "l", $P4 1104 1105 getattribute $P6, $P2, "i" 1106 is( $P6, 10, '"i" getattribute on parent class attrib' ) 1107 getattribute $P6, $P2, "j" 1108 is( $P6, 11, '"j" getattribute on parent class attrib' ) 1109 1110 getattribute $P6, $P2, "k" 1111 is( $P6, 20, '"k" getattribute on subclass attrib' ) 1112 getattribute $P6, $P2, "l" 1113 is( $P6, 21, '"l" getattribute on subclass attrib' ) 1114 1115 getattribute $P6, $P2, ["Foo22"], "i" 1116 is( $P6, 10, '["Foo22"], "i" getattribute on parent class attrib' ) 1117 getattribute $P6, $P2, ["Bar22"], "k" 1118 is( $P6, 20, '["Bar22"], "k" getattribute on subclass attrib' ) 1119.end 1120 1121.sub init_with_and_without_arg 1122 .local pmc cl, o, h, a 1123 cl = newclass "Foo35" 1124 addattribute cl, "a" 1125 o = cl.'new'() 1126 a = getattribute o, "a" 1127 is( a, 'ok 1', 'init without an arg' ) 1128 1129 h = new ['Hash'] 1130 $P0 = new ['String'] 1131 $P0 = "ok 2" 1132 h['a'] = $P0 1133 o = new cl, h 1134 a = getattribute o, "a" 1135 is( a, 'ok 2', 'init with an arg' ) 1136.end 1137 1138.namespace ["Foo35"] 1139.sub init_pmc :vtable :method 1140 .param pmc args 1141 $P0 = args['a'] 1142 setattribute self, 'a', $P0 1143 .return() 1144.end 1145.sub init :vtable :method 1146 $P0 = new ['String'] 1147 $P0 = "ok 1" 1148 setattribute self, 'a', $P0 1149.end 1150 1151.namespace [] # Reset to root namespace for next test 1152 1153.sub newclass_bracket_parsing 1154 newclass $P0, ['Foo23';'Bar23'] 1155 ok( 1, 'newclass created with brackets' ) 1156.end 1157 1158.sub verify_namespace_types 1159 newclass $P0, ['Foo24';'Bar24'] 1160 getinterp $P0 1161 set $P1, $P0[.IGLOBALS_CLASSNAME_HASH] 1162 typeof $S0, $P1 1163 is( $S0, 'NameSpace', 'namespace verified' ) 1164 1165 set $P2, $P1['Foo24'] 1166 typeof $S0, $P2 1167 is( $S0, 'NameSpace', 'namespace verified' ) 1168.end 1169 1170.sub verify_data_type 1171 newclass $P0, ['Foo25';'Bar25'] 1172 getinterp $P0 1173 set $P1, $P0[.IGLOBALS_CLASSNAME_HASH] 1174 set $P2, $P1['Foo25'] 1175 set $P3, $P2['Bar25'] 1176 1177 set $I0, $P3 1178 isgt $I0, $I0, 0 1179 ok( $I0, 'verified datatype > 0' ) 1180.end 1181 1182# Puts init in a namespace 1183.sub new_keyed 1184 .local pmc cl, o, p 1185 cl = newclass ['Foo36';'Bar36'] 1186 addattribute cl, "init_check" 1187 o = cl.'new'() 1188 ok( 1, 'obj successfully created' ) 1189 1190 p = getattribute o, "init_check" 1191 is( p, 999, "overridden init called") 1192.end 1193 1194.namespace ['Foo36';'Bar36'] 1195 1196.sub init :vtable :method 1197 .local pmc p 1198 p = new ['Integer'] 1199 p = 999 1200 setattribute self, "init_check", p 1201.end 1202 1203.namespace [] # revert to root for next test 1204 1205.sub new_keyed_2 1206 .local pmc c1, c2, o1, o2 1207 c1 = newclass ['Foo37';'Bar37'] 1208 c2 = newclass ['Foo37';'Fuz37'] 1209 o1 = c1.'new'() 1210 o2 = c2.'new'() 1211 ok( 1, 'objects created successfully' ) 1212.end 1213 1214.namespace ['Foo37';'Bar37'] 1215 1216.sub init :vtable :method 1217 ok( 1, '__init Bar37' ) 1218.end 1219 1220.namespace ['Foo37';'Fuz37'] 1221 1222.sub init :vtable :method 1223 ok( 1, '__init Fuz37' ) 1224.end 1225 1226.namespace [] # revert to root for next test 1227 1228.sub new_keyed_3 1229 .local pmc c1, c2, c3, o1, o2, o3 1230 c1 = newclass ['Foo38';'Bar38'] 1231 c2 = newclass ['Foo38';'Buz38'] 1232 c3 = newclass 'Foo38' 1233 o1 = new ['Foo38';'Bar38'] 1234 o2 = new ['Foo38';'Buz38'] 1235 o3 = new 'Foo38' 1236 ok( 1, 'objects created successfully' ) 1237.end 1238 1239.namespace ['Foo38';'Bar38'] 1240 1241.sub init :vtable :method 1242 ok( 1, '__init Bar38' ) 1243.end 1244 1245.namespace ['Foo38';'Buz38'] 1246 1247.sub init :vtable :method 1248 ok( 1, '__init Buz38' ) 1249.end 1250 1251.namespace ['Foo38'] 1252 1253.sub init :vtable :method 1254 ok( 1, '__init Foo38' ) 1255.end 1256 1257.namespace [] # revert to root for next test 1258 1259.sub subclass_keyed 1260 .local pmc base, o1, o2 1261 base = subclass 'Hash', ['Perl6-3'; 'PAST'; 'Node'] 1262 addattribute base, '$.source' # original source 1263 addattribute base, '$.pos' # offset position 1264 1265 $P0 = subclass base, ['Perl6-3'; 'PAST'; 'Sub'] 1266 $P0 = subclass base, ['Perl6-3'; 'PAST'; 'Stmt'] 1267 ok( 1, 'ok 1\n' ) 1268 1269 o1 = new ['Perl6-3'; 'PAST'; 'Sub'] 1270 o2 = new ['Perl6-3'; 'PAST'; 'Stmt'] 1271 ok( 1, 'objects created successfully' ) 1272.end 1273 1274.namespace ['Perl6-3'; 'PAST'; 'Stmt'] 1275 1276.sub init :vtable :method 1277 ok( 1, '__init Stmt' ) 1278.end 1279 1280.namespace ['Perl6-3'; 'PAST'; 'Sub'] 1281 1282.sub init :vtable :method 1283 ok( 1, '__init Sub' ) 1284.end 1285 1286.namespace [] # revert to root for next test 1287 1288.sub test_class_name_multipart_name 1289 .local pmc base, o1 1290 base = subclass 'Hash', ['Perl6'; 'PAST'; 'Node'] 1291 o1 = new base 1292 $S0 = typeof o1 1293 is( $S0, "Perl6;PAST;Node", "typeof returns object's class name" ) 1294.end 1295 1296.sub test_get_class_multipart_name 1297 .local pmc base, o1 1298 base = subclass 'Hash', ['Perl6a'; 'PAST'; 'Node'] 1299 $P0 = get_class ['Perl6a'; 'PAST'; 'Node'] 1300 o1 = new $P0 1301 $S0 = typeof o1 1302 is( $S0, 'Perl6a;PAST;Node', 'typeof returns objects created from get_class' ) 1303.end 1304 1305.sub isa_bug 1306 .local pmc base, o1, o2 1307 base = subclass 'Hash', ['Perl6b'; 'PAST'; 'Node'] 1308 $P0 = new [ 'Perl6b'; 'PAST'; 'Node' ] 1309 1310 $I0 = isa $P0, [ 'Perl6b'; 'PAST'; 'Node'] 1311 is( $I0, 1, 'obj isa the full class name' ) 1312 1313 $I0 = isa $P0, 'Hash' 1314 is( $I0, 1, 'obj isa the parent class' ) 1315 1316 $I0 = isa $P0, 'Perl6b' 1317 is( $I0, 0, 'obj !isa the first part of the class name' ) 1318.end 1319 1320.sub new_nested_ordering 1321 .local pmc c1, c2, o 1322 c1 = newclass ['Foo39'] 1323 c2 = newclass ['Foo39';'Bar39'] 1324 o = c2.'new'() 1325 ok( 1, 'objects created successfully' ) 1326.end 1327 1328.namespace ['Foo39'] 1329 1330.sub init :vtable :method 1331 ok( 0, '__init Foo39' ) # shouldn't be called 1332.end 1333 1334.namespace ['Foo39';'Bar39'] 1335 1336.sub init :vtable :method 1337 ok( 1, '__init Bar39' ) # should be called 1338.end 1339 1340.namespace [] # revert to root for next test 1341 1342.sub vtable_override_once_removed 1343 .local pmc base 1344 $P0 = get_class 'Integer' 1345 base = subclass $P0, 'Foo40' # create subclass 'Foo40' 1346 addattribute base, '@!capt' 1347 1348 $P0 = subclass 'Foo40', 'Bar40' # create subclass 'Bar40' 1349 $P1 = new 'Bar40' # create an instance of 'Bar40' 1350 1351 $S1 = $P1 # get its string representation 1352 is( $S1, 'ok bar', 'get_string overridden' ) 1353.end 1354 1355.namespace [ 'Bar40' ] 1356 1357.sub 'get_string' :vtable :method 1358 $S0 = 'ok bar' 1359 .return ($S0) 1360.end 1361 1362.namespace [] # revert to root for next test 1363 1364.sub vtable_fails_for_subclasses_of_core_classes 1365 $P0 = subclass 'Hash', 'Foo41' 1366 $P0 = subclass 'Hash', 'Bar41' 1367 1368 $P1 = new 'Foo41' 1369 $S1 = $P1 1370 is( $S1, 'Hello world', 'get_string :vtable :method' ) 1371 1372 $P1 = new 'Bar41' 1373 $S1 = $P1 1374 is( $S1, 'Hello world', 'get_string :method :vtable' ) 1375.end 1376 1377.namespace [ 'Foo41' ] 1378 1379.sub 'get_string' :vtable :method 1380 .return('Hello world') 1381.end 1382 1383.namespace [ 'Bar41' ] 1384 1385.sub 'get_string' :method :vtable 1386 .return('Hello world') 1387.end 1388 1389.namespace [] # revert to root for next test 1390 1391.sub super___init_called_twice 1392 $P0 = newclass 'Foo42' 1393 $P1 = subclass $P0, 'Bar42' 1394 addattribute $P1, 'i' 1395 1396 $P2 = $P1.'new'() 1397.end 1398 1399.namespace [ 'Foo42' ] 1400 1401.sub 'init' :vtable :method 1402 $P0 = getattribute self, 'i' 1403 isnull $I1, $P0 1404 ok( $I1, 'should be null' ) 1405 1406 $P1 = new ['Integer'] 1407 setattribute self, "i", $P1 # i won't be null if init called again 1408 .return () 1409.end 1410 1411.namespace [] # revert to root for next test 1412 1413.sub using_class_object_from_typeof_op_with_new 1414 $P0 = newclass [ "Monkey" ; "Banana" ] 1415 $P0 = $P0.'new'() 1416 $S0 = $P0."ook"() 1417 is( $S0, "Ook!", 'obj created from .new() class method' ) 1418 1419 $P2 = typeof $P0 1420 $P3 = new $P2 1421 $S0 = $P3."ook"() 1422 is( $S0, "Ook!", 'obj created from "new" called on result of typeof' ) 1423.end 1424 1425.namespace [ "Monkey" ; "Banana" ] 1426.sub ook :method 1427 $S1 = "Ook!" 1428 .return ($S1) 1429.end 1430 1431.namespace [] # revert to root for next test 1432 1433.macro exception_is ( M ) 1434 .local pmc exception 1435 .local string message 1436 .get_results (exception) 1437 1438 message = exception['message'] 1439 is( message, .M, .M ) 1440.endm 1441 1442.sub setting_non_existent_attribute 1443 newclass $P1, "Foo45" 1444 new $P2, $P1 1445 1446 new $P3, ['Integer'] 1447 push_eh handler 1448 setattribute $P2, "bar", $P3 1449 pop_eh 1450 ok(0, "'No such attribute' exception not thrown") 1451 goto end 1452handler: 1453 .exception_is( "No such attribute 'bar'" ) 1454end: 1455.end 1456 1457.sub setting_non_existent_attribute_by_name 1458 newclass $P1, "Foo47" 1459 new $P2, $P1 1460 1461 new $P3, ['Integer'] 1462 push_eh handler 1463 setattribute $P2, ["Foo47"], "no_such", $P3 1464 pop_eh 1465 ok(0, "'No such attribute' exception not thrown") 1466 goto end 1467handler: 1468 .exception_is( "No such attribute 'no_such' in class 'Foo47'" ) 1469end: 1470.end 1471 1472.sub getting_null_attribute 1473 newclass $P1, "Foo51" 1474 addattribute $P1, "i" 1475 new $P2, "Foo51" 1476 1477 getattribute $P3, $P2, "i" 1478 isnull $I0, $P3 1479 is($I0, 1, "null attribute is null") 1480.end 1481 1482.sub getting_non_existent_attribute 1483 newclass $P1, "Foo52" 1484 $P2 = $P1.'new'() 1485 1486 push_eh handler 1487 getattribute $P3, $P2, "bar" 1488 pop_eh 1489 ok(0, "'No such attribute' exception not thrown") 1490 goto end 1491handler: 1492 .exception_is( "No such attribute 'bar'" ) 1493end: 1494.end 1495 1496.sub addparent_exceptions_1 1497 newclass $P0, "Astronomical Object 2" 1498 new $P1, ['String'] 1499 set $P1, "Not a class" 1500 push_eh handler 1501 addparent $P0, $P1 1502 pop_eh 1503 ok(0, "'Parent isn\'t a Class' exception not thrown") 1504 goto end 1505handler: 1506 .exception_is( "Parent 'Not a class' of 'Astronomical Object 2' isn't a Class" ) 1507end: 1508.end 1509 1510.sub addparent_exceptions_2 1511 new $P0, ['Hash'] 1512 newclass $P1, "Trashcan" 1513 push_eh handler 1514 addparent $P0, $P1 1515 pop_eh 1516 ok(0, "'Only classes can be subclassed' exception not thrown") 1517 goto end 1518handler: 1519 .exception_is( "Only classes can be subclassed" ) 1520end: 1521.end 1522 1523.sub subclassing_a_non_existent_class 1524 push_eh handler 1525 subclass $P1, "Character", "Nemo" 1526 pop_eh 1527 ok(0, "nonexistent class exception not thrown") 1528 goto end 1529handler: 1530 .exception_is( "Class 'Character' doesn't exist" ) 1531end: 1532.end 1533 1534.sub anon_subclass_of_non_existent_class 1535 push_eh handler 1536 subclass $P1, "Character" 1537 pop_eh 1538 ok(0, "nonexistent class exception not thrown") 1539 goto end 1540handler: 1541 .exception_is( "Class 'Character' doesn't exist" ) 1542end: 1543.end 1544 1545.sub addattribute_duplicate 1546 newclass $P1, "Foo53" 1547 addattribute $P1, "i" 1548 addattribute $P1, "j" 1549 push_eh handler 1550 addattribute $P1, "i" 1551 pop_eh 1552 ok(0, "attribute already exists exception not thrown") 1553 goto end 1554handler: 1555 .exception_is( "Attribute 'i' already exists in 'Foo53'" ) 1556end: 1557.end 1558 1559.sub wrong_way_to_create_new_objects 1560 push_eh handler 1561 new $P0, ['Object'] 1562 pop_eh 1563 ok(0, "object instantiation exception not thrown") 1564 goto end 1565handler: 1566 .exception_is( "Object must be created by a class" ) 1567end: 1568.end 1569 1570.sub attribute_values__subclassing_access_meths 1571 newclass $P1, "Foo54" 1572 # must add attributes before object instantiation 1573 addattribute $P1, "i" 1574 addattribute $P1, "j" 1575 # define attrib access functions in Foo54 namespace 1576 get_global $P5, "Foo54__set" 1577 addmethod $P1, "Foo54__set", $P5 1578 get_global $P5, "Foo54__get" 1579 addmethod $P1, "Foo54__get", $P5 1580 1581 subclass $P2, $P1, "Bar54" 1582 addattribute $P2, "k" 1583 addattribute $P2, "l" 1584 get_global $P5, "Bar54__set" 1585 addmethod $P2, "Bar54__set", $P5 1586 get_global $P5, "Bar54__get" 1587 addmethod $P2, "Bar54__get", $P5 1588 1589 # instantiate a Bar54 object 1590 new $P13, "Bar54" 1591 1592 # Foo54 and Bar54 have attribute accessor methods 1593 new $P5, ['String'] # set attribute values 1594 set $P5, "i" # attribute slots have reference semantics 1595 set_args "0,0,0", $P13, $P5, "i" 1596 callmethodcc $P13, "Foo54__set" 1597 get_results "" 1598 1599 new $P5, ['String'] 1600 set $P5, "j" 1601 set_args "0,0,0", $P13, $P5, "j" 1602 callmethodcc $P13,"Foo54__set" 1603 get_results "" 1604 1605 new $P5, ['String'] 1606 set $P5, "k" 1607 set_args "0,0,0", $P13, $P5, "k" 1608 callmethodcc $P13,"Bar54__set" 1609 get_results "" 1610 1611 new $P5, ['String'] 1612 set $P5, "l" 1613 set_args "0,0,0", $P13, $P5, "l" 1614 callmethodcc $P13,"Bar54__set" 1615 get_results "" 1616 1617 # now retrieve attributes 1618 set_args "0,0", $P13, "i" 1619 callmethodcc $P13,"Foo54__get" 1620 get_results "0", $P5 1621 is( $P5, "i", 'got attrib i from Bar54->Foo54__get' ) 1622 1623 set_args "0,0", $P13, "j" 1624 callmethodcc $P13,"Foo54__get" 1625 get_results "0", $P5 1626 is( $P5, "j", 'got attrib j from Bar54->Foo54__get' ) 1627 1628 set_args "0,0", $P13, "k" 1629 callmethodcc $P13,"Bar54__get" 1630 get_results "0", $P5 1631 is( $P5, "k", 'got attrib k from Bar54->Bar54__get' ) 1632 1633 set_args "0,0", $P13, "l" 1634 callmethodcc $P13, "Bar54__get" 1635 get_results "0", $P5 1636 is( $P5, "l", 'got attrib l from Bar54->Bar54__get' ) 1637.end 1638 1639# set(obj: Pvalue, Iattr_idx) 1640.sub Foo54__set 1641 get_params "0,0,0", $P2, $P5, $S4 1642 ok( 1, "in Foo54__set" ) 1643 setattribute $P2, $S4, $P5 1644 set_returns "" 1645 returncc 1646.end 1647 1648# Pattr = get(obj: Iattr_idx) 1649.sub Foo54__get 1650 get_params "0,0", $P2, $S4 1651 ok( 1, "in Foo54__get" ) 1652 getattribute $P5, $P2, $S4 1653 set_returns "0", $P5 1654 returncc 1655.end 1656 1657.sub Bar54__set 1658 get_params "0,0,0", $P2, $P5, $S4 1659 ok( 1, "in Bar54__set" ) 1660 setattribute $P2, $S4, $P5 1661 set_returns "" 1662 returncc 1663.end 1664 1665.sub Bar54__get 1666 get_params "0,0", $P2, $S4 1667 ok( 1, "in Bar54__get" ) 1668 getattribute $P5, $P2, $S4 1669 set_returns "0", $P5 1670 returncc 1671.end 1672 1673.sub attribute_values__inherited_access_meths 1674 newclass $P1, "Foo56" 1675 # must add attributes before object instantiation 1676 addattribute $P1, "i" 1677 addattribute $P1, "j" 1678 # define attrib access functions 1679 get_global $P5, "set" 1680 addmethod $P1, "set", $P5 1681 get_global $P5, "get" 1682 addmethod $P1, "get", $P5 1683 1684 subclass $P2, $P1, "Bar56" 1685 addattribute $P2, "k" 1686 addattribute $P2, "l" 1687 addattribute $P2, "m" 1688 1689 # subclass is preferred for the SI case over 1690 # newclass $P2, "Bar56" 1691 # addattrib ... 1692 # addparent $P2, $P1 1693 # which is suitable for adding multiple parents to one class 1694 1695 # instantiate a Bar56 object 1696 new $P2, "Bar56" 1697 1698 # Foo56 and Bar56 have attribute accessor methods 1699 new $P5, ['String'] # set attribute values 1700 set $P5, "i" # attribute slots have reference semantics 1701 set_args "0,0,0,0", $P2, $P5, "Foo56", "i" 1702 callmethodcc $P2, "set" 1703 1704 new $P5, ['String'] 1705 set $P5, "j" 1706 set_args "0,0,0,0", $P2, $P5, "Foo56", "j" 1707 callmethodcc $P2, "set" 1708 1709 new $P5, ['String'] 1710 set $P5, "k" 1711 set_args "0,0,0,0", $P2, $P5, "Bar56", "k" 1712 callmethodcc $P2, "set" 1713 1714 new $P5, ['String'] 1715 set $P5, "l" 1716 set_args "0,0,0,0", $P2, $P5, "Bar56", "l" 1717 callmethodcc $P2, "set" 1718 1719 new $P5, ['String'] 1720 set $P5, "m" 1721 set_args "0,0,0,0", $P2, $P5, "Bar56", "m" 1722 callmethodcc $P2, "set" 1723 1724 # now retrieve attributes 1725 set_args "0,0,0", $P2, "Foo56", "i" 1726 callmethodcc $P2, "get" 1727 get_results "0", $P5 1728 is( $P5, 'i', 'got attrib i from subclass through parent method' ) 1729 1730 set_args "0,0,0", $P2, "Foo56", "j" 1731 callmethodcc $P2, "get" 1732 get_results "0", $P5 1733 is( $P5, "j", 'got attrib i from subclass through parent method' ) 1734 1735 set_args "0,0,0", $P2, "Bar56", "k" 1736 callmethodcc $P2, "get" 1737 get_results "0", $P5 1738 is( $P5, "k", 'got attrib i from subclass through parent method' ) 1739 1740 set_args "0,0,0", $P2, "Bar56", "l" 1741 callmethodcc $P2, "get" 1742 get_results "0", $P5 1743 is( $P5, "l", 'got attrib i from subclass through parent method' ) 1744 1745 set_args "0,0,0", $P2, "Bar56", "m" 1746 callmethodcc $P2, "get" 1747 get_results "0", $P5 1748 is( $P5, "m", 'got attrib i from subclass through parent method' ) 1749.end 1750 1751# Foo56 provides accessor functions which Bar56 inherits 1752# they take an additional classname argument SClass 1753 1754# set(obj: Pvalue, SClass, Sattr) 1755.sub set 1756 get_params "0,0,0,0", $P2, $P5, $S4, $S5 1757 setattribute $P2, $S5, $P5 1758 set_returns "" 1759 returncc 1760.end 1761 1762# Pattr = get(obj: SClass, Sattr) 1763.sub get 1764 get_params "0,0,0", $P2, $S4, $S5 1765 getattribute $P5, $P2, $S5 1766 set_returns "0", $P5 1767 returncc 1768.end 1769 1770# Local Variables: 1771# mode: pir 1772# fill-column: 100 1773# End: 1774# vim: expandtab shiftwidth=4 ft=pir: 1775