File Coverage

blib/lib/Test/Plan.pm

Criterion	Covered	Total	%
statement	106	112	94.6
branch	52	60	86.6
condition	6	7	85.7
subroutine	22	22	100.0
pod	10	11	90.9
total	196	212	92.4

package Test::Plan;

use 5.005;

use strict;
use warnings FATAL => qw(all);

use Config;
use Exporter;
use Test::Builder ();

use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION @SkipReasons);

@ISA = qw(Exporter);

$VERSION = 0.03;

@EXPORT = qw(need
             plan
             need_module
             need_min_perl_version
             need_min_module_version
             need_perl_iolayers
             need_threads
             need_perl
             under_construction
             skip_reason);

my $Test = Test::Builder->new;


# you need to load Test::More before Test::Plan if
# modules want to use functions in their own namspaces
if ($INC{'Test/More.pm'}) {

  no warnings qw(redefine);

  *Test::More::plan = \&plan;
}

sub import {

  # this is why the warnings pragma sucks - I know better
  # than Exporter whether the warnings it is about to throw
  # are ok or not, but
  #   no warnings qw(redefine);
  # doesn't work here by design.
  local $^W=0;

  shift->export_to_level(1, undef, @_ ? @_ : @EXPORT);
}


#---------------------------------------------------------------------
# plan() intelligently.  essentially a combination of
# Apache::Test::plan() and Test::More::plan()
#---------------------------------------------------------------------
sub plan {

  my @plan = @_;

  # Apache::Test::plan()
  if (@plan % 2) {

    my $condition = pop @plan;
    my $ref = ref $condition;
    my $meets_condition = 0;

    if ($ref) {
      if ($ref eq 'CODE') {
        # plan tests $n, \&foo;
        $meets_condition = $condition->();
      }
      elsif ($ref eq 'ARRAY') {
        # plan tests $n, [qw(CGI Foo::Bar)];
        $meets_condition = need_module($condition);
      }
      else {
        die "don't know how to handle a condition of type $ref";
      }
    }
    else {
      # we have the verdict already: true/false
      $meets_condition = $condition ? 1 : 0;
    }

    unless ($meets_condition) {
      my $reason = join ', ',
        @SkipReasons ? @SkipReasons : '';

      @SkipReasons = ();  # reset

      $Test->plan(skip_all => $reason);

      # this will not be reached except in tests, since
      # Test::Builder::plan() calls exit();
      return;
    }
  }

  $Test->plan(@plan);
}


#---------------------------------------------------------------------
# very similar to Apache::Test::need_module() except that it doesn't
# worry about Apache C modules for obvious reasons
#---------------------------------------------------------------------
sub need_module {

    my @modules = grep defined $_,
        ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_;

    my @reasons = ();
    for (@modules) {
        eval "require $_";
        if ($@) {
            push @reasons, "cannot find module '$_'";
        }
    }
    if (@reasons) {
        push @SkipReasons, @reasons;
        return 0;
    }
    else {
        return 1;
    }
}


#---------------------------------------------------------------------
# nearly identical to Apache::Test::need_min_perl_version()
# as of 1.21.  here no version means any version and we trap
# non-numeric warnings
#---------------------------------------------------------------------
sub need_min_perl_version {
    my $version = shift;

    # no version means any version
    return 1 unless defined $version;

    {
      no warnings qw(numeric);
      return 1 if $] >= $version;
    }

    push @SkipReasons, "perl >= $version is required";
    return 0;
}


#---------------------------------------------------------------------
# nearly identical to Apache::Test::need_min_module_version()
# as of 1.21.  here no version means any version
#---------------------------------------------------------------------
sub need_min_module_version {
    my($module, $version) = @_;

    # need_module requires the perl module
    return 0 unless need_module($module);

    # no version means any version
    return 1 unless defined $version;

    # support dev versions like 0.18_01
    return 1
        if eval { no warnings qw(numeric); $module->VERSION($version) };

    push @SkipReasons, "$module version $version or higher is required";
    return 0;
}


#---------------------------------------------------------------------
# identical to Apache::Test::need_perl_iolayers() as of 1.21
#---------------------------------------------------------------------
sub need_perl_iolayers {
    if (my $ext = $Config{extensions}) {
        #XXX: better test?  might need to test patchlevel
        #if support depends bugs fixed in bleedperl
        return $ext =~ m:PerlIO/scalar:;
    }
    0;
}


#---------------------------------------------------------------------
# identical to Apache::Test::config_enabled() as of 1.21
# not exported, so don't use it (it should be marked as private)
#---------------------------------------------------------------------
sub config_enabled {
    my $key = shift;
    defined $Config{$key} and $Config{$key} eq 'define';
}


#---------------------------------------------------------------------
# nearly identical to Apache::Test::need_perl() as of 1.21
#---------------------------------------------------------------------
sub need_perl {
    my $thing = shift || '';
    #XXX: $thing could be a version
    my $config;

    my $have = \&{"need_perl_$thing"};
    if (defined &$have) {
        return 1 if $have->();
    }
    else {
        for my $key ($thing, "use$thing") {
            if (exists $Config{$key}) {
                $config = $key;
                return 1 if config_enabled($key);
            }
        }
    }

    push @SkipReasons, $config ?
      "Perl was not built with $config enabled" :
        "$thing is not available with this version of Perl";

    return 0;
}


#---------------------------------------------------------------------
# similar Apache::Test::need_threads() as of 1.21
# except we don't check APR
#---------------------------------------------------------------------
sub need_threads {
    my $status = 1;

    # check Perl's useithreads
    my $key = 'useithreads';
    unless (exists $Config{$key} and config_enabled($key)) {
        $status = 0;
        push @SkipReasons, "Perl was not built with 'ithreads' enabled";
    }

    return $status;
}


#---------------------------------------------------------------------
# identical to Apache::Test::under_construction as of 1.21
#---------------------------------------------------------------------
sub under_construction {
    push @SkipReasons, "This test is under construction";
    return 0;
}


#---------------------------------------------------------------------
# identical to Apache::Test::skip_reason() as of 1.21
#---------------------------------------------------------------------
sub skip_reason {
    my $reason = shift || 'no reason specified';
    push @SkipReasons, $reason;
    return 0;
}


#---------------------------------------------------------------------
# identical to Apache::Test::need() as of 1.21
#---------------------------------------------------------------------
sub need {
    my $need_all = 1;
    for my $cond (@_) {
        if (ref $cond eq 'HASH') {
            while (my($reason, $value) = each %$cond) {
                $value = $value->() if ref $value eq 'CODE';
                next if $value;
                push @SkipReasons, $reason;
                $need_all = 0;
            }
        }
        elsif ($cond =~ /^(0|1)$/) {
            $need_all = 0 if $cond == 0;
        }
        else {
            $need_all = 0 unless need_module($cond);
        }
    }
    return $need_all;
}

1;

__END__