some more progress. All the initialization routines run and I can get some of the...
[kakapo:kakapo.git] / t / Program.nqp
1 #! /usr/bin/env parrot-nqp
2 # Copyright 2009-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         my $env := pir::new__PS('Env');
8         my $root_dir := $env<HARNESS_ROOT_DIR> || '.';
9         pir::load_bytecode($root_dir ~ '/library/kakapo_full.pbc');
10 }
11
12 class Test::Program
13         is UnitTest::Testcase ;
14
15 UnitTest::Testcase::TEST_MAIN();
16
17 method set_up() {
18         # Set global-variable state to post-INIT{} condition.
19         pir::set_hll_global__vPSP( Key.new( <Program> ), '$_Instance', my $undef);
20 }
21
22 class Test::Exit is Program {
23         method main(*@args) {
24                 foo();
25                 exit(1);
26         }
27
28         sub foo() {
29                 exit(4);
30         }
31 }
32
33 method test_exit() {
34         verify_that( 'Calling global exit() immediately ends program' );
35
36         my $pgm := Test::Exit.new;
37         my $status := $pgm.run;
38
39         fail_unless($status == 4, 'Exit 4 should have passed through');
40 }
41
42 class Test::StartQueue is Program {
43 has $!a;
44 has $!b;
45 has $!c;
46
47         sub set_a($pgm) {       $pgm.a($pgm.b + 1); }
48         sub set_b($pgm) {       $pgm.b(3); }
49         sub set_c($pgm) {       $pgm.c($pgm.a + 5); }
50 }
51
52 method test_start_queue() {
53         verify_that( 'Program calls the entries in the at_start queue correctly' );
54
55         my $pgm := Test::StartQueue.new;
56
57         $pgm.at_start(Test::StartQueue::set_c, 'c', :requires('a'));
58         $pgm.at_start(Test::StartQueue::set_a, 'a', :requires('b'));
59         $pgm.at_start(Test::StartQueue::set_b, 'b');
60
61         $pgm.do_start;
62
63         assert_equal( $pgm.a, 4,
64                 'a should be set to 4');
65         assert_equal( $pgm.b, 3,
66                 'b should be set to 3');
67         assert_equal( $pgm.c, 9,
68                 'c should be set to 9');
69 }
70
71 method test_exit_queue() {
72         verify_that( 'Program calls the entries in the at_exit queue correctly' );
73
74         my $pgm := Test::StartQueue.new;
75
76         $pgm.at_exit(Test::StartQueue::set_c, 'c', :requires('a'));
77         $pgm.at_exit(Test::StartQueue::set_a, 'a', :requires('b'));
78         $pgm.at_exit(Test::StartQueue::set_b, 'b');
79
80         $pgm.do_start;
81
82         assert_equal( $pgm.a + $pgm.b + $pgm.c, 0,
83                 'Nothing done at do_start');
84
85         $pgm.do_exit;
86
87         assert_equal( $pgm.a, 4,
88                 'a should be set to 4');
89         assert_equal( $pgm.b, 3,
90                 'b should be set to 3');
91         assert_equal( $pgm.c, 9,
92                 'c should be set to 9');
93 }
94
95 method test_from_parrot() {
96         my $pgm := Program.new;
97
98         assert_equal( $pgm.program_name, '',
99                 'New program should have no name' );
100
101         $pgm.from_parrot;
102
103         assert_not_equal( $pgm.program_name, '',
104                 'Taking values from parrot interp should provide a program name' );
105
106         assert_not_equal( $pgm.executable_name, '',
107                 'Taking values from parrot interp should provide an executable name' );
108 }
109
110
111 class Test::Global::AtFuncs is Program {
112         sub foo() { 1; }
113 }
114
115 method test_global_at_exit() {
116         my $pgm := Test::Global::AtFuncs.new;
117
118         assert_throws_nothing('Registered program should have no problems with at_exit global',
119         {
120                 Program::instance($pgm);
121                 at_exit(Test::Global::AtFuncs::foo);
122         });
123 }
124
125 method test_global_at_exit_fails() {
126         my $pgm := Test::Global::AtFuncs.new;
127
128         assert_throws(Control::Error, 'at_exit should throw exception if no program registered',
129         {
130                 at_exit(Test::Global::AtFuncs::foo);
131         });
132 }
133
134 method test_global_at_start() {
135         my $pgm := Test::Global::AtFuncs.new;
136
137         assert_throws_nothing('Registered program should have no problems with at_start global',
138         {
139                 Program::instance($pgm);
140                 at_start(Test::Global::AtFuncs::foo);
141         });
142 }
143
144 method test_global_at_start_fails() {
145         my $pgm := Test::Global::AtFuncs.new;
146
147         assert_throws(Control::Error, 'at_start should throw exception if no program registered',
148         {
149                 at_start(Test::Global::AtFuncs::foo);
150         });
151 }
152
153 class Dummy::SetMain is Program {
154         sub foo() { exit(27); }
155 }
156
157 method test_main_uses_set_main() {
158         my $pgm := Dummy::SetMain.new;
159
160         assert_not_defined( $pgm.get_main,
161                 'Program should have no &main set by default.' );
162         assert_throws( Control::Error, 'Program should die with no main set.',
163                 { $pgm.run; });
164
165         $pgm.set_main( Dummy::SetMain::foo );
166         assert_same( Dummy::SetMain::foo, $pgm.get_main,
167                 'get/set_main should be accessors' );
168
169         my $result := $pgm.run;
170
171         assert_equal( 27, $result,
172                 'After set_main, Program::main should call sub' );
173 }
174
175 class Dummy::RunSetsArgs is Program {
176         method main() {
177                 @*ARGS[2];
178         }
179 }
180
181 method run_sets_args() {
182         my $dummy := Dummy::RunSetsArgs.new;
183
184         my $result := $dummy.run: argv => <a b c>;
185
186         assert_equal( 'b', $result,
187                 'Result should be "b" if run is setting @*ARGS');
188 }
189
190 class Dummy::ProgramSwapsStreams is Program {
191         method main() {
192                 say("12345");
193         }
194 }
195
196 method test_run_swaps_streams() {
197         my $string_out := Parrot::new('StringHandle');
198         $string_out.open('any value', 'w');
199
200         my $pgm := Dummy::ProgramSwapsStreams.new;
201         $pgm.stdout( $string_out );
202
203         my $save_stdout := pir::getstdout__P();
204
205         $pgm.run;
206
207         assert_same( pir::getstdout__P(), $save_stdout,
208                 'Program should restore stdout');
209
210         $string_out.open('really, anything', 'r');
211
212         assert_equal( $string_out.readall.index('34'), 2, #"12345\n",
213                 'Program should write to stdout as given');
214 }
215
216 #~ class Test::Dynamic is Program {
217         #~ method main(@args) {
218                 #~ my %results;
219
220                 #~ for @args {
221                         #~ %results{~ $_} := pir::find_dynamic_lex__PS(~ $_);
222                 #~ }
223
224                 #~ exit(%results);
225         #~ }
226
227         #~ method do_exit() {
228                 #~ self.exit_value;
229         #~ }
230 #~ }
231
232 #~ method test_dynamic_vars() {
233         #~ verify_that( 'The various $*DYNAMIC_VARS get set when running' );
234
235         #~ my $fetch := Test::Dynamic.new;
236
237         #~ my @args := <
238                 #~ thisProgram
239                 #~ $*PROGRAM_NAME
240                 #~ @*ARGS
241                 #~ %*ENV
242                 #~ $*EXECUTABLE_NAME
243                 #~ $*PID
244                 #~ $?PERL
245                 #~ $?VM
246                 #~ %*VM
247         #~ >;
248         #~ my %value := $fetch.run(@args);
249
250         #~ fail_unless( %value<$*PROGRAM_NAME> eq @args.shift,
251                 #~ 'Program name should be this script.');
252         #~ fail_unless( %value<@*ARGS>.join(' ') eq @args.join(' '),
253                 #~ 'Program @*ARGS should be the list, minus program name.');
254         #~ #fail_unless( %value<%*ENV><PATH> ne '', 'Path must be in env' );
255         #~ #fail_unless( %value<$*EXECUTABLE_NAME> ne '', 'Executable name must be set' );
256         #~ #fail_unless( %value<$*PID> ne '', 'Process id must be set' );
257         #~ fail_unless( %value<$?PERL> eq 'nqp-rx', 'Perl should be nqp' );
258         #~ fail_unless( %value<$?VM> eq 'parrot', 'VM should be parrot' );
259         #~ fail_unless( %value<%*VM><lib_paths> == 5, '%*VM<lib_paths> should have 5 entries' );
260 #~ }