local-lib5/lib/perl5/Test/ClassAPI.pm

   1 package Test::ClassAPI;
   2
   3 # Allows us to test class APIs in a simplified manner.
   4 # Implemented as a wrapper around Test::More, Class::Inspector and Config::Tiny.
   5
   6 use 5.006;
   7 use strict;
   8 use File::Spec       0.83 ();
   9 use Test::More       0.47 ();
  10 use Config::Tiny     2.00 ();
  11 use Class::Inspector 1.12 ();
  12 use Params::Util     1.00 '_INSTANCE';
  13
  14 use vars qw{$VERSION $CONFIG $SCHEDULE $EXECUTED %IGNORE *DATA};
  15 BEGIN {
  16         $VERSION = '1.06';
  17
  18         # Config starts empty
  19         $CONFIG   = undef;
  20         $SCHEDULE = undef;
  21
  22         # We only execute once
  23         $EXECUTED = '';
  24
  25         # When looking for method that arn't described in the class
  26         # description, we ignore anything from UNIVERSAL.
  27         %IGNORE = map { $_, 1 } qw{isa can};
  28 }
  29
  30 # Get the super path ( not including UNIVERSAL )
  31 # Rather than using Class::ISA, we'll use an inlined version
  32 # that implements the same basic algorithm, but faster.
  33 sub _super_path($) {
  34         my $class = shift;
  35         my @path  = ();
  36         my @queue = ( $class );
  37         my %seen  = ( $class => 1 );
  38         while ( my $cl = shift @queue ) {
  39                 no strict 'refs';
  40                 push @path, $cl;
  41                 unshift @queue, grep { ! $seen{$_}++ }
  42                         map { s/^::/main::/; s/\'/::/g; $_ }
  43                         ( @{"${cl}::ISA"} );
  44         }
  45
  46         @path;
  47 }
  48
  49
  50
  51
  52
  53 #####################################################################
  54 # Main Methods
  55
  56 # Initialise the Configuration
  57 sub init {
  58         my $class = shift;
  59
  60         # Use the script's DATA handle or one passed
  61         *DATA = ref($_[0]) eq 'GLOB' ? shift : *main::DATA;
  62
  63         # Read in all the data, and create the config object
  64         local $/ = undef;
  65         $CONFIG = Config::Tiny->read_string( <DATA> )
  66                 or die 'Failed to load test configuration: '
  67                         . Config::Tiny->errstr;
  68         $SCHEDULE = delete $CONFIG->{_}
  69                 or die 'Config does not have a schedule defined';
  70
  71         # Add implied schedule entries
  72         foreach my $tclass ( keys %$CONFIG ) {
  73                 $SCHEDULE->{$tclass} ||= 'class';
  74                 foreach my $test ( keys %{$CONFIG->{$tclass}} ) {
  75                         next unless $CONFIG->{$tclass}->{$test} eq 'implements';
  76                         $SCHEDULE->{$test} ||= 'interface';
  77                 }
  78         }
  79
  80
  81         # Check the schedule information
  82         foreach my $tclass ( keys %$SCHEDULE ) {
  83                 my $value = $SCHEDULE->{$tclass};
  84                 unless ( $value =~ /^(?:class|abstract|interface)$/ ) {
  85                         die "Invalid schedule option '$value' for class '$tclass'";
  86                 }
  87                 unless ( $CONFIG->{$tclass} ) {
  88                         die "No section '[$tclass]' defined for schedule class";
  89                 }
  90         }
  91
  92         1;
  93 }
  94
  95 # Find and execute the tests
  96 sub execute {
  97         my $class = shift;
  98         if ( $EXECUTED ) {
  99                 die 'You can only execute once, use another test script';
 100         }
 101         $class->init unless $CONFIG;
 102
 103         # Handle options
 104         my @options = map { lc $_ } @_;
 105         my $CHECK_UNKNOWN_METHODS     = !! grep { $_ eq 'complete'   } @options;
 106         my $CHECK_FUNCTION_COLLISIONS = !! grep { $_ eq 'collisions' } @options;
 107
 108         # Set the plan of no plan if we don't have a plan
 109         unless ( Test::More->builder->has_plan ) {
 110                 Test::More::plan( 'no_plan' );
 111         }
 112
 113         # Determine the list of classes to test
 114         my @classes = sort keys %$SCHEDULE;
 115         @classes = grep { $SCHEDULE->{$_} ne 'interface' } @classes;
 116
 117         # Check that all the classes/abstracts are loaded
 118         foreach my $class ( @classes ) {
 119                 Test::More::ok( Class::Inspector->loaded( $class ), "Class '$class' is loaded" );
 120         }
 121
 122         # Check that all the full classes match all the required interfaces
 123         @classes = grep { $SCHEDULE->{$_} eq 'class' } @classes;
 124         foreach my $class ( @classes ) {
 125                 # Find all testable parents
 126                 my @path = grep { $SCHEDULE->{$_} } _super_path($class);
 127
 128                 # Iterate over the testable entries
 129                 my %known_methods = ();
 130                 my @implements = ();
 131                 foreach my $parent ( @path ) {
 132                         foreach my $test ( sort keys %{$CONFIG->{$parent}} ) {
 133                                 my $type = $CONFIG->{$parent}->{$test};
 134
 135                                 # Does the class have a named method
 136                                 if ( $type eq 'method' ) {
 137                                         $known_methods{$test}++;
 138                                         Test::More::can_ok( $class, $test );
 139                                         next;
 140                                 }
 141
 142                                 # Does the class inherit from a named parent
 143                                 if ( $type eq 'isa' ) {
 144                                         Test::More::ok( $class->isa($test), "$class isa $test" );
 145                                         next;
 146                                 }
 147
 148                                 unless ( $type eq 'implements' ) {
 149                                         print "# Warning: Unknown test type '$type'";
 150                                         next;
 151                                 }
 152
 153                                 # When we 'implement' a class or interface,
 154                                 # we need to check the 'method' tests within
 155                                 # it, but not anything else. So we will add
 156                                 # the class name to a seperate queue to be
 157                                 # processed afterwards, ONLY if it is not
 158                                 # already in the normal @path, or already
 159                                 # on the seperate queue.
 160                                 next if grep { $_ eq $test } @path;
 161                                 next if grep { $_ eq $test } @implements;
 162                                 push @implements, $test;
 163                         }
 164                 }
 165
 166                 # Now, if it had any, go through and check the classes added
 167                 # because of any 'implements' tests
 168                 foreach my $parent ( @implements ) {
 169                         foreach my $test ( keys %{$CONFIG->{$parent}} ) {
 170                                 my $type = $CONFIG->{$parent}->{$test};
 171                                 if ( $type eq 'method' ) {
 172                                         # Does the class have a method
 173                                         $known_methods{$test}++;
 174                                         Test::More::can_ok( $class, $test );
 175                                 }
 176                         }
 177                 }
 178
 179                 if ( $CHECK_UNKNOWN_METHODS ) {
 180                         # Check for unknown public methods
 181                         my $methods = Class::Inspector->methods( $class, 'public', 'expanded' )
 182                                 or die "Failed to find public methods for class '$class'";
 183                         @$methods = grep { $_->[2] !~ /^[A-Z_]+$/ } # Internals stuff
 184                                 grep { $_->[1] ne 'Exporter' } # Ignore Exporter methods we don't overload
 185                                 grep { ! ($known_methods{$_->[2]} or $IGNORE{$_->[2]}) } @$methods;
 186                         if ( @$methods ) {
 187                                 print STDERR join '', map { "# Found undocumented method '$_->[2]' defined at '$_->[0]'\n" } @$methods;
 188                         }
 189                         Test::More::is( scalar(@$methods), 0, "No unknown public methods in '$class'" );
 190                 }
 191
 192                 if ( $CHECK_FUNCTION_COLLISIONS ) {
 193                         # Check for methods collisions.
 194                         # A method collision is where
 195                         #
 196                         #     Foo::Bar->method
 197                         #
 198                         # is actually interpreted as
 199                         #
 200                         #     &Foo::Bar()->method
 201                         #
 202                         no strict 'refs';
 203                         my @collisions = ();
 204                         foreach my $symbol ( sort keys %{"${class}::"} ) {
 205                                 next unless $symbol =~ s/::$//;
 206                                 next unless defined *{"${class}::${symbol}"}{CODE};
 207                                 print STDERR "Found function collision: ${class}->${symbol} clashes with ${class}::${symbol}\n";
 208                                 push @collisions, $symbol;
 209                         }
 210                         Test::More::is( scalar(@collisions), 0, "No function/class collisions in '$class'" );
 211                 }
 212         }
 213
 214         1;
 215 }
 216
 217 1;
 218
 219 __END__
 220
 221 =head1 NAME
 222
 223 Test::ClassAPI - Provides basic first-pass API testing for large class trees
 224
 225 =head1 DESCRIPTION
 226
 227 For many APIs with large numbers of classes, it can be very useful to be able
 228 to do a quick once-over to make sure that classes, methods, and inheritance
 229 is correct, before doing more comprehensive testing. This module aims to
 230 provide such a capability.
 231
 232 =head2 Using Test::ClassAPI
 233
 234 Test::ClassAPI is used with a fairly standard looking test script, with the
 235 API description contained in a __DATA__ section at the end of the script.
 236
 237   #!/usr/bin/perl
 238
 239   # Test the API for Foo::Bar
 240   use strict;
 241   use Test::More 'tests' => 123; # Optional
 242   use Test::ClassAPI;
 243
 244   # Load the API to test
 245   use Foo::Bar;
 246
 247   # Execute the tests
 248   Test::ClassAPI->execute;
 249
 250   __DATA__
 251
 252   Foo::Bar::Thing=interface
 253   Foo::Bar::Object=abstract
 254   Foo::Bar::Planet=class
 255
 256   [Foo::Bar::Thing]
 257   foo=method
 258
 259   [Foo::Bar::Object]
 260   bar=method
 261   whatsit=method
 262
 263   [Foo::Bar::Planet]
 264   Foo::Bar::Object=isa
 265   Foo::Bar::Thing=isa
 266   blow_up=method
 267   freeze=method
 268   thaw=method
 269
 270 Looking at the test script, the code itself is fairly simple. We first load
 271 Test::More and Test::ClassAPI. The loading and specification of a test plan
 272 is optional, Test::ClassAPI will provide a plan automatically if needed.
 273
 274 This is followed by a compulsory __DATA__ section, containing the API
 275 description. This description is in provided in the general form of a Windows
 276 style .ini file and is structured as follows.
 277
 278 =head2 Class Manifest
 279
 280 At the beginning of the file, in the root section of the config file, is a
 281 list of entries where the key represents a class name, and the value is one
 282 of either 'class', 'abstract', or 'interface'.
 283
 284 The 'class' entry indicates a fully fledged class. That is, the class is
 285 tested to ensure it has been loaded, and the existance of every method listed
 286 in the section ( and its superclasses ) is tested for.
 287
 288 The 'abstract' entry indicates an abstract class, one which is part of our
 289 class tree, and needs to exist, but is never instantiated directly, and thus
 290 does not have to itself implement all of the methods listed for it. Generally,
 291 many individual 'class' entries will inherit from an 'abstract', and thus a
 292 method listed in the abstract's section will be tested for in all the
 293 subclasses of it.
 294
 295 The 'interface' entry indicates an external interface that is not part of
 296 our class tree, but is inherited from by one or more of our classes, and thus
 297 the methods listed in the interface's section are tested for in all the
 298 classes that inherit from it. For example, if a class inherits from, and
 299 implements, the File::Handle interface, a C<File::Handle=interface> entry
 300 could be added, with the C<[File::Handle]> section listing all the methods
 301 in File::Handle that our class tree actually cares about. No tests, for class
 302 or method existance, are done on the interface itself.
 303
 304 =head2 Class Sections
 305
 306 Every class listed in the class manifest B<MUST> have an individual section,
 307 indicated by C<[Class::Name]> and containing a set of entries where the key
 308 is the name of something to test, and the value is the type of test for it.
 309
 310 The 'isa' test checks inheritance, to make sure that the class the section is
 311 for is (by some path) a sub-class of something else. This does not have to be
 312 an immediate sub-class. Any class refered to (recursively) in a 'isa' test
 313 will have its 'method' test entries applied to the class as well.
 314
 315 The 'method' test is a simple method existance test, using C<UNIVERSAL::can>
 316 to make sure that the method exists in the class.
 317
 318 =head1 METHODS
 319
 320 =head2 execute
 321
 322 The C<Test::ClassAPI> has a single method, C<execute> which is used to start
 323 the testing process. It accepts a single option argument, 'complete', which
 324 indicates to the testing process that the API listed should be considered a
 325 complete list of the entire API. This enables an additional test for each
 326 class to ensure that B<every> public method in the class is detailed in the
 327 API description, and that nothing has been "missed".
 328
 329 =head1 SUPPORT
 330
 331 Bugs should be submitted via the CPAN bug tracker, located at
 332
 333 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-ClassAPI>
 334
 335 For other issues, or commercial enhancement or support, contact the author.
 336
 337 =head1 AUTHOR
 338
 339 Adam Kennedy E<lt>adamk@cpan.orgE<gt>
 340
 341 =head1 COPYRIGHT
 342
 343 Copyright 2002 - 2009 Adam Kennedy.
 344
 345 This program is free software; you can redistribute
 346 it and/or modify it under the same terms as Perl itself.
 347
 348 The full text of the license can be found in the
 349 LICENSE file included with this module.
 350
 351 =cut