view release on metacpan or  search on metacpan

local/lib/perl5/Test/Spec/Example.pm  view on Meta::CPAN

package Test::Spec::Example;

# Purpose: represents an `it` block

use strict;
use warnings;

########################################################################
# NO USER-SERVICEABLE PARTS INSIDE.
########################################################################

use Carp ();
use Scalar::Util ();

sub new {
  my ($class, $args) = @_;

  if (!$args || ref($args) ne 'HASH') {
    Carp::croak "usage: $class->new(\\%args)";
  }

  my $self = bless {}, $class;
  foreach my $attr ( qw/name description code builder context/ ) {
    $self->{$attr} = $args->{$attr} || Carp::croak "$attr missing";
  }

  Scalar::Util::weaken($self->{context});

  return $self;
}

sub name        { shift->{name} }
sub description { shift->{description} }
sub code        { shift->{code} }
sub builder     { shift->{builder} }
sub context     { shift->{context} }

# Build a stack from the starting context
# down to the current context
sub stack {
  my ($self) = @_;

  my $ctx = $self->context;

  my @ancestors = $ctx;
  while ( $ctx = $ctx->parent ) {
      push @ancestors, $ctx;
  }

  return reverse(@ancestors);
}

sub run  {
  my ($self) = @_;

  # clobber Test::Builder's ok() method just like Test::Class does,
  # but without screwing up underscores.
  no warnings 'redefine';
  my $orig_builder_ok = \&Test::Builder::ok;
  local *Test::Builder::ok = sub {
    my ($builder,$test,$desc) = splice(@_,0,3);
    $desc ||= $self->description;
    local $Test::Builder::Level = $Test::Builder::Level+1;
    $orig_builder_ok->($builder, $test, $desc, @_);
  };

  # Run the test
  eval { $self->_runner($self->stack) };

  # And trap any errors
  if (my $err = $@) {
    my $builder = $self->builder;
    my $description = $self->description;

    # eval in case stringification overload croaks
    chomp($err = eval { $err . '' } || 'unknown error');
    my ($file,$line);
    ($file,$line) = ($1,$2) if ($err =~ s/ at (.+?) line (\d+)\.\Z//);

    # disable ok()'s diagnostics so we can generate a custom TAP message
    my $old_diag = $builder->no_diag;
    $builder->no_diag(1);
    # make sure we can restore no_diag
    eval { $builder->ok(0, $description) };
    my $secondary_err = $@;
    # no_diag needs a defined value, so double-negate it to get either '' or 1
    $builder->no_diag(!!$old_diag);