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