view release on metacpan or  search on metacpan

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

package Test::Spec::Context;
use strict;
use warnings;

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

use Carp ();
use List::Util ();
use Scalar::Util ();
use Test::More ();
use Test::Spec qw(*TODO $Debug :constants);
use Test::Spec::Example;
use Test::Spec::TodoExample;

our @CARP_NOT = ();

my $_StackDepth = 0;
my $_AroundStackDepth = 1;

sub new {
  my $class = shift;
  my $self = bless {}, $class;

  if (@_) {
    my $args = shift;
    if (@_ || ref($args) ne 'HASH') {
      Carp::croak "usage: $class->new(\\%args)";
    }
    while (my ($name,$val) = each (%$args)) {
      $self->$name($val);
    }
  }

  my $this = $self;
  Scalar::Util::weaken($this);
  $self->on_enter(sub {
    $this && $this->_debug(sub {
      printf STDERR "%s[%s]\n", '  ' x $_StackDepth, $this->_debug_name;
      $_StackDepth++;
    });
  });

  $self->on_leave(sub {
    $this && $this->_debug(sub {
      $_StackDepth--;
      printf STDERR "%s[/%s]\n", '  ' x $_StackDepth, $this->_debug_name;
    });
  });

  return $self;
}

sub clone {
  my $orig = shift;
  my $clone = bless { %$orig }, ref($orig);

  my $orig_contexts = $clone->context_lookup;
  my $new_contexts  = Test::Spec::_ixhash();

  while (my ($name,$ctx) = each %$orig_contexts) {
    my $new_ctx = $ctx->clone;
    $new_ctx->parent($clone);
    $new_contexts->{$name} = $new_ctx;
  }
  $clone->{_context_lookup} = $new_contexts;

  return $clone;
}

# The reference we keep to our parent causes the garbage collector to
# destroy the innermost context first, which is what we want. If that
# becomes untrue at some point, it will be easy enough to descend the
# hierarchy and run the after("all") tests that way.
sub DESTROY {
  my $self = shift;
  # no need to tear down what was never set up
  if ($self->_has_run_before_all) {
    $self->_run_after_all_once;
  }
}

sub name {
  my $self = shift;
  $self->{_name} = shift if @_;
  return exists($self->{_name})
    ? $self->{_name}
    : ($self->{_name} = '');
}

sub parent {
  my $self = shift;
  if (@_) {
    $self->{_parent} = shift;
    Scalar::Util::weaken($self->{_parent}) if ref($self->{_parent});
  }
  return $self->{_parent};
}

sub class {
  my $self = shift;
  $self->{_class} = shift if @_;
  if ($self->{_class}) {
    return $self->{_class};
  }
  elsif ($self->parent) {
    return $self->parent->class;
  }
  else {
    return undef;
  }
}

sub context_lookup {
  my $self = shift;
  return $self->{_context_lookup} ||= Test::Spec::_ixhash();
}

sub before_blocks {
  my $self = shift;
  return $self->{_before_blocks} ||= [];
}

sub after_blocks {
  my $self = shift;
  return $self->{_after_blocks} ||= [];
}

sub around_blocks {
  my $self = shift;
  return $self->{_around_blocks} ||= [];
}

sub tests {
  my $self = shift;
  return $self->{_tests} ||= [];
}

sub on_enter_blocks {
  my $self = shift;
  return $self->{_on_enter_blocks} ||= [];
}

sub on_leave_blocks {
  my $self = shift;
  return $self->{_on_leave_blocks} ||= [];
}

# private attributes
sub _has_run_before_all {
  my $self = shift;
  $self->{__has_run_before_all} = shift if @_;
  return $self->{__has_run_before_all};
}

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

  $context->class($self->class);
  $context->contextualize($code, $example);
}

# Runs $code within a context (specifically, having been wrapped
#  with on_enter/on_leave setup and teardown,
#  and with around blocks).
sub contextualize {
  my ($self,$code,$example) = @_;
  local $Test::Spec::_Current_Context = $self;
  local $self->{_has_run_on_enter} = {};
  local $self->{_has_run_on_leave} = {};
  local $TODO = $TODO;
  my @errs;

  eval { $self->_run_on_enter };
  push @errs, $@ if $@;

  if (not @errs) {
    $code = $self->wrap_code_with_around_blocks($code,$example);

    eval { $code->($example) };
    push @errs, $@ if $@;
  }

  # always run despite errors, since on_enter might have set up stuff that
  # needs to be torn down, before another on_enter died
  eval { $self->_run_on_leave };
  push @errs, $@ if $@;

  if (@errs) {
    if ($TODO) {
      # make it easy for tests to declare todo status, just "$TODO++"
      $TODO = "(unimplemented)" if $TODO =~ /^\d+$/;
      # expected to fail
      Test::More::ok(1);
    }
    else {
      # rethrow
      die join("\n", @errs);
    }
  }

  return;
}

# Wraps $code within a context with around blocks.
sub wrap_code_with_around_blocks {
  my ($self,$code,$example) = @_;
  for (@{ $self->around_blocks }) {
    $code = $self->wrap_code_with_around_block($code,$_,$example);
  }
  return $code;
}

# Wraps $code within a context with around block.
sub wrap_code_with_around_block {
  my ($self,$inner_code,$block,$example) = @_;

  my $this = $self;
  Scalar::Util::weaken($this);

  return sub {
    my $yield_ok = 0;
    local $Test::Spec::Yield = sub {
      $yield_ok = 1;
      $inner_code->($example);
    };
    $this && $this->_debug(sub {
      printf STDERR "%s[around CODE %s] %s {\n", '__' x $_AroundStackDepth, $self->_debug_name, "$block";
      $_AroundStackDepth++;
    });

    $block->{code}->($example);
    
    $this && $this->_debug(sub {
      $_AroundStackDepth--;
      printf STDERR "%s[/around CODE %s] %s }\n", '__' x $_AroundStackDepth, $self->_debug_name, "$block";
    });
    unless ($yield_ok) {
      local @CARP_NOT = qw( Test::Spec Test::Spec::Example );
      Carp::croak "around CODE doesn't call yield";
    }
  };
}

#
# Copyright (c) 2010-2011 by Informatics Corporation of America.
# 
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#

1;