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