view release on metacpan or  search on metacpan

t/extended_tests.t  view on Meta::CPAN

		our @ISA = ();
	}
	{
		package Diamond::Left2;
		our @ISA = ('Diamond::Base2');
	}
	{
		package Diamond::Right2;
		our @ISA = ('Diamond::Base2');
	}
	{
		package Diamond::Child2;
		our @ISA = ('Diamond::Left2', 'Diamond::Right2');
	}

	my @chain = Object::Configure::_get_inheritance_chain('Diamond::Child2');
	my %seen;
	my @dupes = grep { $seen{$_}++ } @chain;

	ok(!@dupes, 'no duplicate classes in chain');
	ok((grep { $_ eq 'Diamond::Base2'  } @chain), 'Base2 in chain');
	ok((grep { $_ eq 'Diamond::Child2' } @chain), 'Child2 in chain');
};

subtest '_get_inheritance_chain: %seen guard prevents duplicate entries in deep chain' => sub {
	# Perl 5.42+ rejects genuinely cyclic @ISA at the interpreter level, so we
	# cannot manufacture an A->B->A cycle in a test.  Instead we verify the %seen
	# guard indirectly: a 4-level linear chain should produce each class exactly
	# once even though every subclass "inherits" the grandparent transitively.
	plan tests => 2;

	{
		package Deep::Root3;   our @ISA = ();
	}
	{
		package Deep::Mid3;    our @ISA = ('Deep::Root3');
	}
	{
		package Deep::Child3;  our @ISA = ('Deep::Mid3');
	}
	{
		package Deep::Leaf3;   our @ISA = ('Deep::Child3');
	}

	my @chain = Object::Configure::_get_inheritance_chain('Deep::Leaf3');
	my %freq;
	$freq{$_}++ for @chain;
	my @dupes = grep { $freq{$_} > 1 } keys %freq;

	ok(!@dupes, 'no class appears twice in a deep linear chain');
	ok((grep { $_ eq 'Deep::Root3' } @chain), 'root class present in chain');
};

# ---------------------------------------------------------------------------
# SECTION 10 — _deep_merge(): all branch combinations
# ---------------------------------------------------------------------------

# Access the function directly
*_deep_merge = \&Object::Configure::_deep_merge;

subtest '_deep_merge: base not a hashref returns overlay' => sub {
	plan tests => 1;

	my $result = Object::Configure::_deep_merge('scalar_base', { a => 1 });
	is_deeply($result, { a => 1 }, 'overlay returned when base is scalar');
};

subtest '_deep_merge: overlay not a hashref returns overlay' => sub {
	plan tests => 1;

	my $result = Object::Configure::_deep_merge({ a => 1 }, 'scalar_overlay');
	is($result, 'scalar_overlay', 'scalar overlay returned directly');
};

subtest '_deep_merge: overlay undef returned as-is' => sub {
	plan tests => 1;

	my $result = Object::Configure::_deep_merge({ a => 1 }, undef);
	ok(!defined($result), 'undef overlay returned as undef');
};

subtest '_deep_merge: keys only in base are preserved' => sub {
	plan tests => 1;

	my $result = Object::Configure::_deep_merge({ a => 1, b => 2 }, { b => 99 });
	is($result->{a}, 1, 'base-only key preserved');
};

subtest '_deep_merge: keys only in overlay are added' => sub {
	plan tests => 1;

	my $result = Object::Configure::_deep_merge({ a => 1 }, { z => 42 });
	is($result->{z}, 42, 'overlay-only key added');
};

subtest '_deep_merge: overlay scalar overwrites base scalar' => sub {
	plan tests => 1;

	my $result = Object::Configure::_deep_merge({ k => 'old' }, { k => 'new' });
	is($result->{k}, 'new', 'overlay scalar wins');
};

subtest '_deep_merge: nested hashes are recursively merged' => sub {
	plan tests => 3;

	my $base    = { top => { a => 1, b => 2 } };
	my $overlay = { top => { b => 99, c => 3 } };
	my $result  = Object::Configure::_deep_merge($base, $overlay);

	is($result->{top}{a}, 1,  'base sub-key preserved');
	is($result->{top}{b}, 99, 'overlay sub-key wins');
	is($result->{top}{c}, 3,  'overlay-only sub-key added');
};

subtest '_deep_merge: overlay hash over base non-hash replaces' => sub {
	plan tests => 1;

	# base has scalar, overlay has hash — overlay wins (not recursed)
	my $result = Object::Configure::_deep_merge(
		{ k => 'scalar' },
		{ k => { nested => 1 } }
	);
	is_deeply($result->{k}, { nested => 1 },
		'overlay hash replaces base scalar');
};

subtest '_deep_merge: base hash over overlay non-hash, overlay wins' => sub {
	plan tests => 1;

	# base has hash, overlay has scalar — scalar overlay wins
	my $result = Object::Configure::_deep_merge(
		{ k => { deep => 1 } },
		{ k => 'flat' }
	);
	is($result->{k}, 'flat', 'scalar overlay replaces base hash');
};

subtest '_deep_merge: does not mutate either input' => sub {
	plan tests => 2;

	my $base    = { a => 1 };
	my $overlay = { b => 2 };
	my $result  = Object::Configure::_deep_merge($base, $overlay);

	ok(!exists $base->{b},    'base not mutated');
	ok(!exists $overlay->{a}, 'overlay not mutated');
};

# ---------------------------------------------------------------------------
# SECTION 11 — register_object(): guard and repeat-call branches
# ---------------------------------------------------------------------------

subtest 'register_object: undef class croaks' => sub {
	plan tests => 1;
	_reset_globals();
	dies_ok { Object::Configure::register_object(undef, bless {}, 'Foo') }
		'undef class croaks';
};

subtest 'register_object: undef obj croaks' => sub {
	plan tests => 1;
	_reset_globals();
	dies_ok { Object::Configure::register_object('Foo', undef) }
		'undef obj croaks';
};

subtest 'register_object: first call installs USR1 handler (non-Windows)' => sub {
	plan skip_all => 'SIGUSR1 not available on Windows' if $^O eq 'MSWin32';
	plan tests => 2;

	_reset_globals();
	my $obj = bless {}, 'Register::Test::One';
	lives_ok { Object::Configure::register_object('Register::Test::One', $obj) }
		'first register_object does not croak';
	ok(defined $Object::Configure::_original_usr1_handler,
		'_original_usr1_handler set after first call');
};

subtest 'register_object: second call skips handler re-installation' => sub {
	plan skip_all => 'SIGUSR1 not available on Windows' if $^O eq 'MSWin32';
	plan tests => 2;

	_reset_globals();
	my $obj1 = bless {}, 'Register::Test::Two';
	my $obj2 = bless {}, 'Register::Test::Two';

	Object::Configure::register_object('Register::Test::Two', $obj1);
	my $handler_after_first = $SIG{USR1};

	Object::Configure::register_object('Register::Test::Two', $obj2);
	my $handler_after_second = $SIG{USR1};

	is($handler_after_first, $handler_after_second,
		'USR1 handler not replaced on second call');
	is(scalar @{$Object::Configure::_object_registry{'Register::Test::Two'}},
		2, 'both objects in registry');
};

subtest 'register_object: original coderef handler chained on SIGUSR1' => sub {
	plan skip_all => 'SIGUSR1 not available on Windows' if $^O eq 'MSWin32';
	plan tests => 1;

	_reset_globals();

	my $chained = 0;
	$SIG{USR1} = sub { $chained++ };