The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/env perl
#
# define.t
#
# Test cases for Test::Spec definitions
#
########################################################################
#

package Testcase::Spec::Define;
use strict;
use warnings;
use Test::Deep;
use Test::More tests => 18;

# builds a hash of "parent name" => { "child name" => ... }
sub build_context_tree {
  my $node = shift;
  my $tree = shift || {};
  for my $ctx ($node->contexts) {
    build_context_tree($ctx, $tree->{$ctx->name} = {});
  }
  return $tree;
}

{
  package Stub;
  sub new { bless do { \my $stub }, shift() }
  sub AUTOLOAD { shift }
}

my ($outer,$inner) = (0,0);
my ($before_all,$before_each) = (0,0);
my ($after_all,$after_each) = (0,0);
my ($ctx_in_desc, $ctx_in_before, $ctx_in_after);

my $enter_leave_state = undef;
my ($on_enter,$on_leave) = (0,0);

{
  package A;
  use Test::Spec;  # imports
  use base qw(Test::Spec);

  describe "Outer 1" => sub {
    $outer++;

    $ctx_in_desc = A->current_context;

    before all => sub {
      $before_all++;
      $ctx_in_before = A->current_context;
    };
    before each => sub {
      $before_each++;
    };

    it "runs outer test 1" => sub { ok(1, "ran outer test 1") };

    describe "Inner 1" => sub {
      $inner++;
      A->current_context->on_enter(sub {
        $enter_leave_state = 'ENTER';
        $on_enter++;
      });
      A->current_context->on_leave(sub {
        $enter_leave_state = 'LEAVE' if $enter_leave_state eq 'ENTER';
        $on_leave++;
      });

      it "runs inner test 1" => sub { ok(1) };
    };

    after each => sub {
      $after_each++;
      $ctx_in_after = A->current_context;
    };

    after all => sub {
      $after_all++;
    };
  };

  context "Outer 1" => sub {
    $outer++;
    context "Inner 1" => sub {
      $inner++;
    };
    context "Inner 2" => sub {
    };
  };

  # tests
  describe "Outer 2" => sub {
  };
}

is( $outer, 2, "both outer blocks ran");
is( $inner, 2, "both inner blocks ran");

my $tree = build_context_tree('A');
is_deeply( $tree, {
  "Outer 1" => { "Inner 1" => {}, "Inner 2" => {} },
  "Outer 2" => {},
}, "contexts shallow-merged");

is( $before_all,  0, "before-all not run during definition" );
is( $before_each, 0, "before-all not run during definition" );
is( $after_each,  0, "after-each not run during definition" );
is( $after_all,   0, "after-all not run during definition" );
ok( $on_enter > 0, "enter block called");
is( $on_enter, $on_leave, "entered and left symmetrically" );

is( A->phase, Test::Spec::DEFINITION_PHASE, "definition phase" );

{
  no warnings 'once';
  my $stub = Stub->new;
  local *A::builder          = sub { $stub };
  local *Test::More::builder = sub { $stub };
  A->runtests;
}

is( A->phase, Test::Spec::EXECUTION_PHASE, "execution phase" );

is( $ctx_in_desc, $ctx_in_before,
  "describe() and before() contexts are the same (for hooks, esp. mocks)");
is( $ctx_in_desc, $ctx_in_after,
  "describe() and after() contexts are the same (for hooks, esp. mocks)");

is( $outer,       2, "describe blocks did not re-run");
is( $before_all,  1, "before-all ran once before all tests" );
is( $before_each, 2, "before-each ran before each test");
is( $after_each,  2, "after-each ran after each test");

TODO: {
  local $TODO = "after-all untestable without changes to Spec.pm";
  is($after_all,  1, "after-all ran once after all tests" );
}