Tweaked globals to prevent init problems.
[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 module UnitTest::Loader;
5 INIT {
6         use(    'P6metaclass' );
7         
8         has(    '%!seen_methods' );
9         say("Loader init done");
10 }
11
12 method get_test_methods($class) {
13         my @mro := $class.inspect('all_parents');
14         my @test_methods := Array::empty();
15         
16         for @mro {
17                 my %methods := $_.inspect('methods');
18                 
19                 for %methods {
20                         my $name := ~ $_;
21                         
22                         if self.is_test_method($name) 
23                                 && ! self.seen_methods.contains($name) {
24                                 self.seen_methods{$name} := 1;
25                                 @test_methods.push($name);
26                         }
27                 }
28         }
29
30         return @test_methods;
31 }
32
33 method is_test_method($name) {
34 # Returns true for "test_foo" and "testFoo" names
35         if $name.length > 4
36                 && $name.substr(0, 4) eq 'test' {
37                 
38                 if $name[4] eq '_' {
39                         return 1;
40                 }
41
42                 if String::is_cclass('UPPERCASE', $name, :offset(4)) {
43                         return 1;
44                 }
45                 
46                 if String::is_cclass('NUMERIC', $name, :offset(4)) {
47                         return 1;
48                 }
49         }
50
51         return 0;
52 }
53
54 method load_tests_from_testcase($testcase) {
55         my $class := P6metaclass.get_parrotclass($testcase);
56         my $suite := UnitTest::Suite.new;
57
58         for self.get_test_methods($class) {
59                 my $metaclass := Q:PIR {
60                         $P0 = find_lex '$class'
61                         %r = getprop 'metaclass', $P0
62                 };
63                 
64                 $suite.add_test( $metaclass.WHAT.new(:name(~ $_)) );
65         }
66         
67         return $suite;
68 }