File Coverage

blib/lib/Test/API.pm

Criterion	Covered	Total	%
statement	196	197	99.4
branch	43	48	89.5
condition	8	8	100.0
subroutine	42	42	100.0
pod	3	3	100.0
total	292	298	97.9

use 5.006;
use strict;
use warnings;

package Test::API;
# ABSTRACT: Test a list of subroutines provided by a module

our $VERSION = '0.010';

use Symbol ();

use Test::Builder::Module 0.86;
our @ISA    = qw/Test::Builder::Module/;
our @EXPORT = qw/public_ok import_ok class_api_ok/;

#--------------------------------------------------------------------------#

sub import_ok ($;@) { ## no critic
    my $package = shift;
    my %spec    = @_;
    for my $key (qw/export export_ok/) {
        $spec{$key} ||= [];
        $spec{$key} = [ $spec{$key} ] unless ref $spec{$key} eq 'ARRAY';
    }
    my $tb = _builder();
    my @errors;
    my %flagged;

    my $label = "importing from $package";

    return 0 unless _check_loaded( $package, $label );

    # test export
    {
        my $test_pkg = *{ Symbol::gensym() }{NAME};
        eval "package $test_pkg; use $package;"; ## no critic
        my ( $ok, $missing, $extra ) = _public_ok( $test_pkg, @{ $spec{export} } );
        if ( !$ok ) {
            push @errors, "not exported: @$missing" if @$missing;
            @flagged{@$missing} = (1) x @$missing if @$missing;
            push @errors, "unexpectedly exported: @$extra" if @$extra;
            @flagged{@$extra} = (1) x @$extra if @$extra;
        }
    }

    # test export_ok
    my @exportable;
    for my $fcn ( _public_fcns($package) ) {
        next if $flagged{$fcn}; # already complaining about this so skip
        next if grep { $fcn eq $_ } @{ $spec{export} }; # exported by default
        my $pkg_name = *{ Symbol::gensym() }{NAME};
        eval "package $pkg_name; use $package '$fcn';"; ## no critic
        my ( $ok, $missing, $extra ) = _public_ok( $pkg_name, $fcn );
        if ($ok) {
            push @exportable, $fcn;
        }
    }
    my ( $missing, $extra ) = _difference( $spec{export_ok}, \@exportable, );
    push @errors, "not optionally exportable: @$missing" if @$missing;
    push @errors, "extra optionally exportable: @$extra" if @$extra;

    # notify of results
    $tb->ok( !@errors, "importing from $package" );
    $tb->diag($_) for @errors;
    return !@errors;
}

#--------------------------------------------------------------------------#

sub public_ok ($;@) { ## no critic
    my ( $package, @expected ) = @_;
    my $tb    = _builder();
    my $label = "public API for $package";

    return 0 unless _check_loaded( $package, $label );

    my ( $ok, $missing, $extra ) = _public_ok( $package, @expected );
    $tb->ok( $ok, $label );
    if ( !$ok ) {
        $tb->diag("missing: @$missing") if @$missing;
        $tb->diag("extra: @$extra")     if @$extra;
    }
    return $ok;
}

#--------------------------------------------------------------------------#

sub class_api_ok ($;@) { ## no critic
    my ( $package, @expected ) = @_;
    my $tb    = _builder();
    my $label = "public API for class $package";

    return 0 unless _check_loaded( $package, $label );

    my ( $ok, $missing, $extra ) = _public_ok( $package, @expected );

    # Call ->can to check if missing methods might be provided
    # by parent classes...
    if ( !$ok ) {
        @$missing = grep { not $package->can($_) } @$missing;
        $ok = not( scalar(@$missing) + scalar(@$extra) );
    }

    $tb->ok( $ok, $label );
    if ( !$ok ) {
        $tb->diag("missing: @$missing") if @$missing;
        $tb->diag("extra: @$extra")     if @$extra;
    }
    return $ok;
}

#--------------------------------------------------------------------------#

sub _builder {
    return __PACKAGE__->builder;
}

#--------------------------------------------------------------------------#

sub _check_loaded {
    my ( $package, $label ) = @_;
    ( my $path = $package ) =~ s{::}{/}g;
    $path .= ".pm";
    if ( $INC{$path} ) {
        return 1;
    }
    else {
        my $tb = _builder();
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        $tb->ok( 0, $label );
        $tb->diag("Module '$package' not loaded");
        return;
    }
}

#--------------------------------------------------------------------------#

sub _difference {
    my ( $array1, $array2 ) = @_;
    my ( %only1, %only2 );
    @only1{@$array1} = (1) x @$array1;
    delete @only1{@$array2};
    @only2{@$array2} = (1) x @$array2;
    delete @only2{@$array1};
    return ( [ sort keys %only1 ], [ sort keys %only2 ] );
}

#--------------------------------------------------------------------------#

# list adapted from Pod::Coverage
my %private = map { ; $_ => 1 } qw(
  import unimport bootstrap

  AUTOLOAD BUILD BUILDARGS CLONE CLONE_SKIP DESTROY DEMOLISH meta

  TIESCALAR TIEARRAY TIEHASH TIEHANDLE

  FETCH STORE UNTIE FETCHSIZE STORESIZE POP PUSH SHIFT UNSHIFT SPLICE
  DELETE EXISTS EXTEND CLEAR FIRSTKEY NEXTKEY PRINT PRINTF WRITE
  READLINE GETC READ CLOSE BINMODE OPEN EOF FILENO SEEK TELL SCALAR

  MODIFY_REF_ATTRIBUTES MODIFY_SCALAR_ATTRIBUTES MODIFY_ARRAY_ATTRIBUTES
  MODIFY_HASH_ATTRIBUTES MODIFY_CODE_ATTRIBUTES MODIFY_GLOB_ATTRIBUTES
  MODIFY_FORMAT_ATTRIBUTES MODIFY_IO_ATTRIBUTES

  FETCH_REF_ATTRIBUTES FETCH_SCALAR_ATTRIBUTES FETCH_ARRAY_ATTRIBUTES
  FETCH_HASH_ATTRIBUTES FETCH_CODE_ATTRIBUTES FETCH_GLOB_ATTRIBUTES
  FETCH_FORMAT_ATTRIBUTES FETCH_IO_ATTRIBUTES
);

sub _public_fcns {
    my ($package) = @_;
    no strict qw(refs);
    my $stash = \%{"$package\::"};
    my @syms;
    for (keys %$stash) {
        push @syms,
             ref \$stash->{$_} eq 'GLOB'
               ? \$stash->{$_}
               : \*{"$package:\:$_"}
    }
    return grep { substr( $_, 0, 1 ) ne '_' && !$private{$_} && $_ !~ /^\(/ }
      map { ( my $f = *$_ ) =~ s/^\*$package\:://; $f }
      grep { defined( *$_{CODE} ) } @syms;
}

#--------------------------------------------------------------------------#

sub _public_ok ($;@) { ## no critic
    my ( $package, @expected ) = @_;
    my @fcns = _public_fcns($package);
    my ( $missing, $extra ) = _difference( \@expected, \@fcns );
    return ( !@$missing && !@$extra, $missing, $extra );
}

1;

__END__