view release on metacpan or  search on metacpan

t/edge_cases.t  view on Meta::CPAN

#!/usr/bin/perl
# t/edge_cases.t -- destructive, boundary-condition, and security tests.
#
# Deliberately tries to break or subvert Class::Abstract by passing pathological
# inputs, mocking upstream dependencies with edge-case returns, manipulating
# @ISA at runtime, exploiting bypass mechanics, and verifying robustness under
# circular data structures.

use strict;
use warnings;

use Readonly;
use Scalar::Util     qw(blessed reftype weaken);
use Test::Most;
use Test::Mockingbird;
use Test::Returns;

use Class::Abstract;

# ---------------------------------------------------------------------------
# Configuration -- every constant and boundary value in one place
# ---------------------------------------------------------------------------

my %config = (
	# Package names (EC:: prefix avoids collisions with other test files)
	pkg_abstract	=> 'EC::Abstract',
	pkg_concrete	=> 'EC::Concrete',
	pkg_dynamic	=> 'EC::Dynamic',
	pkg_circ_a	=> 'EC::CircA',
	pkg_circ_b	=> 'EC::CircB',
	pkg_module	=> 'Class::Abstract',

	# Boundary string values -- chosen to probe the defined() / length() guards
	str_zero	=> '0',          # falsy but length 1; must be treated as valid
	str_spaces	=> '   ',        # whitespace-only; length 3 but not a valid identifier
	str_long	=> 'A' x 5_000,  # very long identifier; no length limit in spec
	str_numeric	=> '123',        # numeric string; valid Perl package name

	# Truthy non-boolean bypass values (documented in the POD warnings section)
	bypass_str_false	=> 'false',  # counterintuitive but truthy
	bypass_str_zero_e	=> '0E0',    # numerically 0 but string-truthy
	bypass_float	=> 0.1,          # truthy number
	bypass_ref	=> [],             # reference; truthy

	# Expected error patterns matching the module POD exactly
	err_new_unblessed	=> qr/new\(\) invocant must be a class name or blessed object, got/,
	err_new_undef		=> qr/new\(\) requires a defined class name as invocant/,
	err_chk_unblessed	=> qr/check_abstract\(\) requires a class name or blessed object/,
	err_chk_undef		=> qr/check_abstract\(\) requires a defined class name/,
	err_isabs_undef		=> qr/is_abstract\(\) requires a class name or object invocant/,
	err_abstract		=> qr/Cannot instantiate abstract class \S+ directly/,

	# Test::Returns schemas
	schema_string	=> { type => 'string'  },
	schema_integer	=> { type => 'integer' },
);

# Readonly constants -- prevent accidental mutation
Readonly::Scalar my $CLASS_ABSTRACT	=> 'Class::Abstract';
Readonly::Scalar my $TRUE		=> 1;
Readonly::Scalar my $FALSE		=> 0;

# ---------------------------------------------------------------------------
# Fixture packages for edge-case scenarios
# ---------------------------------------------------------------------------

# EC::Abstract: directly abstract via use parent
{
	package EC::Abstract;
	use parent -norequire, 'Class::Abstract';
}

# EC::Concrete: concrete subclass of EC::Abstract

t/edge_cases.t  view on Meta::CPAN

# Purpose: document that enforcement has no fallback if croak is neutralized
subtest 'mock croak as no-op -- enforcement is defeated (design limitation)' => sub {
	plan tests => 2;

	# Replace croak with a silent no-op that returns without dying
	mock 'Class::Abstract::croak' => sub { return };

	enforcement_on {
		# EC::Abstract->new() would normally croak, but the mock prevents it
		my $obj = EC::Abstract->new();

		restore_all();

		# With croak neutralized, execution continues to 'return bless {}, $class'
		ok blessed($obj),
			'SECURITY: neutralized croak lets abstract class be instantiated';

		is ref($obj), $config{pkg_abstract},
			'SECURITY: resulting object is blessed into the abstract class';
	};
};

# ===========================================================================
# SECTION 14: Context sensitivity for is_abstract()
#
# is_abstract() returns a scalar integer.  In list context it must still
# deliver a single meaningful value.  In boolean context the result must
# be truthy for abstract classes and falsy for concrete ones.
# ===========================================================================

