-
Notifications
You must be signed in to change notification settings - Fork 135
/
clone.t
147 lines (120 loc) · 5.16 KB
/
clone.t
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
use v6;
use Test;
plan 39;
# L<S12/Cloning/You can clone an object, changing some of the attributes:>
class Foo {
has $.attr;
method set_attr ($attr) { $.attr = $attr; }
method get_attr () { $.attr }
}
my $a = Foo.new(:attr(13));
isa-ok($a, Foo);
is($a.get_attr(), 13, '... got the right attr value');
my $c = $a.clone();
isa-ok($c, Foo);
is($c.get_attr(), 13, '... cloned object retained attr value');
my $val;
lives-ok {
$val = $c === $a;
}, "... cloned object isn't identity equal to the original object";
ok($val.defined && !$val, "... cloned object isn't identity equal to the original object");
my $d;
lives-ok {
$d = $a.clone(attr => 42)
}, '... cloning with supplying a new attribute value';
my $val2;
lives-ok {
$val2 = $d.get_attr()
}, '... getting attr from cloned value';
is($val2, 42, '... cloned object has proper attr value');
# Test to cover RT #62828, which exposed a bad interaction between while loops
# and cloning.
{
class A {
has $.b;
};
while shift [A.new( :b(0) )] -> $a {
is($a.b, 0, 'sanity before clone');
my $x = $a.clone( :b($a.b + 1) );
is($a.b, 0, 'clone did not change value in original object');
is($x.b, 1, 'however, in the clone it was changed');
last;
}
}
# RT 88254
#?niecza todo "Exception: Representation P6cursor does not support cloning"
{
my ($p, $q);
$p = 'a' ~~ /$<foo>='a'/;
# previously it was timeout on Rakudo
lives-ok { $q = $p.clone }, 'Match object can be cloned';
is ~$q{'foo'}, 'a', 'cloned Match object retained named capture value';
}
# test cloning of array and hash attributes
{
# array
my class ArrTest {
has @.array;
}
# hash
my class HshTest {
has %.hash;
}
# when cloning with new versions of attributes, it should not update the original
my $a1 = ArrTest.new(:array<a b>);
my $a2 = $a1.clone(:array<c d>);
is-deeply $a1.array, ['a', 'b'], 'original object has its original array';
#?rakudo.jvm todo 'cloned object has @.array as Parcel instead of Array RT #125577'
is-deeply $a2.array, ['c', 'd'], 'cloned object has the newly-provided array (1)';
is $a2.array[0], 'c', 'cloned object has the newly-provided array (2)';
is $a2.array[1], 'd', 'cloned object has the newly-provided array (3)';
my $b1 = HshTest.new(hash=> 'a' => 'b' );
my $b2 = $b1.clone(hash=> 'c' => 'd' );
is-deeply $b1.hash, {'a' => 'b'}, 'original object has its original hash';
#?rakudo.jvm todo 'cloned object has @.hash as Pair instead of Hash RT #125577'
is-deeply $b2.hash, {'c' => 'd'}, 'cloned object has the newly-provided hash (1)';
is $b2.hash.elems, 1, 'cloned object has the newly-provided hash (2)';
is $b2.hash<c>, 'd', 'cloned object has the newly-provided hash (3)';
# when cloning without new versions of attributes, it should not deep-copy the array/hash
my $a3 = ArrTest.new(:array<a b>);
my $a4 = $a3.clone;
is-deeply $a3.array, ['a', 'b'], 'original array attr sanity test';
is-deeply $a4.array, ['a', 'b'], 'cloned array attr sanity test';
push $a3.array, 'c';
is-deeply $a3.array, ['a', 'b', 'c'], 'array on original is updated';
is-deeply $a4.array, ['a', 'b', 'c'], 'array on copy is updated';
my $b3 = HshTest.new(hash=>{'a' => 'b'});
my $b4 = $b3.clone;
is-deeply $b3.hash, {'a' => 'b'}, 'original hash attr sanity test';
is-deeply $b4.hash, {'a' => 'b'}, 'cloned hash attr sanity test';
$b3.hash{'c'} = 'd';
is-deeply $b3.hash, {'a' => 'b', 'c' => 'd'}, 'hash on original is updated';
is-deeply $b4.hash, {'a' => 'b', 'c' => 'd'}, 'hash on copy is updated';
}
# test cloning of custom class objects
{
my class LeObject {
has $.identifier;
has @.arr;
has %.hsh;
}
my class LeContainer { has LeObject $.obj; }
my $cont = LeContainer.new(obj=>LeObject.new(identifier=>'1234', :arr<a b c>, :hsh{'x'=>'y'}));
my $cont_clone_diff = $cont.clone(obj=>LeObject.new(identifier=>'4567', :arr<d e f>, :hsh{'z'=>'a'}));
my $cont_clone_same = $cont.clone;
# cont_clone_diff should contain a new value, altering its contained values should not alter the original
is-deeply $cont_clone_diff.obj.arr, ['d', 'e', 'f'], 'cloned object sanity';
is-deeply $cont.obj.arr, ['a', 'b', 'c'], 'original object is untouched';
# change the cloned objects contained object, the original should be intact afterwards
$cont_clone_diff.obj.arr = 'g', 'h', 'i';
is-deeply $cont_clone_diff.obj.arr, ['g', 'h', 'i'], 'cloned object sanity';
is-deeply $cont.obj.arr, ['a', 'b', 'c'], 'original object is untouched';
# change attributes on contained object should change clones if a new object was not assigned
is-deeply $cont_clone_same.obj.arr, ['a', 'b', 'c'], 'cloned object has identical value';
is-deeply $cont.obj.arr, ['a', 'b', 'c'], 'original object sanity test';
$cont.obj.arr = 'j', 'k', 'l';
is-deeply $cont_clone_same.obj.arr, ['j', 'k', 'l'], 'cloned object has new value';
is-deeply $cont.obj.arr, ['j', 'k', 'l'], 'original object has new value';
}
lives-ok { Int.clone }, 'cloning a type object does not explode';
# vim: ft=perl6