1# tests shared between t/op/caller.t and ext/XS-APItest/t/op.t 2 3use strict; 4use warnings; 5 6sub dooot { 7 is(hint_fetch('dooot'), undef); 8 is(hint_fetch('thikoosh'), undef); 9 ok(!hint_exists('dooot')); 10 ok(!hint_exists('thikoosh')); 11 if ($::testing_caller) { 12 is(hint_fetch('dooot', 1), 54); 13 } 14 BEGIN { 15 $^H{dooot} = 42; 16 } 17 is(hint_fetch('dooot'), 6 * 7); 18 if ($::testing_caller) { 19 is(hint_fetch('dooot', 1), 54); 20 } 21 22 BEGIN { 23 $^H{dooot} = undef; 24 } 25 is(hint_fetch('dooot'), undef); 26 ok(hint_exists('dooot')); 27 28 BEGIN { 29 delete $^H{dooot}; 30 } 31 is(hint_fetch('dooot'), undef); 32 ok(!hint_exists('dooot')); 33 if ($::testing_caller) { 34 is(hint_fetch('dooot', 1), 54); 35 } 36} 37{ 38 is(hint_fetch('dooot'), undef); 39 is(hint_fetch('thikoosh'), undef); 40 BEGIN { 41 $^H{dooot} = 1; 42 $^H{thikoosh} = "SKREECH"; 43 } 44 if ($::testing_caller) { 45 is(hint_fetch('dooot'), 1); 46 } 47 is(hint_fetch('thikoosh'), "SKREECH"); 48 49 BEGIN { 50 $^H{dooot} = 42; 51 } 52 { 53 { 54 BEGIN { 55 $^H{dooot} = 6 * 9; 56 } 57 is(hint_fetch('dooot'), 54); 58 is(hint_fetch('thikoosh'), "SKREECH"); 59 { 60 BEGIN { 61 delete $^H{dooot}; 62 } 63 is(hint_fetch('dooot'), undef); 64 ok(!hint_exists('dooot')); 65 is(hint_fetch('thikoosh'), "SKREECH"); 66 } 67 dooot(); 68 } 69 is(hint_fetch('dooot'), 6 * 7); 70 is(hint_fetch('thikoosh'), "SKREECH"); 71 } 72 is(hint_fetch('dooot'), 6 * 7); 73 is(hint_fetch('thikoosh'), "SKREECH"); 74} 75 76print "# which now works inside evals\n"; 77 78{ 79 BEGIN { 80 $^H{dooot} = 42; 81 } 82 is(hint_fetch('dooot'), 6 * 7); 83 84 eval "is(hint_fetch('dooot'), 6 * 7); 1" or die $@; 85 86 eval <<'EOE' or die $@; 87 is(hint_fetch('dooot'), 6 * 7); 88 eval "is(hint_fetch('dooot'), 6 * 7); 1" or die $@; 89 BEGIN { 90 $^H{dooot} = 54; 91 } 92 is(hint_fetch('dooot'), 54); 93 eval "is(hint_fetch('dooot'), 54); 1" or die $@; 94 eval 'BEGIN { $^H{dooot} = -1; }; 1' or die $@; 95 is(hint_fetch('dooot'), 54); 96 eval "is(hint_fetch('dooot'), 54); 1" or die $@; 97EOE 98} 99 100{ 101 BEGIN { 102 $^H{dooot} = "FIP\0FOP\0FIDDIT\0FAP"; 103 } 104 is(hint_fetch('dooot'), "FIP\0FOP\0FIDDIT\0FAP", "Can do embedded 0 bytes"); 105 106 BEGIN { 107 $^H{dooot} = chr 256; 108 } 109 is(hint_fetch('dooot'), chr 256, "Can do Unicode"); 110 111 BEGIN { 112 $^H{dooot} = -42; 113 } 114 is(hint_fetch('dooot'), -42, "Can do IVs"); 115 116 BEGIN { 117 $^H{dooot} = ~0; 118 } 119 cmp_ok(hint_fetch('dooot'), '>', 42, "Can do UVs"); 120} 121 122{ 123 my ($k1, $k2, $k3, $k4); 124 BEGIN { 125 $k1 = chr 163; 126 $k2 = $k1; 127 $k3 = chr 256; 128 $k4 = $k3; 129 utf8::upgrade $k2; 130 utf8::encode $k4; 131 132 $^H{$k1} = 1; 133 $^H{$k2} = 2; 134 $^H{$k3} = 3; 135 $^H{$k4} = 4; 136 } 137 138 139 is(hint_fetch($k1), 2, "UTF-8 or not, it's the same"); 140 if ($::testing_caller) { 141 # Perl_refcounted_he_fetch() insists that you have the key correctly 142 # normalised for the way hashes store them. As this one isn't 143 # normalised down to bytes, it won't work with 144 # Perl_refcounted_he_fetch() 145 is(hint_fetch($k2), 2, "UTF-8 or not, it's the same"); 146 } 147 is(hint_fetch($k3), 3, "Octect sequences and UTF-8 are distinct"); 148 is(hint_fetch($k4), 4, "Octect sequences and UTF-8 are distinct"); 149} 150 151{ 152 my ($k1, $k2, $k3); 153 BEGIN { 154 ($k1, $k2, $k3) = ("\0", "\0\0", "\0\0\0"); 155 $^H{$k1} = 1; 156 $^H{$k2} = 2; 157 $^H{$k3} = 3; 158 } 159 160 is(hint_fetch($k1), 1, "Keys with the same hash value don't clash"); 161 is(hint_fetch($k2), 2, "Keys with the same hash value don't clash"); 162 is(hint_fetch($k3), 3, "Keys with the same hash value don't clash"); 163 164 BEGIN { 165 $^H{$k1} = "a"; 166 $^H{$k2} = "b"; 167 $^H{$k3} = "c"; 168 } 169 170 is(hint_fetch($k1), "a", "Keys with the same hash value don't clash"); 171 is(hint_fetch($k2), "b", "Keys with the same hash value don't clash"); 172 is(hint_fetch($k3), "c", "Keys with the same hash value don't clash"); 173} 174 1751; 176