Portabel perl clone function for clone objects

clone.pl

use strict;
use warnings;

use Test::More;

############################
# code under test
############################

sub clone {
    my ($obj) = @_;
    my $cls = ref($obj);
    my $copy = {};
    for my $key (keys %$obj) {
        my $ref = ref($obj->{$key});

        if ($ref eq "ARRAY") {
            $copy->{$key} = [ @{ $obj->{$key} } ];
        }
        elsif ($ref eq "HASH") {
            $copy->{$key} = { %{ $obj->{$key} } };
        }
        else {
            $copy->{$key} = $obj->{$key};
        }
    }
    bless $copy, $cls;
}

############################
# helper class
############################

{
    package Foo;
    sub new {
        my ($class, %args) = @_;
        bless { %args }, $class;
    }
}

############################
# 1–5: basic object cloning
############################

my $o1 = Foo->new(x => 1);
my $c1 = clone($o1);

is(ref $c1, 'Foo', 'class preserved');
is($c1->{x}, 1, 'scalar field copied');
$o1->{x} = 2;
is($c1->{x}, 1, 'scalar not aliased');

ok($o1 ne $c1, 'clone is a different object');

############################
# 6–10: arrayrefs
############################

my $o2 = Foo->new(a => [1,2,3]);
my $c2 = clone($o2);

is_deeply($c2->{a}, [1,2,3], 'array copied');
ok($c2->{a} ne $o2->{a}, 'array ref not aliased');

$o2->{a}[0] = 99;
is($c2->{a}[0], 1, 'array mutation does not leak');

push @{ $c2->{a} }, 4;
is_deeply($o2->{a}, [99,2,3], 'reverse mutation isolation');

############################
# 11–15: hashrefs
############################

my $o3 = Foo->new(h => { a => 1, b => 2 });
my $c3 = clone($o3);

is_deeply($c3->{h}, { a => 1, b => 2 }, 'hash copied');
ok($c3->{h} ne $o3->{h}, 'hash ref not aliased');

$o3->{h}{a} = 42;
is($c3->{h}{a}, 1, 'hash mutation does not leak');

$c3->{h}{b} = 99;
is($o3->{h}{b}, 2, 'reverse hash mutation isolated');

############################
# 16–18: coderefs (shared)
############################

my $sub = sub { 123 };
my $o4 = Foo->new(cb => $sub);
my $c4 = clone($o4);

is($c4->{cb}->(), 123, 'coderef preserved');
ok($c4->{cb} eq $o4->{cb}, 'coderef shared (expected)');

############################
# 19–21: nested structures (shallow behavior)
############################

my $nested = { x => [1,2] };
my $o5 = Foo->new(n => $nested);
my $c5 = clone($o5);

ok($c5->{n} ne $o5->{n}, 'top-level hash copied');
ok($c5->{n}{x} eq $o5->{n}{x}, 'nested array shared (shallow)');

$o5->{n}{x}[0] = 9;
is($c5->{n}{x}[0], 9, 'nested mutation leaks (expected)');

############################
# 22–24: objects inside fields (shared)
############################

my $inner = Foo->new(x => 5);
my $o6 = Foo->new(inner => $inner);
my $c6 = clone($o6);

ok($c6->{inner} eq $o6->{inner}, 'inner object shared');
$o6->{inner}{x} = 10;
is($c6->{inner}{x}, 10, 'shared object mutation visible');

############################
# 25–27: scalar refs (shared)
############################

my $scalar = 7;
my $o7 = Foo->new(r => \$scalar);
my $c7 = clone($o7);

ok($c7->{r} eq $o7->{r}, 'scalar ref shared');
${$o7->{r}} = 99;
is(${$c7->{r}}, 99, 'scalar ref mutation visible');

############################
# 28–30: empty, multiple fields, stability
############################

my $o8 = Foo->new();
my $c8 = clone($o8);
is_deeply($c8, $o8, 'empty object cloned');

my $o9 = Foo->new(a => 1, b => [2], c => { d => 3 });
my $c9 = clone($o9);
is($c9->{a}, 1, 'mixed scalar ok');
is_deeply($c9->{b}, [2], 'mixed array ok');
is_deeply($c9->{c}, { d => 3 }, 'mixed hash ok');

done_testing;