File Coverage

inc/Test/ClassAPI.pm
Criterion Covered Total %
statement 98 127 77.2
branch 17 42 40.5
condition 2 7 28.6
subroutine 12 12 100.0
pod 1 2 50.0
total 130 190 68.4


line stmt bran cond sub pod time code
1             #line 1
2             package Test::ClassAPI;
3              
4             # Allows us to test class APIs in a simplified manner.
5             # Implemented as a wrapper around Test::More, Class::Inspector and Config::Tiny.
6 1     1   14  
  1         10  
  1         14  
7 1     1   509 use strict;
  1         11  
  1         15  
8 1     1   15 use UNIVERSAL 'isa';
  1         9  
  1         10  
9 1     1   52 use Test::More ();
  1         10  
  1         10  
10 1     1   27 use Config::Tiny ();
  1         32  
  1         12  
11             use Class::Inspector ();
12 1     1   20  
  1         10  
  1         17  
13             use vars qw{$VERSION $CONFIG $SCHEDULE $EXECUTED %IGNORE *DATA};
14 1     1   15 BEGIN {
15             $VERSION = '1.02';
16              
17 1         10 # Config starts empty
18 1         9 $CONFIG   = undef;
19             $SCHEDULE = undef;
20              
21 1         9 # We only execute once
22             $EXECUTED = '';
23              
24             # When looking for method that arn't described in the class
25 1         9 # description, we ignore anything from UNIVERSAL.
  2         27  
26             %IGNORE = map { $_, 1 } qw{isa can};
27             }
28              
29             # Get the super path ( not including UNIVERSAL )
30             # Rather than using Class::ISA, we'll use an inlined version
31             # that implements the same basic algorithm, but faster.
32 4     4   36 sub _super_path($) {
33 4         36 my $class = shift;
34 4         38 my @path = ();
35 4         43 my @queue = ( $class );
36 4         47 my %seen = ( $class => 1 );
37 1     1   18 while ( my $cl = shift @queue ) {
  1         68  
  1         17  
38 7         68 no strict 'refs';
39 3         44 push @path, $cl;
  3         28  
40 3         27 unshift @queue, grep { ! $seen{$_}++ }
  3         32  
  7         107  
41 7         58 map { s/^::/main::/; s/\'/::/g; $_ }
42             ( @{"${cl}::ISA"} );
43             }
44 4         47  
45             @path;
46             }
47              
48              
49              
50              
51              
52             #####################################################################
53             # Main Methods
54              
55             # Initialise the Configuration
56 1     1 0 11 sub init {
57             my $class = shift;
58              
59 1 50       32 # Use the script's DATA handle or one passed
60             *DATA = isa( $_[0], 'GLOB' ) ? shift : *main::DATA;
61              
62 1         13 # Read in all the data, and create the config object
63 1 50       68 local $/ = undef;
64             $CONFIG = Config::Tiny->read_string( <DATA> )
65             or die 'Failed to load test configuration: '
66 1 50       810 . Config::Tiny->errstr;
67             $SCHEDULE = delete $CONFIG->{_}
68             or die 'Config does not have a schedule defined';
69              
70 1         13 # Add implied schedule entries
71 6   50     61 foreach my $tclass ( keys %$CONFIG ) {
72 6         50 $SCHEDULE->{$tclass} ||= 'class';
  6         67  
73 19 50       215 foreach my $test ( keys %{$CONFIG->{$tclass}} ) {
74 0   0     0 next unless $CONFIG->{$tclass}->{$test} eq 'implements';
75             $SCHEDULE->{$test} ||= 'interface';
76             }
77             }
78            
79              
80 1         14 # Check the schedule information
81 6         56 foreach my $tclass ( keys %$SCHEDULE ) {
82 6 50       65 my $value = $SCHEDULE->{$tclass};
83 0         0 unless ( $value =~ /^(?:class|abstract|interface)$/ ) {
84             die "Invalid schedule option '$value' for class '$tclass'";
85 6 50       64 }
86 0         0 unless ( $CONFIG->{$tclass} ) {
87             die "No section '[$tclass]' defined for schedule class";
88             }
89             }
90 1         13  
91             1;
92             }
93              
94             # Find and execute the tests
95 1     1 1 12 sub execute {
96 1 50       12 my $class = shift;
97 0         0 if ( $EXECUTED ) {
98             die 'You can only execute once, use another test script';
99 1 50       16 }
100             $class->init unless $CONFIG;
101              
102 1         10 # Handle options
  1         13  
103 1         11 my @options = map { lc $_ } @_;
  1         12  
104 1         10 my $CHECK_UNKNOWN_METHODS = !! grep { $_ eq 'complete' } @options;
  1         12  
105             my $CHECK_FUNCTION_COLLISIONS = !! grep { $_ eq 'collisions' } @options;
106              
107 1 50       22 # Set the plan of no plan if we don't have a plan
108 0         0 unless ( Test::More->builder->has_plan ) {
109             Test::More::plan( 'no_plan' );
110             }
111              
112 1         20 # Determine the list of classes to test
113 1         11 my @classes = sort keys %$SCHEDULE;
  6         67  
114             @classes = grep { $SCHEDULE->{$_} ne 'interface' } @classes;
115              
116 1         11 # Check that all the classes/abstracts are loaded
117 6         734 foreach my $class ( @classes ) {
118             Test::More::ok( Class::Inspector->loaded( $class ), "Class '$class' is loaded" );
119             }
120              
121 1         11 # Check that all the full classes match all the required interfaces
  6         135  
122 1         13 @classes = grep { $SCHEDULE->{$_} eq 'class' } @classes;
123             foreach my $class ( @classes ) {
124 4         46 # Find all testable parents
  7         78  
125             my @path = grep { $SCHEDULE->{$_} } _super_path($class);
126              
127 4         39 # Iterate over the testable entries
128 4         35 my %known_methods = ();
129 4         34 my @implements = ();
130 7         60 foreach my $parent ( @path ) {
  7         102  
131 29         346 foreach my $test ( keys %{$CONFIG->{$parent}} ) {
132 29 100       277 my $type = $CONFIG->{$parent}->{$test};
    50          
133             if ( $type eq 'method' ) {
134 26         235 # Does the class have a method
135 26         267 $known_methods{$test}++;
136             Test::More::can_ok( $class, $test );
137             } elsif ( $type eq 'isa' ) {
138 3         72 # Does the class inherit from a parent
139             Test::More::ok( isa( $class, $test ), "$class isa $test" );
140 29 50       1027 }
141             next unless $type eq 'implements';
142            
143             # When we 'implement' a class or interface,
144             # we need to check the 'method' tests within
145             # it, but not anything else. So we will add
146             # the class name to a seperate queue to be
147             # processed afterwards, ONLY if it is not
148             # already in the normal @path, or already
149 0 0       0 # on the seperate queue.
  0         0  
150 0 0       0 next if grep { $_ eq $test } @path;
  0         0  
151 0         0 next if grep { $_ eq $test } @implements;
152             push @implements, $test;
153             }
154             }
155              
156             # Now, if it had any, go through and check the classes added
157 4         43 # because of any 'implements' tests
158 0         0 foreach my $parent ( @implements ) {
  0         0  
159 0         0 foreach my $test ( keys %{$CONFIG->{$parent}} ) {
160 0 0       0 my $type = $CONFIG->{$parent}->{$test};
161             if ( $type eq 'method' ) {
162 0         0 # Does the class have a method
163 0         0 $known_methods{$test}++;
164             Test::More::can_ok( $class, $test );
165             }
166             }
167             }
168 4 50       43  
169             if ( $CHECK_UNKNOWN_METHODS ) {
170 4 50       58 # Check for unknown public methods
171             my $methods = Class::Inspector->methods( $class, 'public', 'expanded' )
172 0         0 or die "Failed to find public methods for class '$class'";
  0         0  
173 26   33     301 @$methods = grep { $_->[2] !~ /^[A-Z_]+$/ } # Internals stuff
174 4         40 grep { $_->[1] ne 'Exporter' } # Ignore Exporter methods we don't overload
175 4 50       45 grep { ! ($known_methods{$_->[2]} or $IGNORE{$_->[2]}) } @$methods;
176 0         0 if ( @$methods ) {
  0         0  
177             print STDERR join '', map { "# Found undocumented method '$_->[2]' defined at '$_->[0]'\n" } @$methods;
178 4         54 }
179             Test::More::is( scalar(@$methods), 0, "No unknown public methods in '$class'" );
180             }
181 4 50       90  
182             if ( $CHECK_FUNCTION_COLLISIONS ) {
183             # Check for methods collisions.
184             # A method collision is where
185             #
186             # Foo::Bar->method
187             #
188             # is actually interpreted as
189             #
190             # &Foo::Bar()->method
191 1     1   22 #
  1         10  
  1         49  
192 0         0 no strict 'refs';
193 0         0 my @collisions = ();
  0         0  
194 0 0       0 foreach my $symbol ( sort keys %{"${class}::"} ) {
195 0 0       0 next unless $symbol =~ s/::$//;
  0         0  
196 0         0 next unless defined *{"${class}::${symbol}"}{CODE};
197 0         0 print STDERR "Found function collision: ${class}->${symbol} clashes with ${class}::${symbol}\n";
198             push @collisions, $symbol;
199 0         0 }
200             Test::More::is( scalar(@collisions), 0, "No function/class collisions in '$class'" );
201             }
202             }
203 1         14  
204             1;
205             }
206              
207             1;
208              
209             __END__
210            
211             #line 339
212