1#!perl 2 3use strict ("subs", "vars", "refs"); 4use warnings ("all"); 5BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} = "Clone::PP"; } 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