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