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