Replaced Array::new with [ ]
[kakapo:kakapo.git] / t / Cuculinae / Cuculus.nqp
1 #! /usr/bin/env parrot-nqp
2 # Copyright 2010, Austin Hastings. See accompanying LICENSE file, or
3 # http://www.opensource.org/licenses/artistic-license-2.0.php for license.
4
5 INIT {
6         # Load the Kakapo library
7         pir::load_language('parrot');
8         my $env := pir::new__PS('Env');
9         my $root_dir := $env<HARNESS_ROOT_DIR> || '.';
10         pir::load_bytecode($root_dir ~ '/library/kakapo_full.pbc');
11 }
12
13 class Test::Mock::Parent {
14         method a() { 1; }
15         method b() { 1; }
16         method c() { 1; }
17 }
18
19 class Test::Cuculus::Canorus
20         is UnitTest::Testcase ;
21
22 has $!sut;
23
24 INIT {
25         use(    'UnitTest::Testcase' );
26         use(    'UnitTest::Assertions' );
27         use(    'Matcher::Factory' );
28
29         use(    'Cuculus::Canorus' );
30 }
31
32 MAIN();
33
34 sub MAIN() {
35         my $proto := Opcode::get_root_global(pir::get_namespace__P().get_name);
36         $proto.suite.run;
37         #$proto.set_up;
38         #$proto.test_mock_object_isa_parent;
39 }
40
41
42 # For named mocks, check the mock is installed correctly.
43 method check_class_namespace($class, $namespace) {
44         my $parrot_class := P6metaclass.get_parrotclass($class);
45
46         my $proto_obj := Parrot::get_hll_global($namespace);
47         assert_same($proto_obj, $class,
48                 'Protoobject should be installed as $namespace global symbol');
49
50         my $nsp := Parrot::get_hll_namespace($namespace);
51         assert_same($parrot_class.get_namespace, $nsp,
52                 'Class should be linked to $namespace namespace' );
53 }
54
55 method check_created_class($class, :@parents) {
56         my $parrot_class := P6metaclass.get_parrotclass($class);
57
58         # Check parents against specified list. Stringify to get name, transform "A;B" style into A::B, and sort.
59         my @mock_parents := $parrot_class.inspect('parents'
60                 ).map( -> $parent { ~ $parent }
61                 ).map( -> $name { $name.split(';').join('::') }
62                 );
63         @mock_parents.sort;
64
65         @parents.sort;
66
67         assert_equal( @mock_parents, @parents,
68                 'Inspected "parents" attribute should have: ' ~ @parents.join(', '));
69
70         # Verify that the species attribute gets set
71         my $species := Opcode::getattribute($class, '$!CUCULUS_CANORUS');
72
73         assert_not_null( $species,
74                 '$!CUCULUS_CANORUS attribute should always be set on generated classes');
75         assert_same( $species, $!sut,
76                 '$!CUCULUS_CANORUS should point back to cuckoo object that generated the class');
77 }
78
79 method set_up() {
80         $!sut := Cuculus::Canorus.new;
81 }
82
83 method test_new() {
84         verify_that( 'SUT is created okay, right class.' );
85
86         assert_isa( $!sut, 'Cuculus::Canorus',
87                 'SUT should be populated with object of the right class.');
88 }
89
90 method test_mock_class() {
91         verify_that( 'mock_class() creates an anonymous class based on P6object' );
92
93         my $class := $!sut.mock_class();
94         self.check_created_class($class, :parents( [ 'Cuculus::Canorus::Ovum' ] ));
95 }
96
97 method test_mock_class_named() {
98         verify_that( 'mock_class(:named("Foo::Bar") creates a class in the right namespace' );
99
100         my $class := $!sut.mock_class(:named('Foo::Bar'));
101
102         self.check_created_class($class, :parents( [ 'Cuculus::Canorus::Ovum' ] ));
103         self.check_class_namespace($class, 'Foo::Bar');
104 }
105
106 method test_mock_object_isa_parent() {
107         my $class := $!sut.mock_class('Test::Mock::Parent');
108         my $obj := $class.new;
109         
110         assert_not_null( $obj, 
111                 'Mock class new() should create objects');
112         assert_isa( $obj, 'Test::Mock::Parent',
113                 'Mock objects should be isa parent class');             
114 }
115
116 method test_mock_subclass() {
117         verify_that( 'mock_class(parent_class) creates an anonymous class with the right parents' );
118
119         my $class := $!sut.mock_class('Test::Mock::Parent');
120         self.check_created_class($class, :parents(<Cuculus::Canorus::Ovum Test::Mock::Parent>));
121 }
122
123 method test_mock_subclass_named() {
124         verify_that( 'mock_class(parent_class, :named("Foo::Baz")) has right parents, right namespace' );
125         
126         my $class := $!sut.mock_class('Test::Mock::Parent', :named('Foo::Baz'));
127         self.check_created_class($class, :parents(<Cuculus::Canorus::Ovum Test::Mock::Parent>));
128         self.check_class_namespace($class, 'Foo::Baz');
129 }
130
131 method test_new_egg() {
132         $!sut.class('Cuculus::Canorus::Ovum');
133         my $egg := $!sut.new_egg();
134
135         assert_isa( $egg, 'Cuculus::Canorus::Ovum',
136                 'new_egg should return the right type');
137
138         my $behavior := Opcode::getattribute( $egg, '&!CUCULUS_BEHAVIOR' );
139         assert_same( $behavior, Cuculus::Canorus::mock_execute,
140                 'New egg should be execute-configured by default' );
141 }