view release on metacpan or  search on metacpan

t/unit.t  view on Meta::CPAN

};

# Purpose: calling import() again must NOT add a second entry
subtest 'import() -- no duplicate when called on a package that already inherits' => sub {
	plan tests => 2;

	# UT::ImportA already has Class::Abstract from the previous subtest
	my $count_before = scalar grep { $_ eq $CLASS_ABSTRACT } @UT::ImportA::ISA;

	# Second import call -- must not change the count
	{ package UT::ImportA; Class::Abstract->import() }

	my $count_after = scalar grep { $_ eq $CLASS_ABSTRACT } @UT::ImportA::ISA;

	# Entry count must be unchanged
	is $count_after, $count_before,
		'calling import() twice does not duplicate the entry in @ISA';

	# Sanity: the count should be exactly one
	is $count_after, $TRUE,
		'Class::Abstract appears exactly once in @UT::ImportA::ISA';
};

# Purpose: import() must return the module name as a typed string
subtest 'import() -- return value is the module name as a typed string' => sub {
	plan tests => 3;

	# Install a spy to confirm set_return is called with the right schema.
	# The spy passes through to the original, so import() still works.
	my $spy = spy 'Class::Abstract::set_return';

	# Call import() from a fresh package so the normal (non-early-return) path runs
	my $ret;
	{ package UT::ImportB; our @ISA = (); $ret = Class::Abstract->import() }

	# Restore the spy before any assertion that may call set_return itself
	restore_all();

	diag "import() returned: '$ret'" if $ENV{TEST_VERBOSE};

	# The return value must equal the module name
	is $ret, $CLASS_ABSTRACT, 'import() returns the string "Class::Abstract"';

	# Validate the return type using the documented schema
	returns_ok $ret, $config{schema_string},
		'import() return satisfies the { type => "string" } schema';

	# Verify set_return was invoked (typed-return contract honoured)
	my @calls = $spy->();
	ok scalar @calls >= $TRUE,
		'set_return() was called inside import() for the typed return';
};

# Purpose: import() must not add anything to Class::Abstract's own @ISA
subtest 'import() -- does not register Class::Abstract into its own @ISA' => sub {
	plan tests => 1;

	# Snapshot the ISA array before any call
	my @snapshot = @Class::Abstract::ISA;

	# Re-entering import() from the same module is blocked by the self-guard.
	# We verify the invariant directly: ISA must be identical before and after.
	is_deeply \@Class::Abstract::ISA, \@snapshot,
		'@Class::Abstract::ISA is unchanged (self-registration guard holds)';
};

# ===========================================================================
# SECTION: new()
#
# POD contract:
#   - Returns a blessed empty hashref of class $class
#   - Croaks for directly abstract classes (when enforcement is active)
#   - Accepts a blessed object as the invocant
#   - Rejects unblessed references with an error
#   - Rejects undef with an error
#   - Bypass variables suppress the abstract croak
# ===========================================================================

# Purpose: a concrete class must be successfully instantiated
subtest 'new() -- returns a blessed hashref for a concrete class' => sub {
	plan tests => 2;

	my $obj;

	# Enforcement on: UT::Concrete is not abstract, so new() must succeed
	enforcement_on {
		lives_ok { $obj = UT::Concrete->new() }
			'UT::Concrete->new() lives (concrete class)';
	};

	# The returned value must be a blessed reference
	ok blessed($obj), 'new() returns a blessed reference';
};

# Purpose: the object must carry the correct class, not a base class
subtest 'new() -- blesses the object into the concrete invocant class' => sub {
	plan tests => 1;

	# ref() on the returned object must equal the calling class
	my $obj = UT::Concrete->new();
	is ref($obj), $config{pkg_concrete},
		'new() blesses the object into UT::Concrete, not Class::Abstract';
};

# Purpose: directly abstract class must croak when enforcement is active
subtest 'new() -- croaks for a directly abstract class (enforcement on)' => sub {
	plan tests => 2;

	enforcement_on {
		# throws_ok verifies exact error message format from the POD
		throws_ok { UT::Abstract->new() }
			qr/Cannot instantiate abstract class UT::Abstract directly/,
			'new() croaks with the exact documented error for abstract class';

		# Verify the canonical phrase is present in $@
		like $@, qr/Cannot instantiate abstract class/,
			'$@ contains the documented error phrase';
	};
};

# Purpose: $BYPASS = truthy must suppress the abstract-class croak