1#!perl
2
3use strict ("subs", "vars", "refs");
4use warnings ("all");
5BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} = "Clone"; }
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;
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
58my $merge = Hash::Merge->new();
59ok($merge->get_behavior() eq 'LEFT_PRECEDENT', 'no arg default is LEFT_PRECEDENT');
60
61my %lp = %{$merge->merge(\%left, \%right)};
62
63is_deeply($lp{ss}, 'left', 'Left Precedent - Scalar on Scalar');
64is_deeply($lp{sa}, 'left', 'Left Precedent - Scalar on Array');
65is_deeply($lp{sh}, 'left', 'Left Precedent - Scalar on Hash');
66is_deeply($lp{so}, 'left', 'Left Precedent - Scalar on Object');
67is_deeply($lp{as}, ['l1', 'l2', 'right'], 'Left Precedent - Array on Scalar');
68is_deeply($lp{aa}, ['l1', 'l2', 'r1', 'r2'], 'Left Precedent - Array on Array');
69is_deeply($lp{ah}, ['l1', 'l2', 1], 'Left Precedent - Array on Hash');
70is_deeply($lp{ao}, ['l1', 'l2', {key => 'right'}], 'Left Precedent - Array on Object');
71is_deeply($lp{hs}, {left => 1}, 'Left Precedent - Hash on Scalar');
72is_deeply($lp{ha}, {left => 1}, 'Left Precedent - Hash on Array');
73is_deeply(
74    $lp{hh},
75    {
76        left  => 1,
77        right => 1,
78    },
79    'Left Precedent - Hash on Hash'
80);
81is_deeply(
82    $lp{ho},
83    {
84        left => 1,
85        foo  => {
86            key => 'right',
87        },
88    },
89    'Left Precedent - Hash on Object'
90);
91is_deeply($lp{os}, {foo => {key => 'left'}}, 'Left Precedent - Object on Scalar');
92is_deeply($lp{oa}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array');
93is_deeply(
94    $lp{oh},
95    {
96        foo   => {key => 'left'},
97        right => 1,
98    },
99    'Left Precedent - Object on Array'
100);
101is_deeply($lp{oo}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array');
102
103ok($merge->set_behavior('RIGHT_PRECEDENT') eq 'LEFT_PRECEDENT', 'set_behavior() returns previous behavior');
104ok($merge->get_behavior() eq 'RIGHT_PRECEDENT',                 'set_behavior() actually sets the behavior)');
105
106my %rp = %{$merge->merge(\%left, \%right)};
107
108is_deeply($rp{ss}, 'right', 'Right Precedent - Scalar on Scalar');
109is_deeply($rp{sa}, ['left', 'r1', 'r2'], 'Right Precedent - Scalar on Array');
110is_deeply($rp{sh}, {right => 1}, 'Right Precedent - Scalar on Hash');
111is_deeply($rp{so}, {foo => {key => 'right'}}, 'Right Precedent - Scalar on Object');
112is_deeply($rp{as}, 'right', 'Right Precedent - Array on Scalar');
113is_deeply($rp{aa}, ['l1', 'l2', 'r1', 'r2'], 'Right Precedent - Array on Array');
114is_deeply($rp{ah}, {right => 1}, 'Right Precedent - Array on Hash');
115is_deeply($rp{ao}, {foo => {key => 'right'}}, 'Right Precedent - Array on Object');
116is_deeply($rp{hs}, 'right', 'Right Precedent - Hash on Scalar');
117is_deeply($rp{ha}, [1, 'r1', 'r2'], 'Right Precedent - Hash on Array');
118is_deeply(
119    $rp{hh},
120    {
121        left  => 1,
122        right => 1,
123    },
124    'Right Precedent - Hash on Hash'
125);
126is_deeply(
127    $rp{ho},
128    {
129        foo  => {key => 'right'},
130        left => 1,
131    },
132    'Right Precedent - Hash on Object'
133);
134is_deeply($rp{os}, 'right', 'Right Precedent - Object on Scalar');
135is_deeply($rp{oa}, [{key => 'left'}, 'r1', 'r2'], 'Right Precedent - Object on Array');
136is_deeply(
137    $rp{oh},
138    {
139        foo   => {key => 'left'},
140        right => 1,
141    },
142    'Right Precedent - Object on Hash'
143);
144is_deeply($rp{oo}, {foo => {key => 'right'}}, 'Right Precedent - Object on Object');
145
146Hash::Merge::set_behavior('STORAGE_PRECEDENT');
147ok($merge->get_behavior() eq 'RIGHT_PRECEDENT', '"global" function does not affect object');
148$merge->set_behavior('STORAGE_PRECEDENT');
149
150my %sp = %{$merge->merge(\%left, \%right)};
151
152is_deeply($sp{ss}, 'left', 'Storage Precedent - Scalar on Scalar');
153is_deeply($sp{sa}, ['left', 'r1', 'r2'], 'Storage Precedent - Scalar on Array');
154is_deeply($sp{sh}, {right => 1}, 'Storage Precedent - Scalar on Hash');
155is_deeply($sp{so}, {foo => {key => 'right'}}, 'Storage Precedent - Scalar on Object');
156is_deeply($sp{as}, ['l1', 'l2', 'right'], 'Storage Precedent - Array on Scalar');
157is_deeply($sp{aa}, ['l1', 'l2', 'r1', 'r2'], 'Storage Precedent - Array on Array');
158is_deeply($sp{ah}, {right => 1}, 'Storage Precedent - Array on Hash');
159is_deeply($sp{ao}, {foo => {key => 'right'}}, 'Storage Precedent - Array on Object');
160is_deeply($sp{hs}, {left => 1}, 'Storage Precedent - Hash on Scalar');
161is_deeply($sp{ha}, {left => 1}, 'Storage Precedent - Hash on Array');
162is_deeply(
163    $sp{hh},
164    {
165        left  => 1,
166        right => 1,
167    },
168    'Storage Precedent - Hash on Hash'
169);
170is_deeply(
171    $sp{ho},
172    {
173        foo  => {key => 'right'},
174        left => 1,
175    },
176    'Storage Precedent - Hash on Object'
177);
178is_deeply($sp{os}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Scalar');
179is_deeply($sp{oa}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Array');
180is_deeply(
181    $sp{oh},
182    {
183        foo   => {key => 'left'},
184        right => 1,
185    },
186    'Storage Precedent - Object on Hash'
187);
188is_deeply($sp{oo}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Object');
189
190$merge->set_behavior('RETAINMENT_PRECEDENT');
191my %rep = %{$merge->merge(\%left, \%right)};
192
193is_deeply($rep{ss}, ['left', 'right'], 'Retainment Precedent - Scalar on Scalar');
194is_deeply($rep{sa}, ['left', 'r1', 'r2'], 'Retainment Precedent - Scalar on Array');
195is_deeply(
196    $rep{sh},
197    {
198        left  => 'left',
199        right => 1,
200    },
201    'Retainment Precedent - Scalar on Hash'
202);
203is_deeply(
204    $rep{so},
205    {
206        foo  => {key => 'right'},
207        left => 'left',
208    },
209    'Retainment Precedent - Scalar on Object'
210);
211is_deeply($rep{as}, ['l1', 'l2', 'right'], 'Retainment Precedent - Array on Scalar');
212is_deeply($rep{aa}, ['l1', 'l2', 'r1', 'r2'], 'Retainment Precedent - Array on Array');
213is_deeply(
214    $rep{ah},
215    {
216        l1    => 'l1',
217        l2    => 'l2',
218        right => 1,
219    },
220    'Retainment Precedent - Array on Hash'
221);
222is_deeply(
223    $rep{ao},
224    {
225        foo => {key => 'right'},
226        l1  => 'l1',
227        l2  => 'l2',
228    },
229    'Retainment Precedent - Array on Object'
230);
231is_deeply(
232    $rep{hs},
233    {
234        left  => 1,
235        right => 'right',
236    },
237    'Retainment Precedent - Hash on Scalar'
238);
239is_deeply(
240    $rep{ha},
241    {
242        left => 1,
243        r1   => 'r1',
244        r2   => 'r2',
245    },
246    'Retainment Precedent - Hash on Array'
247);
248is_deeply(
249    $rep{hh},
250    {
251        left  => 1,
252        right => 1,
253    },
254    'Retainment Precedent - Hash on Hash'
255);
256is_deeply(
257    $rep{ho},
258    {
259        foo  => {key => 'right'},
260        left => 1,
261    },
262    'Retainment Precedent - Hash on Object'
263);
264is_deeply(
265    $rep{os},
266    {
267        foo   => {key => 'left'},
268        right => 'right',
269    },
270    'Retainment Precedent - Object on Scalar'
271);
272is_deeply(
273    $rep{oa},
274    {
275        foo => {key => 'left'},
276        r1  => 'r1',
277        r2  => 'r2',
278    },
279    'Retainment Precedent - Object on Array'
280);
281is_deeply(
282    $rep{oh},
283    {
284        foo   => {key => 'left'},
285        right => 1,
286    },
287    'Retainment Precedent - Object on Hash'
288);
289is_deeply($rep{oo}, {foo => [{key => 'left'}, {key => 'right'},]}, 'Retainment Precedent - Object on Object');
290
291$merge->add_behavior_spec(
292    {
293        SCALAR => {
294            SCALAR => sub { $_[0] },
295            ARRAY  => sub { $_[0] },
296            HASH   => sub { $_[0] }
297        },
298        ARRAY => {
299            SCALAR => sub { $_[0] },
300            ARRAY  => sub { $_[0] },
301            HASH   => sub { $_[0] }
302        },
303        HASH => {
304            SCALAR => sub { $_[0] },
305            ARRAY  => sub { $_[0] },
306            HASH   => sub { $_[0] }
307        }
308    },
309    "My Behavior"
310);
311
312SCOPE: {
313    my $err;
314    local $SIG{__WARN__} = sub { $err = shift };
315    eval { $merge->specify_behavior( $merge->get_behavior_spec("My Behavior"), "My Behavior" ) };
316    $@ and $err = $@;
317    like($err, qr/already defined. Please take another name/, "Cannot add behavior spec twice");
318}
319
320my %cp = %{$merge->merge(\%left, \%right)};
321
322is_deeply($cp{ss}, 'left', 'Custom Precedent - Scalar on Scalar');
323is_deeply($cp{sa}, 'left', 'Custom Precedent - Scalar on Array');
324is_deeply($cp{sh}, 'left', 'Custom Precedent - Scalar on Hash');
325is_deeply($cp{so}, 'left', 'Custom Precedent - Scalar on Object');
326is_deeply($cp{as}, ['l1', 'l2'], 'Custom Precedent - Array on Scalar');
327is_deeply($cp{aa}, ['l1', 'l2'], 'Custom Precedent - Array on Array');
328is_deeply($cp{ah}, ['l1', 'l2'], 'Custom Precedent - Array on Hash');
329is_deeply($cp{ao}, ['l1', 'l2'], 'Custom Precedent - Array on Object');
330is_deeply($cp{hs}, {left => 1}, 'Custom Precedent - Hash on Scalar');
331is_deeply($cp{ha}, {left => 1}, 'Custom Precedent - Hash on Array');
332is_deeply($cp{hh}, {left => 1}, 'Custom Precedent - Hash on Hash');
333is_deeply($cp{ho}, {left => 1}, 'Custom Precedent - Hash on Hash');
334is_deeply($cp{os}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Scalar');
335is_deeply($cp{oa}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Array');
336is_deeply($cp{oh}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Hash');
337is_deeply($cp{oo}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Object');
338
339{
340    package    # Test sponsored by David Wheeler
341      HashMergeHashContainer;
342    my $h1 = {
343        foo => bless {one => 2},
344        __PACKAGE__
345    };
346    my $h2 = {
347        foo => bless {one => 2},
348        __PACKAGE__
349    };
350    my $merged = Hash::Merge->new->merge($h1, $h2);
351    main::ok($merged);
352}
353
354{
355    my $destroyed = 0;
356    no warnings 'once';
357    local *Hash::Merge::DESTROY = sub { $destroyed = 1; };
358    use warnings;
359    Hash::Merge->new;
360    sleep 1;
361    ok $destroyed, "instance did not leak";
362}
363
364done_testing;
365
366
367