1use Test::More;
2
3BEGIN
4{
5    $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}
6      and eval "use $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}; 1;";
7    $@ and plan skip_all => "No $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} found.";
8}
9
10use Hash::Merge qw( merge );
11
12my %left = (
13    ss => 'left',
14    sa => 'left',
15    sh => 'left',
16    so => 'left',
17    as => ['l1', 'l2'],
18    aa => ['l1', 'l2'],
19    ah => ['l1', 'l2'],
20    ao => ['l1', 'l2'],
21    hs => {left => 1},
22    ha => {left => 1},
23    hh => {left => 1},
24    ho => {left => 1},
25    os => {foo => bless({key => 'left'}, __PACKAGE__)},
26    oa => {foo => bless({key => 'left'}, __PACKAGE__)},
27    oh => {foo => bless({key => 'left'}, __PACKAGE__)},
28    oo => {foo => bless({key => 'left'}, __PACKAGE__)},
29);
30
31my %right = (
32    ss => 'right',
33    as => 'right',
34    hs => 'right',
35    os => 'right',
36    sa => ['r1', 'r2'],
37    aa => ['r1', 'r2'],
38    ha => ['r1', 'r2'],
39    oa => ['r1', 'r2'],
40    sh => {right => 1},
41    ah => {right => 1},
42    hh => {right => 1},
43    oh => {right => 1},
44    so => {foo => bless({key => 'right'}, __PACKAGE__)},
45    ao => {foo => bless({key => 'right'}, __PACKAGE__)},
46    ho => {foo => bless({key => 'right'}, __PACKAGE__)},
47    oo => {foo => bless({key => 'right'}, __PACKAGE__)},
48);
49
50# Test left precedence
51Hash::Merge::set_behavior('LEFT_PRECEDENT');
52my %lp = %{merge(\%left, \%right)};
53
54is_deeply($lp{ss}, 'left', 'Left Precedent - Scalar on Scalar');
55is_deeply($lp{sa}, 'left', 'Left Precedent - Scalar on Array');
56is_deeply($lp{sh}, 'left', 'Left Precedent - Scalar on Hash');
57is_deeply($lp{so}, 'left', 'Left Precedent - Scalar on Object');
58is_deeply($lp{as}, ['l1', 'l2', 'right'], 'Left Precedent - Array on Scalar');
59is_deeply($lp{aa}, ['l1', 'l2', 'r1', 'r2'], 'Left Precedent - Array on Array');
60is_deeply($lp{ah}, ['l1', 'l2', 1], 'Left Precedent - Array on Hash');
61is_deeply($lp{ao}, ['l1', 'l2', {key => 'right'}], 'Left Precedent - Array on Object');
62is_deeply($lp{hs}, {left => 1}, 'Left Precedent - Hash on Scalar');
63is_deeply($lp{ha}, {left => 1}, 'Left Precedent - Hash on Array');
64is_deeply(
65    $lp{hh},
66    {
67        left  => 1,
68        right => 1,
69    },
70    'Left Precedent - Hash on Hash'
71);
72is_deeply(
73    $lp{ho},
74    {
75        left => 1,
76        foo  => {
77            key => 'right',
78        },
79    },
80    'Left Precedent - Hash on Object'
81);
82is_deeply($lp{os}, {foo => {key => 'left'}}, 'Left Precedent - Object on Scalar');
83is_deeply($lp{oa}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array');
84is_deeply(
85    $lp{oh},
86    {
87        foo   => {key => 'left'},
88        right => 1,
89    },
90    'Left Precedent - Object on Array'
91);
92is_deeply($lp{oo}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array');
93
94Hash::Merge::set_behavior('RIGHT_PRECEDENT');
95my %rp = %{merge(\%left, \%right)};
96
97is_deeply($rp{ss}, 'right', 'Right Precedent - Scalar on Scalar');
98is_deeply($rp{sa}, ['left', 'r1', 'r2'], 'Right Precedent - Scalar on Array');
99is_deeply($rp{sh}, {right => 1}, 'Right Precedent - Scalar on Hash');
100is_deeply($rp{so}, {foo => {key => 'right'}}, 'Right Precedent - Scalar on Object');
101is_deeply($rp{as}, 'right', 'Right Precedent - Array on Scalar');
102is_deeply($rp{aa}, ['l1', 'l2', 'r1', 'r2'], 'Right Precedent - Array on Array');
103is_deeply($rp{ah}, {right => 1}, 'Right Precedent - Array on Hash');
104is_deeply($rp{ao}, {foo => {key => 'right'}}, 'Right Precedent - Array on Object');
105is_deeply($rp{hs}, 'right', 'Right Precedent - Hash on Scalar');
106is_deeply($rp{ha}, [1, 'r1', 'r2'], 'Right Precedent - Hash on Array');
107is_deeply(
108    $rp{hh},
109    {
110        left  => 1,
111        right => 1,
112    },
113    'Right Precedent - Hash on Hash'
114);
115is_deeply(
116    $rp{ho},
117    {
118        foo  => {key => 'right'},
119        left => 1,
120    },
121    'Right Precedent - Hash on Object'
122);
123is_deeply($rp{os}, 'right', 'Right Precedent - Object on Scalar');
124is_deeply($rp{oa}, [{key => 'left'}, 'r1', 'r2'], 'Right Precedent - Object on Array');
125is_deeply(
126    $rp{oh},
127    {
128        foo   => {key => 'left'},
129        right => 1,
130    },
131    'Right Precedent - Object on Hash'
132);
133is_deeply($rp{oo}, {foo => {key => 'right'}}, 'Right Precedent - Object on Object');
134
135Hash::Merge::set_behavior('STORAGE_PRECEDENT');
136my %sp = %{merge(\%left, \%right)};
137
138is_deeply($sp{ss}, 'left', 'Storage Precedent - Scalar on Scalar');
139is_deeply($sp{sa}, ['left', 'r1', 'r2'], 'Storage Precedent - Scalar on Array');
140is_deeply($sp{sh}, {right => 1}, 'Storage Precedent - Scalar on Hash');
141is_deeply($sp{so}, {foo => {key => 'right'}}, 'Storage Precedent - Scalar on Object');
142is_deeply($sp{as}, ['l1', 'l2', 'right'], 'Storage Precedent - Array on Scalar');
143is_deeply($sp{aa}, ['l1', 'l2', 'r1', 'r2'], 'Storage Precedent - Array on Array');
144is_deeply($sp{ah}, {right => 1}, 'Storage Precedent - Array on Hash');
145is_deeply($sp{ao}, {foo => {key => 'right'}}, 'Storage Precedent - Array on Object');
146is_deeply($sp{hs}, {left => 1}, 'Storage Precedent - Hash on Scalar');
147is_deeply($sp{ha}, {left => 1}, 'Storage Precedent - Hash on Array');
148is_deeply(
149    $sp{hh},
150    {
151        left  => 1,
152        right => 1,
153    },
154    'Storage Precedent - Hash on Hash'
155);
156is_deeply(
157    $sp{ho},
158    {
159        foo  => {key => 'right'},
160        left => 1,
161    },
162    'Storage Precedent - Hash on Object'
163);
164is_deeply($sp{os}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Scalar');
165is_deeply($sp{oa}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Array');
166is_deeply(
167    $sp{oh},
168    {
169        foo   => {key => 'left'},
170        right => 1,
171    },
172    'Storage Precedent - Object on Hash'
173);
174is_deeply($sp{oo}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Object');
175
176Hash::Merge::set_behavior('RETAINMENT_PRECEDENT');
177my %rep = %{merge(\%left, \%right)};
178
179is_deeply($rep{ss}, ['left', 'right'], 'Retainment Precedent - Scalar on Scalar');
180is_deeply($rep{sa}, ['left', 'r1', 'r2'], 'Retainment Precedent - Scalar on Array');
181is_deeply(
182    $rep{sh},
183    {
184        left  => 'left',
185        right => 1,
186    },
187    'Retainment Precedent - Scalar on Hash'
188);
189is_deeply(
190    $rep{so},
191    {
192        foo  => {key => 'right'},
193        left => 'left',
194    },
195    'Retainment Precedent - Scalar on Object'
196);
197is_deeply($rep{as}, ['l1', 'l2', 'right'], 'Retainment Precedent - Array on Scalar');
198is_deeply($rep{aa}, ['l1', 'l2', 'r1', 'r2'], 'Retainment Precedent - Array on Array');
199is_deeply(
200    $rep{ah},
201    {
202        l1    => 'l1',
203        l2    => 'l2',
204        right => 1
205    },
206    'Retainment Precedent - Array on Hash'
207);
208is_deeply(
209    $rep{ao},
210    {
211        foo => {key => 'right'},
212        l1  => 'l1',
213        l2  => 'l2',
214    },
215    'Retainment Precedent - Array on Object'
216);
217is_deeply(
218    $rep{hs},
219    {
220        left  => 1,
221        right => 'right'
222    },
223    'Retainment Precedent - Hash on Scalar'
224);
225is_deeply(
226    $rep{ha},
227    {
228        left => 1,
229        r1   => 'r1',
230        r2   => 'r2',
231    },
232    'Retainment Precedent - Hash on Array'
233);
234is_deeply(
235    $rep{hh},
236    {
237        left  => 1,
238        right => 1,
239    },
240    'Retainment Precedent - Hash on Hash'
241);
242is_deeply(
243    $rep{ho},
244    {
245        foo  => {key => 'right'},
246        left => 1,
247    },
248    'Retainment Precedent - Hash on Object'
249);
250is_deeply(
251    $rep{os},
252    {
253        foo   => {key => 'left'},
254        right => 'right',
255    },
256    'Retainment Precedent - Object on Scalar'
257);
258is_deeply(
259    $rep{oa},
260    {
261        foo => {key => 'left'},
262        r1  => 'r1',
263        r2  => 'r2',
264    },
265    'Retainment Precedent - Object on Array'
266);
267is_deeply(
268    $rep{oh},
269    {
270        foo   => {key => 'left'},
271        right => 1,
272    },
273    'Retainment Precedent - Object on Hash'
274);
275is_deeply($rep{oo}, {foo => [{key => 'left'}, {key => 'right'},]}, 'Retainment Precedent - Object on Object');
276
277Hash::Merge::add_behavior_spec(
278    {
279        SCALAR => {
280            SCALAR => sub { $_[0] },
281            ARRAY  => sub { $_[0] },
282            HASH   => sub { $_[0] }
283        },
284        ARRAY => {
285            SCALAR => sub { $_[0] },
286            ARRAY  => sub { $_[0] },
287            HASH   => sub { $_[0] }
288        },
289        HASH => {
290            SCALAR => sub { $_[0] },
291            ARRAY  => sub { $_[0] },
292            HASH   => sub { $_[0] }
293        }
294    },
295    "My Behavior"
296);
297
298SCOPE: {
299    my $err;
300    local $SIG{__WARN__} = sub { $err = shift };
301    eval { Hash::Merge::specify_behavior( Hash::Merge::get_behavior_spec("My Behavior"), "My Behavior" ) };
302    $@ and $err = $@;
303    like($err, qr/already defined. Please take another name/, "Cannot add behavior spec twice");
304}
305
306my %cp = %{merge(\%left, \%right)};
307
308is_deeply($cp{ss}, 'left', 'Custom Precedent - Scalar on Scalar');
309is_deeply($cp{sa}, 'left', 'Custom Precedent - Scalar on Array');
310is_deeply($cp{sh}, 'left', 'Custom Precedent - Scalar on Hash');
311is_deeply($cp{so}, 'left', 'Custom Precedent - Scalar on Object');
312is_deeply($cp{as}, ['l1', 'l2'], 'Custom Precedent - Array on Scalar');
313is_deeply($cp{aa}, ['l1', 'l2'], 'Custom Precedent - Array on Array');
314is_deeply($cp{ah}, ['l1', 'l2'], 'Custom Precedent - Array on Hash');
315is_deeply($cp{ao}, ['l1', 'l2'], 'Custom Precedent - Array on Object');
316is_deeply($cp{hs}, {left => 1}, 'Custom Precedent - Hash on Scalar');
317is_deeply($cp{ha}, {left => 1}, 'Custom Precedent - Hash on Array');
318is_deeply($cp{hh}, {left => 1}, 'Custom Precedent - Hash on Hash');
319is_deeply($cp{ho}, {left => 1}, 'Custom Precedent - Hash on Hash');
320is_deeply($cp{os}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Scalar');
321is_deeply($cp{oa}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Array');
322is_deeply($cp{oh}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Hash');
323is_deeply($cp{oo}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Object');
324
325{
326    package    # Test sponsored by David Wheeler
327      HashMergeHashContainer;
328    my $h1 = {
329        foo => bless {one => 2},
330        __PACKAGE__
331    };
332    my $h2 = {
333        foo => bless {one => 2},
334        __PACKAGE__
335    };
336    my $merged = Hash::Merge::merge($h1, $h2);
337    main::ok($merged);
338}
339
340done_testing;
341