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