view release on metacpan or  search on metacpan

t/function.t  view on Meta::CPAN

	ok(grep({ $_ eq 'UNIVERSAL' } @chain), 'UNIVERSAL in chain');
	ok(grep({ $_ eq 'Test::Parent' } @chain), 'Parent in chain');
	ok(grep({ $_ eq 'Test::Child' } @chain), 'Child in chain');

	# Verify order: UNIVERSAL, Parent, Child
	my %positions;
	for my $i (0..$#chain) {
		$positions{$chain[$i]} = $i;
	}
	ok($positions{'UNIVERSAL'} < $positions{'Test::Parent'}, 'UNIVERSAL before Parent');
	ok($positions{'Test::Parent'} < $positions{'Test::Child'}, 'Parent before Child');

	done_testing();
};

subtest '_get_inheritance_chain() - processes class hierarchy' => sub {
	{
		package Test::Base;
		sub new { bless {}, shift }
	}
	{
		package Test::Derived;
		use base 'Test::Base';
		sub new { bless {}, shift }
	}

	my @chain = Object::Configure::_get_inheritance_chain('Test::Derived');

	ok(scalar(@chain) > 0, 'Chain populated');
	ok((grep { $_ eq 'Test::Derived' } @chain), 'Derived class in chain');
	ok((grep { $_ eq 'Test::Base'    } @chain), 'Base class in chain');
	ok((grep { $_ eq 'UNIVERSAL'     } @chain), 'UNIVERSAL in chain');

	done_testing();
};

subtest '_get_inheritance_chain() - adds UNIVERSAL for classes with no parents' => sub {
	my @chain = Object::Configure::_get_inheritance_chain('Test::Orphan');

	ok((grep { $_ eq 'UNIVERSAL'    } @chain), 'UNIVERSAL added for orphan class');
	ok((grep { $_ eq 'Test::Orphan' } @chain), 'Class itself in chain');

	done_testing();
};

subtest '_get_inheritance_chain() - UNIVERSAL appears exactly once' => sub {
	my @chain = Object::Configure::_get_inheritance_chain('Test::Solo');

	my $universal_count = grep { $_ eq 'UNIVERSAL' } @chain;
	is($universal_count, 1, 'UNIVERSAL appears exactly once');

	done_testing();
};

subtest '_deep_merge() - merges two hashes' => sub {
	my $base = {
		foo => 1,
		bar => 2,
		nested => { a => 1 }
	};
	my $overlay = {
		bar => 3,
		baz => 4,
		nested => { b => 2 }
	};

	my $result = Object::Configure::_deep_merge($base, $overlay);

	is($result->{foo}, 1, 'Base value preserved');
	is($result->{bar}, 3, 'Overlay overrides base');
	is($result->{baz}, 4, 'New value from overlay');
	is($result->{nested}{a}, 1, 'Nested base value preserved');
	is($result->{nested}{b}, 2, 'Nested overlay value added');

	done_testing();
};

subtest '_deep_merge() - handles non-hash inputs' => sub {
	my $result1 = Object::Configure::_deep_merge('not_hash', { foo => 1 });
	is_deeply($result1, { foo => 1 }, 'Returns overlay when base not hash');

	my $result2 = Object::Configure::_deep_merge({ foo => 1 }, 'not_hash');
	is($result2, 'not_hash', 'Returns overlay when overlay not hash (overlay takes precedence)');

	my $result3 = Object::Configure::_deep_merge('not_hash', 'also_not_hash');
	is($result3, 'also_not_hash', 'Returns overlay when neither is hash');

	done_testing();
};

subtest 'instantiate() - creates object with configuration' => sub {
	{
		package Test::Instantiable;
		sub new {
			my ($class, $params) = @_;
			return bless $params, $class;
		}
	}

	my $obj = Object::Configure::instantiate(
		class => 'Test::Instantiable',
		foo => 'bar'
	);

	ok(blessed($obj), 'Object is blessed');
	isa_ok($obj, 'Test::Instantiable', 'Object');
	is($obj->{foo}, 'bar', 'Parameter passed through');
	ok(blessed($obj->{logger}), 'Logger added');

	done_testing();
};

subtest 'register_object() - requires both arguments' => sub {
	throws_ok {
		Object::Configure::register_object('Some::Class', undef);
	} qr/register_object: Usage/, 'Croaks with undef object';

	throws_ok {
		Object::Configure::register_object(undef, {});
	} qr/register_object: Usage/, 'Croaks with undef class';

	done_testing();
};

subtest 'register_object() - adds to registry' => sub {
	my $obj = bless { foo => 'bar' }, 'Test::Registerable';

	Object::Configure::register_object('Test::Registerable', $obj);

	ok(exists($Object::Configure::_object_registry{'Test::Registerable'}),
		'Registry entry created');
	ok(scalar(@{$Object::Configure::_object_registry{'Test::Registerable'}}) > 0,
		'Object added to registry');

	# Cleanup
	delete $Object::Configure::_object_registry{'Test::Registerable'};

	done_testing();
};

subtest 'get_signal_handler_info() - returns info hash' => sub {
	my $info = Object::Configure::get_signal_handler_info();

	ok(ref($info) eq 'HASH', 'Returns hashref');
	ok(exists($info->{original_usr1}), 'Has original_usr1 key');
	ok(exists($info->{current_usr1}), 'Has current_usr1 key');