The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#! /usr/local/bin/perl

use lib qw(./t);
use warnings;
use strict;
use Test_Framework;

# Test the copy() method.  The equals() method is used to
# do much of the testing.

use Class::Generate qw(&class);

class Basic_Class => [ mem => '@', new => { style => 'positional mem' } ];
class
    All_Types => {
	Scalar => "\$",
	Array  => '@',
	Hash   => '%',
	Scalar_Class => 'Basic_Class',
	Array_Class  => '@Basic_Class',
	Hash_Class   => '%Basic_Class'
    };

use vars qw($v $w);
$v = new All_Types;
Test {
    $v = (new All_Types)->copy;
    ! grep defined $v->$_(), qw(Scalar Array Hash Scalar_Class Array_Class Hash_Class)
};

Test { (new All_Types)->equals((new All_Types)->copy) };

Test {
    $v = (new All_Types Scalar => 1)->copy;
    $v->Scalar == 1
};

Test { (new All_Types Scalar => 1)->equals((new All_Types Scalar => 1)->copy) };

Test {
    my @a = (1, 2, 3);
    $v = (new All_Types Array => [@a])->copy;
    Arrays_Equal [$v->Array], [@a];
};

Test {
    my %h = (e1 => 1, e2 => 2);
    $v = (new All_Types Hash => {%h})->copy;
    Arrays_Equal [sort { $a cmp $b } $v->Hash], [sort { $a cmp $b } (%h)];
};

Test {
    my @a = (1, 2, 3);
    $v = (new All_Types Scalar_Class => (new Basic_Class [@a]))->copy;
    Arrays_Equal [$v->Scalar_Class->mem], [@a];
};

Test {
    my @a0 = (1, 2, 3);
    my @a1 = (4, 5, 6);
    $v = (new All_Types Array_Class => [(new Basic_Class [@a0]), (new Basic_Class [@a1])])->copy;
    ($v->Array_Class_size == 1 &&
     Arrays_Equal([$v->Array_Class(0)->mem], [@a0]) &&
     Arrays_Equal([$v->Array_Class(1)->mem], [@a1]));
};

Test {
    my @a0 = (1, 2, 3);
    my @a1 = (4, 5, 6);
    $v = (new All_Types Hash_Class => { e1 => (new Basic_Class [@a0]),
					e2 => (new Basic_Class [@a1]) } )->copy;
    (scalar($v->Hash_Class_keys) == 2 &&
     Arrays_Equal([sort { $a cmp $b } $v->Hash_Class_keys], [qw(e1 e2)]) &&
     Arrays_Equal([$v->Hash_Class('e1')->mem], [@a0]) &&
     Arrays_Equal([$v->Hash_Class('e2')->mem], [@a1]));
};

Test {
    $v = new All_Types;
    $v->Scalar(1);
    $v->Array([2, 3]);
    $v->Hash({e1 => 3, e2 => 4});
    $v->Scalar_Class(new Basic_Class [5, 6]);
    $v->Array_Class([(new Basic_Class [7]), (new Basic_Class [8])]);
    $v->Hash_Class({e1 => (new Basic_Class [7]), e2 => (new Basic_Class [8])});
    $v->equals($v->copy);
};

Test {
    class Picky_Copy => {
	Array => { type => '@', nocopy => 1 },
	Hash  => { type => '%', nocopy => 1 }
    };
    1;
};

Test {
    $v = new Picky_Copy Array => [1, 2, 3], Hash => { e1 => 4, e2 => 5 };
    $w = $v->copy;
    $v->equals($w) && $w->equals($v);
};

Test { $v->Array(3, 4); $v->equals($w) };
Test {
    $v->Hash('e3', 6);
    $v->Hash('e1', 7);
    $v->delete_Hash('e2');
    $v->equals($w);
};

Report_Results;