1#!perl 2use strict; use warnings; 3use Test::More; 4my $n_tests; 5 6use Hash::Util::FieldHash; 7use Scalar::Util qw( weaken); 8 9sub numbers_first { # Sort helper: All digit entries sort in front of others 10 # Makes sorting portable across ASCII/EBCDIC 11 return $a cmp $b if ($a =~ /^\d+$/) == ($b =~ /^\d+$/); 12 return -1 if $a =~ /^\d+$/; 13 return 1; 14} 15 16# The functions in Hash::Util::FieldHash 17# _test_uvar_get, _test_uvar_get and _test_uvar_both 18 19# _test_uvar_get( $anyref, \ $counter) makes the referent of $anyref 20# "uvar"-magical with get magic only. $counter is reset if the magic 21# could be established. $counter will be incremented each time the 22# magic "get" function is called. 23 24# _test_uvar_set does the same for "set" magic. _test_uvar_both 25# sets both magic functions identically. Both use the same counter. 26 27# magical weak ref (patch to sv.c) 28{ 29 my( $magref, $counter); 30 31 $counter = 123; 32 Hash::Util::FieldHash::_test_uvar_set( \ $magref, \ $counter); 33 is( $counter, 0, "got magical scalar"); 34 35 my $ref = []; 36 $magref = $ref; 37 is( $counter, 1, "store triggers magic"); 38 39 weaken $magref; 40 is( $counter, 1, "weaken doesn't trigger magic"); 41 42 { my $x = $magref } 43 is( $counter, 1, "read doesn't trigger magic"); 44 45 undef $ref; 46 is( $counter, 2, "ref expiry triggers magic (weakref patch worked)"); 47 48 is( $magref, undef, "weak ref works normally"); 49 50 # same, but overwrite weakref before expiry 51 $counter = 0; 52 weaken( $magref = $ref = []); 53 is( $counter, 1, "setup for overwrite"); 54 55 $magref = my $other_ref = []; 56 is( $counter, 2, "overwrite triggers"); 57 58 undef $ref; 59 is( $counter, 2, "ref expiry doesn't trigger after overwrite"); 60 61 is( $magref, $other_ref, "weak ref doesn't kill overwritten value"); 62 63 BEGIN { $n_tests += 10 } 64} 65 66# magical hash (patches to mg.c and hv.c) 67{ 68 # the hook is only sensitive if the set function is NULL 69 my ( %h, $counter); 70 $counter = 123; 71 Hash::Util::FieldHash::_test_uvar_get( \ %h, \ $counter); 72 is( $counter, 0, "got magical hash"); 73 74 %h = ( abc => 123); 75 is( $counter, 1, "list assign triggers"); 76 77 78 my $x = keys %h; 79 is( $counter, 1, "scalar keys doesn't trigger"); 80 is( $x, 1, "there is one key"); 81 82 my (@x) = keys %h; 83 is( $counter, 1, "list keys doesn't trigger"); 84 is( "@x", "abc", "key is correct"); 85 86 $x = values %h; 87 is( $counter, 1, "scalar values doesn't trigger"); 88 is( $x, 1, "the value is correct"); 89 90 (@x) = values %h; 91 is( $counter, 1, "list values doesn't trigger"); 92 is( "@x", "123", "the value is correct"); 93 94 $x = each %h; 95 is( $counter, 1, "scalar each doesn't trigger"); 96 is( $x, "abc", "the return is correct"); 97 98 $x = each %h; 99 is( $counter, 1, "scalar each doesn't trigger"); 100 is( $x, undef, "the return is correct"); 101 102 (@x) = each %h; 103 is( $counter, 1, "list each doesn't trigger"); 104 is( "@x", "abc 123", "the return is correct"); 105 106 $x = scalar %h; 107 is( $counter, 1, "hash in scalar context doesn't trigger"); 108 is( $x, 1, "correct result"); 109 110 (@x) = %h; 111 is( $counter, 1, "hash in list context doesn't trigger"); 112 is( "@x", "abc 123", "correct result"); 113 114 115 $h{ def} = 456; 116 is( $counter, 2, "lvalue assign triggers"); 117 118 (@x) = sort numbers_first %h; 119 is( $counter, 2, "hash in list context doesn't trigger"); 120 is( "@x", "123 456 abc def", "correct result"); 121 122 exists $h{ def}; 123 is( $counter, 3, "good exists triggers"); 124 125 exists $h{ xyz}; 126 is( $counter, 4, "bad exists triggers"); 127 128 delete $h{ def}; 129 is( $counter, 5, "good delete triggers"); 130 131 (@x) = sort numbers_first %h; 132 is( $counter, 5, "hash in list context doesn't trigger"); 133 is( "@x", "123 abc", "correct result"); 134 135 delete $h{ xyz}; 136 is( $counter, 6, "bad delete triggers"); 137 138 (@x) = sort numbers_first %h; 139 is( $counter, 6, "hash in list context doesn't trigger"); 140 is( "@x", "123 abc", "correct result"); 141 142 $x = $h{ abc}; 143 is( $counter, 7, "good read triggers"); 144 145 $x = $h{ xyz}; 146 is( $counter, 8, "bad read triggers"); 147 148 (@x) = sort numbers_first %h; 149 is( $counter, 8, "hash in list context doesn't trigger"); 150 is( "@x", "123 abc", "correct result"); 151 152 153 bless \ %h; 154 is( $counter, 8, "bless doesn't trigger"); 155 156 bless \ %h, 'xyz'; 157 is( $counter, 8, "bless doesn't trigger"); 158 159 # see that normal set magic doesn't trigger (identity condition) 160 my %i; 161 Hash::Util::FieldHash::_test_uvar_set( \ %i, \ $counter); 162 is( $counter, 0, "got magical hash"); 163 164 %i = ( abc => 123); 165 $i{ def} = 456; 166 exists $i{ def}; 167 exists $i{ xyz}; 168 delete $i{ def}; 169 delete $i{ xyz}; 170 $x = $i{ abc}; 171 $x = $i{ xyz}; 172 $x = keys %i; 173 () = keys %i; 174 $x = values %i; 175 () = values %i; 176 $x = each %i; 177 () = each %i; 178 179 is( $counter, 0, "normal set magic never triggers"); 180 181 bless \ %i, 'abc'; 182 is( $counter, 1, "...except with bless"); 183 184 # see that magic with both set and get doesn't trigger 185 $counter = 123; 186 my %j; 187 Hash::Util::FieldHash::_test_uvar_same( \ %j, \ $counter); 188 is( $counter, 0, "got magical hash"); 189 190 %j = ( abc => 123); 191 $j{ def} = 456; 192 exists $j{ def}; 193 exists $j{ xyz}; 194 delete $j{ def}; 195 delete $j{ xyz}; 196 $x = $j{ abc}; 197 $x = $j{ xyz}; 198 $x = keys %j; 199 () = keys %j; 200 $x = values %j; 201 () = values %j; 202 $x = each %j; 203 () = each %j; 204 205 is( $counter, 0, "get/set magic never triggers"); 206 207 bless \ %j, 'abc'; 208 is( $counter, 1, "...except for bless"); 209 210 BEGIN { $n_tests += 43 } 211} 212 213BEGIN { plan tests => $n_tests } 214 215