view release on metacpan or  search on metacpan

t/4019-object-introspection.t  view on Meta::CPAN

# ==== Setup Test Classes ====

object::define('Person',
    'name:Str:required',
    'age:Int:default(0)',
    'email:Str:readonly',
    'bio:Str:lazy:builder(_build_bio)',
    'tags:ArrayRef:default([])',
);

package Person;
sub _build_bio { "Default bio for " . shift->name }
package main;

object::define('Simple', 'foo', 'bar', 'baz');

# ==== object::clone() Tests ====

subtest 'clone() basic functionality' => sub {
    my $p = new Person name => 'Alice', age => 30, email => 'alice@example.com';
    my $clone = object::clone($p);

    isa_ok($clone, 'Person', 'Clone is same class');
    isnt($clone, $p, 'Clone is different reference');
    is($clone->name, 'Alice', 'Clone has same name');
    is($clone->age, 30, 'Clone has same age');
    is($clone->email, 'alice@example.com', 'Clone has same email');
};

subtest 'clone() shallow copy semantics' => sub {
    my $p = new Person name => 'Carol', age => 35, email => 'carol@example.com';
    push @{$p->tags}, 'original';

    my $clone = object::clone($p);

    # Both should see the same array reference
    is_deeply($p->tags, ['original'], 'Original has tag');
    is_deeply($clone->tags, ['original'], 'Clone shares same array');

    # Modify original's array
    push @{$p->tags}, 'added';

    # Clone should see the change (shallow copy = shared reference)
    is_deeply($clone->tags, ['original', 'added'],
        'Shallow copy shares references');
};

subtest 'clone() does not copy frozen state' => sub {
    my $p = new Person name => 'Dave', age => 40, email => 'dave@example.com';
    object::freeze($p);
    ok(object::is_frozen($p), 'Original is frozen');

    my $clone = object::clone($p);
    ok(!object::is_frozen($clone), 'Clone is not frozen');

    # Clone should be mutable
    $clone->age(41);
    is($clone->age, 41, 'Clone can be modified');
};

subtest 'clone() does not copy locked state' => sub {
    my $p = new Person name => 'Eve', age => 28, email => 'eve@example.com';
    object::lock($p);
    ok(object::is_locked($p), 'Original is locked');

    my $clone = object::clone($p);
    ok(!object::is_locked($clone), 'Clone is not locked');
};

subtest 'clone() with undef slots' => sub {
    my $s = new Simple foo => 'x';
    # bar and baz are undef
    my $clone = object::clone($s);

    is($clone->foo, 'x', 'Clone has foo value');
    ok(!defined $clone->bar, 'Clone bar is undef');
    ok(!defined $clone->baz, 'Clone baz is undef');
};

subtest 'clone() error handling' => sub {
    eval { object::clone("not an object") };
    like($@, qr/not an object/i, 'Croaks on non-object');

    eval { object::clone([1,2,3]) };
    like($@, qr/not an object/i, 'Croaks on plain arrayref');
};

# ==== object::properties() Tests ====

subtest 'properties() list context' => sub {
    my @props = object::properties('Person');
    is(scalar @props, 5, 'Person has 5 properties');
    ok((grep { $_ eq 'name' } @props), 'name in list');
    ok((grep { $_ eq 'age' } @props), 'age in list');
    ok((grep { $_ eq 'email' } @props), 'email in list');
    ok((grep { $_ eq 'bio' } @props), 'bio in list');
    ok((grep { $_ eq 'tags' } @props), 'tags in list');
};

subtest 'properties() scalar context' => sub {
    my $count = object::properties('Person');
    is($count, 5, 'Person has 5 properties (scalar)');
};

subtest 'properties() simple class' => sub {
    my @props = object::properties('Simple');
    is(scalar @props, 3, 'Simple has 3 properties');
    is_deeply([sort @props], ['bar', 'baz', 'foo'], 'Simple properties correct');
};

subtest 'properties() non-existent class' => sub {
    my @props = object::properties('NonExistent');
    is(scalar @props, 0, 'Empty list for non-existent class');

    my $count = object::properties('NonExistent');
    is($count, 0, 'Zero count for non-existent class');
};

# ==== object::slot_info() Tests ====

subtest 'slot_info() required typed property' => sub {
    my $info = object::slot_info('Person', 'name');
    is(ref $info, 'HASH', 'Returns hashref');
    is($info->{name}, 'name', 'name field correct');
    is($info->{index}, 1, 'index field correct (first property is slot 1)');
    is($info->{type}, 'Str', 'type field correct');
    is($info->{is_required}, 1, 'is_required is true');