Update Time-HiRes Changes for 1.9760
[perl.git] / t / op / caller.pl
1 # tests shared between t/op/caller.t and ext/XS-APItest/t/op.t
2
3 use strict;
4 use warnings;
5
6 sub 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
76 print "# 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 $@;
97 EOE
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 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
175 1;