# Purpose: is_abstract() behaves consistently across calling contexts
subtest 'is_abstract() -- consistent in list, scalar, and boolean contexts' => sub {
	plan tests => 5;

	# List context: must return a list of exactly one element
	my @list = EC::Abstract->is_abstract();
	is scalar @list, 1,
		'is_abstract() in list context returns a 1-element list';

	is $list[0], $TRUE,
		'is_abstract() list context: first element is 1 for abstract class';

	# Scalar context: must return the integer 1 for abstract class
	my $scalar = EC::Abstract->is_abstract();
	is $scalar, $TRUE,
		'is_abstract() in scalar context returns 1 for abstract class';

	# Boolean context: abstract must be truthy, concrete must be falsy.
	# Explicit parens prevent 'ok CLASS->method' being parsed as 'CLASS->ok(...)'.
	ok( EC::Abstract->is_abstract(),
		'EC::Abstract->is_abstract() is truthy in boolean context' );

	ok( !EC::Concrete->is_abstract(),
		'EC::Concrete->is_abstract() is falsy in boolean context' );
};

# ===========================================================================
# SECTION 15: Weakened reference as invocant
#
# Scalar::Util::weaken() removes the strong reference count.  Once all
# strong references are gone the object is destroyed and the weak ref becomes
# undef.  A live (still-referenced) weakened blessed ref must pass new().
# A dead (garbage-collected) weakened ref becomes undef and must croak.
# ===========================================================================

# Purpose: live weakened blessed ref works; dead weakened ref croaks
subtest 'weakened references as invocants' => sub {
	plan tests => 3;

	# Live weak ref: a strong ref also exists, so the object survives
	my $strong = EC::Concrete->new();
	my $weak   = $strong;
	weaken($weak);

	diag 'weak ref: ' . (defined($weak) ? ref($weak) : 'undef') if $ENV{TEST_VERBOSE};

	# $weak is still alive because $strong holds a strong reference
	ok defined($weak) && blessed($weak),
		'precondition: weakened ref is still alive (strong ref holds it)';

	# A live weakened blessed ref must be accepted by new()
	lives_ok { $strong->new() }
		'live weakened blessed ref: new() succeeds via strong ref';

	# Dead weak ref: no strong references, object is garbage-collected immediately
	my $dead_weak = do { my $obj = EC::Concrete->new(); weaken($obj); $obj };

	# The dead weak ref is undef; ref(undef) = "", so it hits the undef guard
	throws_ok { Class::Abstract::new($dead_weak) }
		$config{err_new_undef},
		'dead weakened ref (undef) causes new() to croak with defined-class-name error';
};

# ===========================================================================
# SECTION 16: $_ is never clobbered by any public method
#
# Any grep or map over @ISA inside _is_direct_abstract could overwrite $_.
# Verify $_ is unchanged across all four public methods under varied inputs.
# ===========================================================================

# Purpose: no public method may mutate $_ in the calling scope
subtest '$_ not clobbered by any public method under varied inputs' => sub {
	plan tests => 4;

	# Use a value containing characters that would cause obvious corruption
	Readonly::Scalar my $SENTINEL => 'SENTINEL_DO_NOT_MUTATE';

	# import() must leave $_ alone
	{
		local $_ = $SENTINEL;
		{ package EC::DontClobberImport; our @ISA = (); Class::Abstract->import() }
		is $_, $SENTINEL, '$_ unchanged after import()';
	}

	# new() must leave $_ alone
	{
		local $_ = $SENTINEL;
		EC::Concrete->new();
		is $_, $SENTINEL, '$_ unchanged after new()';
	}

	# check_abstract() must leave $_ alone
	{
		local $_ = $SENTINEL;
		enforcement_on { Class::Abstract::check_abstract($config{pkg_concrete}) };
		is $_, $SENTINEL, '$_ unchanged after check_abstract()';
	}

	# is_abstract() must leave $_ alone (grep on @ISA is the risk)
	{
		local $_ = $SENTINEL;
		EC::Abstract->is_abstract();
		EC::Concrete->is_abstract();
		Class::Abstract->is_abstract($config{pkg_abstract});
		is $_, $SENTINEL, '$_ unchanged after multiple is_abstract() calls';
	}
};

done_testing;