view release on metacpan or  search on metacpan

lib/Test/Spec.pm  view on Meta::CPAN

  my $list = $_Package_Tests{$class} ||= [];
  return @$list;
}

# runtests
# PACKAGE->runtests # @ARGV or $ENV{SPEC}
# PACKAGE->runtests(PATTERNS)
sub runtests {
  my $class = $_[0];
  if (not defined $class) {
    $class = caller;
  }
  elsif (not eval { $class->isa(__PACKAGE__) }) {
    $class = caller;
  }
  else {
    shift;  # valid class, remove from arg stack.
  }
  $class->_materialize_tests;
  $class->phase(EXECUTION_PHASE);

  my @which = @_         ? @_           :
              $ENV{SPEC} ? ($ENV{SPEC}) : ();

  my @tests = $class->_pick_tests(@which);
  return $class->_execute_tests( @tests );
}

sub builder {
  # this is a singleton.
  Test::Builder->new;
}

sub _pick_tests {
  my ($class,@matchers) = @_;
  my @tests = $class->tests;

  my $pattern = join("|", @matchers);
  @tests = grep { $_->name =~ /$pattern/i } @tests;

  return @tests;
}

sub _execute_tests {
  my ($class,@tests) = @_;
  for my $test (@tests) {
    $test->run();
  }

  # Ensure we don't keep any references to user variables so they go out
  # of scope in a predictable fashion.
  %_Package_Tests = %_Package_Contexts = ();

  # XXX: this doesn't play nicely with Test::NoWarnings and friends
  $class->builder->done_testing;
}

# it DESC => CODE
# it CODE
# it DESC
sub it(@) {
  my $package = caller;
  my $code;
  if (@_ && ref($_[-1]) eq 'CODE') {
    $code = pop;
  }
  my $name = shift;
  if (not ($code || $name)) {
    Carp::croak "it() requires at least one of (description,code)";
  }
  $name ||= "behaves as expected (whatever that means)";
  push @{ _autovivify_context($package)->tests }, {
    name => $name,
    code => $code,
    todo => $TODO,
  };
  return;
}

# alias "they" to "it", for describing behavior of multiple items
sub they(@);
BEGIN { *they = \&it }

# describe DESC => CODE
# describe CODE
sub describe(@) {
  my $package = caller;
  my $code = pop;
  if (ref($code) ne 'CODE') {
    Carp::croak "expected subroutine reference as last argument";
  }
  my $name = shift || $package;

  my $container;
  if ($_Current_Context) {
    $container = $_Current_Context->context_lookup;
  }
  else {
    $container = $_Package_Contexts{$package} ||= Test::Spec::_ixhash();
  }

  __PACKAGE__->_accumulate_examples({
    container => $container,
    name => $name,
    class => $package,
    code => $code,
    label => $name,
  });
}

# around CODE
sub around(&) {
  my $package = caller;
  my $code = pop;
  if (ref($code) ne 'CODE') {
    Carp::croak "expected subroutine reference as last argument";
  }
  my $context = _autovivify_context($package);
  push @{ $context->around_blocks }, { code => $code };
}