some more progress. All the initialization routines run and I can get some of the...
[kakapo:kakapo.git] / src / UnitTest / Loader.nqp
1 # Copyright (C) 2010, Austin Hastings. See accompanying LICENSE file, or
2 # http://www.opensource.org/licenses/artistic-license-2.0.php for license.
3
4 class UnitTest::Loader;
5
6 has     $!class;
7 has     %!seen_methods;
8 has     $!test_prefix;
9
10 sub compare_methods($a, $b) {
11         pir::cmp_str__IPP(~ $a, ~ $b);
12 }
13
14 method configure_suite(@tests, :$suite, *%named) {
15         unless $suite.defined {
16                 $suite := self.default_suite;
17         }
18
19         my $proto := pir::getprop__PSP('metaclass', $!class).WHAT();
20         pir::say(pir::typeof__SP($proto));
21         for @tests -> $test {
22                 $suite.add_test: $proto.new(:name($test));
23         }
24
25         $suite;
26 }
27
28 method default_suite() {
29         return UnitTest::Suite.new();
30 }
31
32 method get_test_methods() {
33         my @mro := $!class.inspect('all_parents');
34         my @test_methods := Array::new();
35
36         for @mro {
37                 my %methods := $_.inspect('methods');
38
39                 for %methods {
40                         my $name := ~ $_;
41
42                         if self.is_test_method($name)
43                                 && ! %!seen_methods.contains($name) {
44                                 %!seen_methods{$name} := 1;
45                                 @test_methods.push($name);
46                         }
47                 }
48         }
49
50         self.order_tests(@test_methods);
51 }
52
53 method _init_obj(*@pos, *%named) {
54         $!test_prefix := 'test';
55
56         self._init_args(|@pos, |%named);
57 }
58
59 # Returns true for "test_foo" and "testFoo" names
60 method is_test_method($name) {
61         if $name.length > 4
62                 && $name.substr(0, 4) eq 'test' {
63
64                 if $name[4] eq '_' {
65                         return 1;
66                 }
67
68                 if String::is_cclass('UPPERCASE', $name, :offset(4)) {
69                         return 1;
70                 }
71
72                 if String::is_cclass('NUMERIC', $name, :offset(4)) {
73                         return 1;
74                 }
75         }
76
77         return 0;
78 }
79
80 method load_tests_from_testcase($class, *%named) {
81         $!class := P6metaclass.get_parrotclass($class);
82         my @tests := self.get_test_methods;
83
84         self.configure_suite(@tests, |%named);
85 }
86
87 method order_tests(@tests) {
88         @tests.unsort;
89 }
90
91 method test_prefix($value?)     { $value ?? ($!test_prefix := $value) !! $!test_prefix; }