Added bootstrap tests for Testcase.nqp.
[kakapo:rurbans-kakapo.git] / t / bootstrap / Classes / P6metaclass.nqp
1 #! parrot-nqp
2
3 MAIN();
4
5 INIT {
6         # Load the Test::More library
7         pir::load_language('parrot');
8         pir::compreg__PS('parrot').import('Test::More');
9         
10         # Load the Kakapo library
11         my $env := pir::new__PS('Env');
12         my $root_dir := $env<HARNESS_ROOT_DIR>;
13         
14         unless $root_dir {
15                 $root_dir := '.';
16         }
17         
18         pir::load_bytecode($root_dir ~ '/library/kakapo_full.pbc');
19 }
20
21 sub MAIN() {    
22         plan(16);
23
24         test_base();
25         test_derived();
26         test_attributes();
27         test_deferred();
28 }
29
30 class Base {
31         method m1() {
32                 17;
33         }
34         
35         method m2() {
36                 19;
37         }
38 }
39
40 sub test_base() {
41         my $obj := Base.new();
42         ok($obj.defined, 'Got Simple object');
43         is($obj.m1, 17, 'Got expected method result');
44         is($obj.m2, 19, 'Got expected method result');
45 }
46
47 class Derived is Base {
48         method m1() {
49                 16;
50         }
51
52         method m3() {
53                 21;
54         }
55 }
56
57 sub test_derived() {
58         my $obj := Derived.new();
59         ok($obj.isa(Derived), 'Got right class');
60         ok($obj.isa('Base'), 'isa Base okay');
61         is($obj.m3, 21, 'Independent method okay');
62         is($obj.m2, 19, 'Inherited method okay');
63         is($obj.m1, 16, 'Overridden method okay');
64 }
65
66 class Attributes is Base {
67         INIT {
68                 use(    'P6metaclass' );
69                 
70                 has(    '$!attr' );
71         }       
72 }
73
74 sub test_attributes() {
75         my $obj := Attributes.new();
76         
77         ok($obj.isa('Attributes'), 'Attributes: Right class');
78         ok($obj.isa('Base'), 'Attributes: isa Base');
79         ok(Attributes.HOW.can(Attributes, 'attr'), 'Attributes: Has accessor');
80         
81         $obj.attr(11);
82         my $value := 6;
83         $value := $obj.attr;
84         is($value, 11, 'Attributes: Stored and fetched okay.'); 
85 }
86
87 module Deferred {
88         INIT {
89                 use(    'P6metaclass' );
90                 
91                 extends( 'Attributes' );
92                 has(    '@.list' );
93         }
94 }
95
96 sub test_deferred() {
97         my $obj := Deferred.new();
98         ok($obj.isa('Deferred'), 'Deferred: right class');
99         ok($obj.isa('Attributes'), 'Deferred: right hierarchy');
100         
101         $obj.attr(17);
102         is($obj.attr, 17, 'Deferred: inherited attr okay');
103         $obj.list.push(5);
104         is($obj.list, 1, 'Deferred: list attr okay');
105 }