Commit | Line | Data |
---|---|---|
6a93a7e5 | 1 | #define PERL_IN_XS_APITEST |
3e61d65a JH |
2 | #include "EXTERN.h" |
3 | #include "perl.h" | |
4 | #include "XSUB.h" | |
5 | ||
36c2b1d0 NC |
6 | typedef SV *SVREF; |
7 | typedef PTR_TBL_t *XS__APItest__PtrTable; | |
85ce96a1 | 8 | |
11f9f0ed | 9 | #define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__) |
779bc08a | 10 | #define croak_fail_ne(h, w) croak("fail %p!=%p at " __FILE__ " line %d", (h), (w), __LINE__) |
11f9f0ed | 11 | |
85ce96a1 DM |
12 | /* for my_cxt tests */ |
13 | ||
14 | #define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION | |
15 | ||
16 | typedef struct { | |
17 | int i; | |
18 | SV *sv; | |
03569ecf BM |
19 | GV *cscgv; |
20 | AV *cscav; | |
13b6b3bc BM |
21 | AV *bhkav; |
22 | bool bhk_record; | |
201c7e1f FR |
23 | peep_t orig_peep; |
24 | peep_t orig_rpeep; | |
25 | int peep_recording; | |
26 | AV *peep_recorder; | |
27 | AV *rpeep_recorder; | |
f568d64d | 28 | AV *xop_record; |
85ce96a1 DM |
29 | } my_cxt_t; |
30 | ||
31 | START_MY_CXT | |
32 | ||
26ab20ee FR |
33 | MGVTBL vtbl_foo, vtbl_bar; |
34 | ||
85ce96a1 | 35 | /* indirect functions to test the [pa]MY_CXT macros */ |
f16dd614 | 36 | |
85ce96a1 DM |
37 | int |
38 | my_cxt_getint_p(pMY_CXT) | |
39 | { | |
40 | return MY_CXT.i; | |
41 | } | |
f16dd614 | 42 | |
85ce96a1 DM |
43 | void |
44 | my_cxt_setint_p(pMY_CXT_ int i) | |
45 | { | |
46 | MY_CXT.i = i; | |
47 | } | |
f16dd614 DM |
48 | |
49 | SV* | |
9568a123 | 50 | my_cxt_getsv_interp_context(void) |
f16dd614 | 51 | { |
f16dd614 DM |
52 | dTHX; |
53 | dMY_CXT_INTERP(my_perl); | |
9568a123 NC |
54 | return MY_CXT.sv; |
55 | } | |
56 | ||
57 | SV* | |
58 | my_cxt_getsv_interp(void) | |
59 | { | |
f16dd614 | 60 | dMY_CXT; |
f16dd614 DM |
61 | return MY_CXT.sv; |
62 | } | |
63 | ||
85ce96a1 DM |
64 | void |
65 | my_cxt_setsv_p(SV* sv _pMY_CXT) | |
66 | { | |
67 | MY_CXT.sv = sv; | |
68 | } | |
69 | ||
70 | ||
9b5c3821 | 71 | /* from exception.c */ |
7a646707 | 72 | int apitest_exception(int); |
0314122a | 73 | |
ff66e713 SH |
74 | /* from core_or_not.inc */ |
75 | bool sv_setsv_cow_hashkey_core(void); | |
76 | bool sv_setsv_cow_hashkey_notcore(void); | |
77 | ||
2dc92170 NC |
78 | /* A routine to test hv_delayfree_ent |
79 | (which itself is tested by testing on hv_free_ent */ | |
80 | ||
81 | typedef void (freeent_function)(pTHX_ HV *, register HE *); | |
82 | ||
83 | void | |
84 | test_freeent(freeent_function *f) { | |
85 | dTHX; | |
86 | dSP; | |
87 | HV *test_hash = newHV(); | |
88 | HE *victim; | |
89 | SV *test_scalar; | |
90 | U32 results[4]; | |
91 | int i; | |
92 | ||
8afd2d2e NC |
93 | #ifdef PURIFY |
94 | victim = (HE*)safemalloc(sizeof(HE)); | |
95 | #else | |
2dc92170 NC |
96 | /* Storing then deleting something should ensure that a hash entry is |
97 | available. */ | |
c33e8be1 Z |
98 | (void) hv_store(test_hash, "", 0, &PL_sv_yes, 0); |
99 | (void) hv_delete(test_hash, "", 0, 0); | |
2dc92170 NC |
100 | |
101 | /* We need to "inline" new_he here as it's static, and the functions we | |
102 | test expect to be able to call del_HE on the HE */ | |
6a93a7e5 | 103 | if (!PL_body_roots[HE_SVSLOT]) |
2dc92170 | 104 | croak("PL_he_root is 0"); |
8a722a80 | 105 | victim = (HE*) PL_body_roots[HE_SVSLOT]; |
6a93a7e5 | 106 | PL_body_roots[HE_SVSLOT] = HeNEXT(victim); |
8afd2d2e | 107 | #endif |
2dc92170 NC |
108 | |
109 | victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0); | |
110 | ||
111 | test_scalar = newSV(0); | |
112 | SvREFCNT_inc(test_scalar); | |
de616631 | 113 | HeVAL(victim) = test_scalar; |
2dc92170 NC |
114 | |
115 | /* Need this little game else we free the temps on the return stack. */ | |
116 | results[0] = SvREFCNT(test_scalar); | |
117 | SAVETMPS; | |
118 | results[1] = SvREFCNT(test_scalar); | |
119 | f(aTHX_ test_hash, victim); | |
120 | results[2] = SvREFCNT(test_scalar); | |
121 | FREETMPS; | |
122 | results[3] = SvREFCNT(test_scalar); | |
123 | ||
124 | i = 0; | |
125 | do { | |
126 | mPUSHu(results[i]); | |
c33e8be1 | 127 | } while (++i < (int)(sizeof(results)/sizeof(results[0]))); |
2dc92170 NC |
128 | |
129 | /* Goodbye to our extra reference. */ | |
130 | SvREFCNT_dec(test_scalar); | |
131 | } | |
132 | ||
b54b4831 NC |
133 | |
134 | static I32 | |
53c40a8f NC |
135 | bitflip_key(pTHX_ IV action, SV *field) { |
136 | MAGIC *mg = mg_find(field, PERL_MAGIC_uvar); | |
137 | SV *keysv; | |
c33e8be1 | 138 | PERL_UNUSED_ARG(action); |
53c40a8f NC |
139 | if (mg && (keysv = mg->mg_obj)) { |
140 | STRLEN len; | |
141 | const char *p = SvPV(keysv, len); | |
142 | ||
143 | if (len) { | |
144 | SV *newkey = newSV(len); | |
145 | char *new_p = SvPVX(newkey); | |
146 | ||
147 | if (SvUTF8(keysv)) { | |
148 | const char *const end = p + len; | |
149 | while (p < end) { | |
150 | STRLEN len; | |
a75fcbca SP |
151 | UV chr = utf8_to_uvuni((U8 *)p, &len); |
152 | new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32); | |
53c40a8f NC |
153 | p += len; |
154 | } | |
155 | SvUTF8_on(newkey); | |
156 | } else { | |
157 | while (len--) | |
158 | *new_p++ = *p++ ^ 32; | |
159 | } | |
160 | *new_p = '\0'; | |
161 | SvCUR_set(newkey, SvCUR(keysv)); | |
162 | SvPOK_on(newkey); | |
163 | ||
164 | mg->mg_obj = newkey; | |
165 | } | |
166 | } | |
167 | return 0; | |
168 | } | |
169 | ||
170 | static I32 | |
b54b4831 NC |
171 | rot13_key(pTHX_ IV action, SV *field) { |
172 | MAGIC *mg = mg_find(field, PERL_MAGIC_uvar); | |
173 | SV *keysv; | |
c33e8be1 | 174 | PERL_UNUSED_ARG(action); |
b54b4831 NC |
175 | if (mg && (keysv = mg->mg_obj)) { |
176 | STRLEN len; | |
177 | const char *p = SvPV(keysv, len); | |
178 | ||
179 | if (len) { | |
180 | SV *newkey = newSV(len); | |
181 | char *new_p = SvPVX(newkey); | |
182 | ||
183 | /* There's a deliberate fencepost error here to loop len + 1 times | |
184 | to copy the trailing \0 */ | |
185 | do { | |
186 | char new_c = *p++; | |
187 | /* Try doing this cleanly and clearly in EBCDIC another way: */ | |
188 | switch (new_c) { | |
189 | case 'A': new_c = 'N'; break; | |
190 | case 'B': new_c = 'O'; break; | |
191 | case 'C': new_c = 'P'; break; | |
192 | case 'D': new_c = 'Q'; break; | |
193 | case 'E': new_c = 'R'; break; | |
194 | case 'F': new_c = 'S'; break; | |
195 | case 'G': new_c = 'T'; break; | |
196 | case 'H': new_c = 'U'; break; | |
197 | case 'I': new_c = 'V'; break; | |
198 | case 'J': new_c = 'W'; break; | |
199 | case 'K': new_c = 'X'; break; | |
200 | case 'L': new_c = 'Y'; break; | |
201 | case 'M': new_c = 'Z'; break; | |
202 | case 'N': new_c = 'A'; break; | |
203 | case 'O': new_c = 'B'; break; | |
204 | case 'P': new_c = 'C'; break; | |
205 | case 'Q': new_c = 'D'; break; | |
206 | case 'R': new_c = 'E'; break; | |
207 | case 'S': new_c = 'F'; break; | |
208 | case 'T': new_c = 'G'; break; | |
209 | case 'U': new_c = 'H'; break; | |
210 | case 'V': new_c = 'I'; break; | |
211 | case 'W': new_c = 'J'; break; | |
212 | case 'X': new_c = 'K'; break; | |
213 | case 'Y': new_c = 'L'; break; | |
214 | case 'Z': new_c = 'M'; break; | |
215 | case 'a': new_c = 'n'; break; | |
216 | case 'b': new_c = 'o'; break; | |
217 | case 'c': new_c = 'p'; break; | |
218 | case 'd': new_c = 'q'; break; | |
219 | case 'e': new_c = 'r'; break; | |
220 | case 'f': new_c = 's'; break; | |
221 | case 'g': new_c = 't'; break; | |
222 | case 'h': new_c = 'u'; break; | |
223 | case 'i': new_c = 'v'; break; | |
224 | case 'j': new_c = 'w'; break; | |
225 | case 'k': new_c = 'x'; break; | |
226 | case 'l': new_c = 'y'; break; | |
227 | case 'm': new_c = 'z'; break; | |
228 | case 'n': new_c = 'a'; break; | |
229 | case 'o': new_c = 'b'; break; | |
230 | case 'p': new_c = 'c'; break; | |
231 | case 'q': new_c = 'd'; break; | |
232 | case 'r': new_c = 'e'; break; | |
233 | case 's': new_c = 'f'; break; | |
234 | case 't': new_c = 'g'; break; | |
235 | case 'u': new_c = 'h'; break; | |
236 | case 'v': new_c = 'i'; break; | |
237 | case 'w': new_c = 'j'; break; | |
238 | case 'x': new_c = 'k'; break; | |
239 | case 'y': new_c = 'l'; break; | |
240 | case 'z': new_c = 'm'; break; | |
241 | } | |
242 | *new_p++ = new_c; | |
243 | } while (len--); | |
244 | SvCUR_set(newkey, SvCUR(keysv)); | |
245 | SvPOK_on(newkey); | |
246 | if (SvUTF8(keysv)) | |
247 | SvUTF8_on(newkey); | |
248 | ||
249 | mg->mg_obj = newkey; | |
250 | } | |
251 | } | |
252 | return 0; | |
253 | } | |
254 | ||
218787bd VP |
255 | STATIC I32 |
256 | rmagical_a_dummy(pTHX_ IV idx, SV *sv) { | |
c33e8be1 Z |
257 | PERL_UNUSED_ARG(idx); |
258 | PERL_UNUSED_ARG(sv); | |
218787bd VP |
259 | return 0; |
260 | } | |
261 | ||
262 | STATIC MGVTBL rmagical_b = { 0 }; | |
263 | ||
03569ecf | 264 | STATIC void |
13b6b3bc | 265 | blockhook_csc_start(pTHX_ int full) |
03569ecf BM |
266 | { |
267 | dMY_CXT; | |
268 | AV *const cur = GvAV(MY_CXT.cscgv); | |
269 | ||
c33e8be1 | 270 | PERL_UNUSED_ARG(full); |
03569ecf BM |
271 | SAVEGENERICSV(GvAV(MY_CXT.cscgv)); |
272 | ||
273 | if (cur) { | |
274 | I32 i; | |
d024465f | 275 | AV *const new_av = newAV(); |
03569ecf BM |
276 | |
277 | for (i = 0; i <= av_len(cur); i++) { | |
d024465f | 278 | av_store(new_av, i, newSVsv(*av_fetch(cur, i, 0))); |
03569ecf BM |
279 | } |
280 | ||
d024465f | 281 | GvAV(MY_CXT.cscgv) = new_av; |
03569ecf BM |
282 | } |
283 | } | |
284 | ||
285 | STATIC void | |
13b6b3bc | 286 | blockhook_csc_pre_end(pTHX_ OP **o) |
03569ecf BM |
287 | { |
288 | dMY_CXT; | |
289 | ||
c33e8be1 | 290 | PERL_UNUSED_ARG(o); |
03569ecf BM |
291 | /* if we hit the end of a scope we missed the start of, we need to |
292 | * unconditionally clear @CSC */ | |
52db365a | 293 | if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) { |
03569ecf | 294 | av_clear(MY_CXT.cscav); |
52db365a | 295 | } |
03569ecf BM |
296 | |
297 | } | |
298 | ||
13b6b3bc BM |
299 | STATIC void |
300 | blockhook_test_start(pTHX_ int full) | |
301 | { | |
302 | dMY_CXT; | |
303 | AV *av; | |
304 | ||
305 | if (MY_CXT.bhk_record) { | |
306 | av = newAV(); | |
307 | av_push(av, newSVpvs("start")); | |
308 | av_push(av, newSViv(full)); | |
309 | av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av))); | |
310 | } | |
311 | } | |
312 | ||
313 | STATIC void | |
314 | blockhook_test_pre_end(pTHX_ OP **o) | |
315 | { | |
316 | dMY_CXT; | |
317 | ||
c33e8be1 | 318 | PERL_UNUSED_ARG(o); |
13b6b3bc BM |
319 | if (MY_CXT.bhk_record) |
320 | av_push(MY_CXT.bhkav, newSVpvs("pre_end")); | |
321 | } | |
322 | ||
323 | STATIC void | |
324 | blockhook_test_post_end(pTHX_ OP **o) | |
325 | { | |
326 | dMY_CXT; | |
327 | ||
c33e8be1 | 328 | PERL_UNUSED_ARG(o); |
13b6b3bc BM |
329 | if (MY_CXT.bhk_record) |
330 | av_push(MY_CXT.bhkav, newSVpvs("post_end")); | |
331 | } | |
332 | ||
333 | STATIC void | |
334 | blockhook_test_eval(pTHX_ OP *const o) | |
335 | { | |
336 | dMY_CXT; | |
337 | AV *av; | |
338 | ||
339 | if (MY_CXT.bhk_record) { | |
340 | av = newAV(); | |
341 | av_push(av, newSVpvs("eval")); | |
342 | av_push(av, newSVpv(OP_NAME(o), 0)); | |
343 | av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av))); | |
344 | } | |
345 | } | |
346 | ||
347 | STATIC BHK bhk_csc, bhk_test; | |
348 | ||
201c7e1f FR |
349 | STATIC void |
350 | my_peep (pTHX_ OP *o) | |
351 | { | |
352 | dMY_CXT; | |
353 | ||
354 | if (!o) | |
355 | return; | |
356 | ||
357 | MY_CXT.orig_peep(aTHX_ o); | |
358 | ||
359 | if (!MY_CXT.peep_recording) | |
360 | return; | |
361 | ||
362 | for (; o; o = o->op_next) { | |
363 | if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) { | |
364 | av_push(MY_CXT.peep_recorder, newSVsv(cSVOPx_sv(o))); | |
365 | } | |
366 | } | |
367 | } | |
368 | ||
369 | STATIC void | |
370 | my_rpeep (pTHX_ OP *o) | |
371 | { | |
372 | dMY_CXT; | |
373 | ||
374 | if (!o) | |
375 | return; | |
376 | ||
377 | MY_CXT.orig_rpeep(aTHX_ o); | |
378 | ||
379 | if (!MY_CXT.peep_recording) | |
380 | return; | |
381 | ||
382 | for (; o; o = o->op_next) { | |
383 | if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) { | |
384 | av_push(MY_CXT.rpeep_recorder, newSVsv(cSVOPx_sv(o))); | |
385 | } | |
386 | } | |
387 | } | |
388 | ||
d9088386 Z |
389 | STATIC OP * |
390 | THX_ck_entersub_args_lists(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) | |
391 | { | |
c33e8be1 Z |
392 | PERL_UNUSED_ARG(namegv); |
393 | PERL_UNUSED_ARG(ckobj); | |
d9088386 Z |
394 | return ck_entersub_args_list(entersubop); |
395 | } | |
396 | ||
397 | STATIC OP * | |
398 | THX_ck_entersub_args_scalars(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) | |
399 | { | |
400 | OP *aop = cUNOPx(entersubop)->op_first; | |
c33e8be1 Z |
401 | PERL_UNUSED_ARG(namegv); |
402 | PERL_UNUSED_ARG(ckobj); | |
d9088386 Z |
403 | if (!aop->op_sibling) |
404 | aop = cUNOPx(aop)->op_first; | |
405 | for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) { | |
406 | op_contextualize(aop, G_SCALAR); | |
407 | } | |
408 | return entersubop; | |
409 | } | |
410 | ||
411 | STATIC OP * | |
412 | THX_ck_entersub_multi_sum(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) | |
413 | { | |
414 | OP *sumop = NULL; | |
415 | OP *pushop = cUNOPx(entersubop)->op_first; | |
c33e8be1 Z |
416 | PERL_UNUSED_ARG(namegv); |
417 | PERL_UNUSED_ARG(ckobj); | |
d9088386 Z |
418 | if (!pushop->op_sibling) |
419 | pushop = cUNOPx(pushop)->op_first; | |
420 | while (1) { | |
421 | OP *aop = pushop->op_sibling; | |
422 | if (!aop->op_sibling) | |
423 | break; | |
424 | pushop->op_sibling = aop->op_sibling; | |
425 | aop->op_sibling = NULL; | |
426 | op_contextualize(aop, G_SCALAR); | |
427 | if (sumop) { | |
428 | sumop = newBINOP(OP_ADD, 0, sumop, aop); | |
429 | } else { | |
430 | sumop = aop; | |
431 | } | |
432 | } | |
433 | if (!sumop) | |
434 | sumop = newSVOP(OP_CONST, 0, newSViv(0)); | |
435 | op_free(entersubop); | |
436 | return sumop; | |
437 | } | |
438 | ||
2fcb4757 Z |
439 | STATIC void test_op_list_describe_part(SV *res, OP *o); |
440 | STATIC void | |
441 | test_op_list_describe_part(SV *res, OP *o) | |
442 | { | |
443 | sv_catpv(res, PL_op_name[o->op_type]); | |
444 | switch (o->op_type) { | |
445 | case OP_CONST: { | |
446 | sv_catpvf(res, "(%d)", (int)SvIV(cSVOPx(o)->op_sv)); | |
447 | } break; | |
448 | } | |
449 | if (o->op_flags & OPf_KIDS) { | |
450 | OP *k; | |
451 | sv_catpvs(res, "["); | |
452 | for (k = cUNOPx(o)->op_first; k; k = k->op_sibling) | |
453 | test_op_list_describe_part(res, k); | |
454 | sv_catpvs(res, "]"); | |
455 | } else { | |
456 | sv_catpvs(res, "."); | |
457 | } | |
458 | } | |
459 | ||
460 | STATIC char * | |
461 | test_op_list_describe(OP *o) | |
462 | { | |
463 | SV *res = sv_2mortal(newSVpvs("")); | |
464 | if (o) | |
465 | test_op_list_describe_part(res, o); | |
466 | return SvPVX(res); | |
467 | } | |
468 | ||
b7b1e41b | 469 | /* the real new*OP functions have a tendency to call fold_constants, and |
5983a79d BM |
470 | * other such unhelpful things, so we need our own versions for testing */ |
471 | ||
472 | #define mkUNOP(t, f) THX_mkUNOP(aTHX_ (t), (f)) | |
473 | static OP * | |
474 | THX_mkUNOP(pTHX_ U32 type, OP *first) | |
475 | { | |
476 | UNOP *unop; | |
477 | NewOp(1103, unop, 1, UNOP); | |
478 | unop->op_type = (OPCODE)type; | |
479 | unop->op_first = first; | |
480 | unop->op_flags = OPf_KIDS; | |
481 | return (OP *)unop; | |
482 | } | |
483 | ||
484 | #define mkBINOP(t, f, l) THX_mkBINOP(aTHX_ (t), (f), (l)) | |
485 | static OP * | |
486 | THX_mkBINOP(pTHX_ U32 type, OP *first, OP *last) | |
487 | { | |
488 | BINOP *binop; | |
489 | NewOp(1103, binop, 1, BINOP); | |
490 | binop->op_type = (OPCODE)type; | |
491 | binop->op_first = first; | |
492 | binop->op_flags = OPf_KIDS; | |
493 | binop->op_last = last; | |
494 | first->op_sibling = last; | |
495 | return (OP *)binop; | |
496 | } | |
497 | ||
498 | #define mkLISTOP(t, f, s, l) THX_mkLISTOP(aTHX_ (t), (f), (s), (l)) | |
499 | static OP * | |
500 | THX_mkLISTOP(pTHX_ U32 type, OP *first, OP *sib, OP *last) | |
501 | { | |
502 | LISTOP *listop; | |
503 | NewOp(1103, listop, 1, LISTOP); | |
504 | listop->op_type = (OPCODE)type; | |
505 | listop->op_flags = OPf_KIDS; | |
506 | listop->op_first = first; | |
507 | first->op_sibling = sib; | |
508 | sib->op_sibling = last; | |
509 | listop->op_last = last; | |
510 | return (OP *)listop; | |
511 | } | |
512 | ||
513 | static char * | |
514 | test_op_linklist_describe(OP *start) | |
515 | { | |
516 | SV *rv = sv_2mortal(newSVpvs("")); | |
517 | OP *o; | |
518 | o = start = LINKLIST(start); | |
519 | do { | |
520 | sv_catpvs(rv, "."); | |
521 | sv_catpv(rv, OP_NAME(o)); | |
522 | if (o->op_type == OP_CONST) | |
523 | sv_catsv(rv, cSVOPo->op_sv); | |
524 | o = o->op_next; | |
525 | } while (o && o != start); | |
526 | return SvPVX(rv); | |
527 | } | |
528 | ||
8f89e5a9 Z |
529 | /** establish_cleanup operator, ripped off from Scope::Cleanup **/ |
530 | ||
531 | STATIC void | |
532 | THX_run_cleanup(pTHX_ void *cleanup_code_ref) | |
533 | { | |
534 | dSP; | |
535 | ENTER; | |
536 | SAVETMPS; | |
537 | PUSHMARK(SP); | |
538 | call_sv((SV*)cleanup_code_ref, G_VOID|G_DISCARD); | |
539 | FREETMPS; | |
540 | LEAVE; | |
541 | } | |
542 | ||
543 | STATIC OP * | |
544 | THX_pp_establish_cleanup(pTHX) | |
545 | { | |
546 | dSP; | |
547 | SV *cleanup_code_ref; | |
548 | cleanup_code_ref = newSVsv(POPs); | |
549 | SAVEFREESV(cleanup_code_ref); | |
550 | SAVEDESTRUCTOR_X(THX_run_cleanup, cleanup_code_ref); | |
551 | if(GIMME_V != G_VOID) PUSHs(&PL_sv_undef); | |
552 | RETURN; | |
553 | } | |
554 | ||
555 | STATIC OP * | |
556 | THX_ck_entersub_establish_cleanup(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) | |
557 | { | |
558 | OP *pushop, *argop, *estop; | |
559 | ck_entersub_args_proto(entersubop, namegv, ckobj); | |
560 | pushop = cUNOPx(entersubop)->op_first; | |
561 | if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first; | |
562 | argop = pushop->op_sibling; | |
563 | pushop->op_sibling = argop->op_sibling; | |
564 | argop->op_sibling = NULL; | |
565 | op_free(entersubop); | |
566 | NewOpSz(0, estop, sizeof(UNOP)); | |
567 | estop->op_type = OP_RAND; | |
568 | estop->op_ppaddr = THX_pp_establish_cleanup; | |
569 | cUNOPx(estop)->op_flags = OPf_KIDS; | |
570 | cUNOPx(estop)->op_first = argop; | |
571 | PL_hints |= HINT_BLOCK_SCOPE; | |
572 | return estop; | |
573 | } | |
574 | ||
3ad73efd Z |
575 | STATIC OP * |
576 | THX_ck_entersub_postinc(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) | |
577 | { | |
c33e8be1 | 578 | OP *pushop, *argop; |
3ad73efd Z |
579 | ck_entersub_args_proto(entersubop, namegv, ckobj); |
580 | pushop = cUNOPx(entersubop)->op_first; | |
581 | if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first; | |
582 | argop = pushop->op_sibling; | |
583 | pushop->op_sibling = argop->op_sibling; | |
584 | argop->op_sibling = NULL; | |
585 | op_free(entersubop); | |
586 | return newUNOP(OP_POSTINC, 0, | |
587 | op_lvalue(op_contextualize(argop, G_SCALAR), OP_POSTINC)); | |
588 | } | |
589 | ||
83f8bb56 Z |
590 | /** RPN keyword parser **/ |
591 | ||
592 | #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV) | |
593 | #define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP) | |
594 | #define sv_is_string(sv) \ | |
595 | (!sv_is_glob(sv) && !sv_is_regexp(sv) && \ | |
596 | (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK))) | |
597 | ||
598 | static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv, *hintkey_stufftest_sv; | |
07ffcb73 | 599 | static SV *hintkey_swaptwostmts_sv, *hintkey_looprest_sv; |
a7aaec61 | 600 | static SV *hintkey_scopelessblock_sv; |
e53d8f76 Z |
601 | static SV *hintkey_stmtasexpr_sv, *hintkey_stmtsasexpr_sv; |
602 | static SV *hintkey_loopblock_sv, *hintkey_blockasexpr_sv; | |
361d9b55 | 603 | static SV *hintkey_swaplabel_sv, *hintkey_labelconst_sv; |
78cdf107 Z |
604 | static SV *hintkey_arrayfullexpr_sv, *hintkey_arraylistexpr_sv; |
605 | static SV *hintkey_arraytermexpr_sv, *hintkey_arrayarithexpr_sv; | |
606 | static SV *hintkey_arrayexprflags_sv; | |
83f8bb56 Z |
607 | static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **); |
608 | ||
609 | /* low-level parser helpers */ | |
610 | ||
611 | #define PL_bufptr (PL_parser->bufptr) | |
612 | #define PL_bufend (PL_parser->bufend) | |
613 | ||
614 | /* RPN parser */ | |
615 | ||
616 | #define parse_var() THX_parse_var(aTHX) | |
617 | static OP *THX_parse_var(pTHX) | |
618 | { | |
619 | char *s = PL_bufptr; | |
620 | char *start = s; | |
621 | PADOFFSET varpos; | |
622 | OP *padop; | |
623 | if(*s != '$') croak("RPN syntax error"); | |
624 | while(1) { | |
625 | char c = *++s; | |
626 | if(!isALNUM(c)) break; | |
627 | } | |
628 | if(s-start < 2) croak("RPN syntax error"); | |
629 | lex_read_to(s); | |
630 | { | |
631 | /* because pad_findmy() doesn't really use length yet */ | |
632 | SV *namesv = sv_2mortal(newSVpvn(start, s-start)); | |
633 | varpos = pad_findmy(SvPVX(namesv), s-start, 0); | |
634 | } | |
635 | if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos)) | |
636 | croak("RPN only supports \"my\" variables"); | |
637 | padop = newOP(OP_PADSV, 0); | |
638 | padop->op_targ = varpos; | |
639 | return padop; | |
640 | } | |
641 | ||
642 | #define push_rpn_item(o) \ | |
643 | (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop) | |
644 | #define pop_rpn_item() \ | |
645 | (!stack ? (croak("RPN stack underflow"), (OP*)NULL) : \ | |
646 | (tmpop = stack, stack = stack->op_sibling, \ | |
647 | tmpop->op_sibling = NULL, tmpop)) | |
648 | ||
649 | #define parse_rpn_expr() THX_parse_rpn_expr(aTHX) | |
650 | static OP *THX_parse_rpn_expr(pTHX) | |
651 | { | |
652 | OP *stack = NULL, *tmpop; | |
653 | while(1) { | |
654 | I32 c; | |
655 | lex_read_space(0); | |
656 | c = lex_peek_unichar(0); | |
657 | switch(c) { | |
658 | case /*(*/')': case /*{*/'}': { | |
659 | OP *result = pop_rpn_item(); | |
660 | if(stack) croak("RPN expression must return a single value"); | |
661 | return result; | |
662 | } break; | |
663 | case '0': case '1': case '2': case '3': case '4': | |
664 | case '5': case '6': case '7': case '8': case '9': { | |
665 | UV val = 0; | |
666 | do { | |
667 | lex_read_unichar(0); | |
668 | val = 10*val + (c - '0'); | |
669 | c = lex_peek_unichar(0); | |
670 | } while(c >= '0' && c <= '9'); | |
671 | push_rpn_item(newSVOP(OP_CONST, 0, newSVuv(val))); | |
672 | } break; | |
673 | case '$': { | |
674 | push_rpn_item(parse_var()); | |
675 | } break; | |
676 | case '+': { | |
677 | OP *b = pop_rpn_item(); | |
678 | OP *a = pop_rpn_item(); | |
679 | lex_read_unichar(0); | |
680 | push_rpn_item(newBINOP(OP_I_ADD, 0, a, b)); | |
681 | } break; | |
682 | case '-': { | |
683 | OP *b = pop_rpn_item(); | |
684 | OP *a = pop_rpn_item(); | |
685 | lex_read_unichar(0); | |
686 | push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b)); | |
687 | } break; | |
688 | case '*': { | |
689 | OP *b = pop_rpn_item(); | |
690 | OP *a = pop_rpn_item(); | |
691 | lex_read_unichar(0); | |
692 | push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b)); | |
693 | } break; | |
694 | case '/': { | |
695 | OP *b = pop_rpn_item(); | |
696 | OP *a = pop_rpn_item(); | |
697 | lex_read_unichar(0); | |
698 | push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b)); | |
699 | } break; | |
700 | case '%': { | |
701 | OP *b = pop_rpn_item(); | |
702 | OP *a = pop_rpn_item(); | |
703 | lex_read_unichar(0); | |
704 | push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b)); | |
705 | } break; | |
706 | default: { | |
707 | croak("RPN syntax error"); | |
708 | } break; | |
709 | } | |
710 | } | |
711 | } | |
712 | ||
713 | #define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX) | |
714 | static OP *THX_parse_keyword_rpn(pTHX) | |
715 | { | |
716 | OP *op; | |
717 | lex_read_space(0); | |
718 | if(lex_peek_unichar(0) != '('/*)*/) | |
719 | croak("RPN expression must be parenthesised"); | |
720 | lex_read_unichar(0); | |
721 | op = parse_rpn_expr(); | |
722 | if(lex_peek_unichar(0) != /*(*/')') | |
723 | croak("RPN expression must be parenthesised"); | |
724 | lex_read_unichar(0); | |
725 | return op; | |
726 | } | |
727 | ||
728 | #define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX) | |
729 | static OP *THX_parse_keyword_calcrpn(pTHX) | |
730 | { | |
731 | OP *varop, *exprop; | |
732 | lex_read_space(0); | |
733 | varop = parse_var(); | |
734 | lex_read_space(0); | |
735 | if(lex_peek_unichar(0) != '{'/*}*/) | |
736 | croak("RPN expression must be braced"); | |
737 | lex_read_unichar(0); | |
738 | exprop = parse_rpn_expr(); | |
739 | if(lex_peek_unichar(0) != /*{*/'}') | |
740 | croak("RPN expression must be braced"); | |
741 | lex_read_unichar(0); | |
742 | return newASSIGNOP(OPf_STACKED, varop, 0, exprop); | |
743 | } | |
744 | ||
745 | #define parse_keyword_stufftest() THX_parse_keyword_stufftest(aTHX) | |
746 | static OP *THX_parse_keyword_stufftest(pTHX) | |
747 | { | |
748 | I32 c; | |
749 | bool do_stuff; | |
750 | lex_read_space(0); | |
751 | do_stuff = lex_peek_unichar(0) == '+'; | |
752 | if(do_stuff) { | |
753 | lex_read_unichar(0); | |
754 | lex_read_space(0); | |
755 | } | |
756 | c = lex_peek_unichar(0); | |
757 | if(c == ';') { | |
758 | lex_read_unichar(0); | |
759 | } else if(c != /*{*/'}') { | |
760 | croak("syntax error"); | |
761 | } | |
762 | if(do_stuff) lex_stuff_pvs(" ", 0); | |
763 | return newOP(OP_NULL, 0); | |
764 | } | |
765 | ||
766 | #define parse_keyword_swaptwostmts() THX_parse_keyword_swaptwostmts(aTHX) | |
767 | static OP *THX_parse_keyword_swaptwostmts(pTHX) | |
768 | { | |
769 | OP *a, *b; | |
770 | a = parse_fullstmt(0); | |
771 | b = parse_fullstmt(0); | |
772 | if(a && b) | |
773 | PL_hints |= HINT_BLOCK_SCOPE; | |
2fcb4757 | 774 | return op_append_list(OP_LINESEQ, b, a); |
83f8bb56 Z |
775 | } |
776 | ||
07ffcb73 Z |
777 | #define parse_keyword_looprest() THX_parse_keyword_looprest(aTHX) |
778 | static OP *THX_parse_keyword_looprest(pTHX) | |
779 | { | |
94bf0465 Z |
780 | return newWHILEOP(0, 1, NULL, newSVOP(OP_CONST, 0, &PL_sv_yes), |
781 | parse_stmtseq(0), NULL, 1); | |
07ffcb73 Z |
782 | } |
783 | ||
a7aaec61 Z |
784 | #define parse_keyword_scopelessblock() THX_parse_keyword_scopelessblock(aTHX) |
785 | static OP *THX_parse_keyword_scopelessblock(pTHX) | |
786 | { | |
787 | I32 c; | |
788 | OP *body; | |
789 | lex_read_space(0); | |
790 | if(lex_peek_unichar(0) != '{'/*}*/) croak("syntax error"); | |
791 | lex_read_unichar(0); | |
792 | body = parse_stmtseq(0); | |
793 | c = lex_peek_unichar(0); | |
794 | if(c != /*{*/'}' && c != /*[*/']' && c != /*(*/')') croak("syntax error"); | |
795 | lex_read_unichar(0); | |
796 | return body; | |
797 | } | |
798 | ||
9eb5c532 Z |
799 | #define parse_keyword_stmtasexpr() THX_parse_keyword_stmtasexpr(aTHX) |
800 | static OP *THX_parse_keyword_stmtasexpr(pTHX) | |
801 | { | |
8359b381 | 802 | OP *o = parse_barestmt(0); |
3ad73efd Z |
803 | if (!o) o = newOP(OP_STUB, 0); |
804 | if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS; | |
805 | return op_scope(o); | |
9eb5c532 Z |
806 | } |
807 | ||
808 | #define parse_keyword_stmtsasexpr() THX_parse_keyword_stmtsasexpr(aTHX) | |
809 | static OP *THX_parse_keyword_stmtsasexpr(pTHX) | |
810 | { | |
811 | OP *o; | |
812 | lex_read_space(0); | |
813 | if(lex_peek_unichar(0) != '{'/*}*/) croak("syntax error"); | |
814 | lex_read_unichar(0); | |
815 | o = parse_stmtseq(0); | |
816 | lex_read_space(0); | |
817 | if(lex_peek_unichar(0) != /*{*/'}') croak("syntax error"); | |
818 | lex_read_unichar(0); | |
3ad73efd Z |
819 | if (!o) o = newOP(OP_STUB, 0); |
820 | if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS; | |
821 | return op_scope(o); | |
9eb5c532 Z |
822 | } |
823 | ||
e53d8f76 Z |
824 | #define parse_keyword_loopblock() THX_parse_keyword_loopblock(aTHX) |
825 | static OP *THX_parse_keyword_loopblock(pTHX) | |
826 | { | |
94bf0465 Z |
827 | return newWHILEOP(0, 1, NULL, newSVOP(OP_CONST, 0, &PL_sv_yes), |
828 | parse_block(0), NULL, 1); | |
e53d8f76 Z |
829 | } |
830 | ||
831 | #define parse_keyword_blockasexpr() THX_parse_keyword_blockasexpr(aTHX) | |
832 | static OP *THX_parse_keyword_blockasexpr(pTHX) | |
833 | { | |
834 | OP *o = parse_block(0); | |
3ad73efd Z |
835 | if (!o) o = newOP(OP_STUB, 0); |
836 | if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS; | |
837 | return op_scope(o); | |
e53d8f76 Z |
838 | } |
839 | ||
361d9b55 Z |
840 | #define parse_keyword_swaplabel() THX_parse_keyword_swaplabel(aTHX) |
841 | static OP *THX_parse_keyword_swaplabel(pTHX) | |
842 | { | |
843 | OP *sop = parse_barestmt(0); | |
844 | SV *label = parse_label(PARSE_OPTIONAL); | |
845 | if (label) sv_2mortal(label); | |
846 | return newSTATEOP(0, label ? savepv(SvPVX(label)) : NULL, sop); | |
847 | } | |
848 | ||
849 | #define parse_keyword_labelconst() THX_parse_keyword_labelconst(aTHX) | |
850 | static OP *THX_parse_keyword_labelconst(pTHX) | |
851 | { | |
852 | return newSVOP(OP_CONST, 0, parse_label(0)); | |
853 | } | |
854 | ||
78cdf107 Z |
855 | #define parse_keyword_arrayfullexpr() THX_parse_keyword_arrayfullexpr(aTHX) |
856 | static OP *THX_parse_keyword_arrayfullexpr(pTHX) | |
857 | { | |
858 | return newANONLIST(parse_fullexpr(0)); | |
859 | } | |
860 | ||
861 | #define parse_keyword_arraylistexpr() THX_parse_keyword_arraylistexpr(aTHX) | |
862 | static OP *THX_parse_keyword_arraylistexpr(pTHX) | |
863 | { | |
864 | return newANONLIST(parse_listexpr(0)); | |
865 | } | |
866 | ||
867 | #define parse_keyword_arraytermexpr() THX_parse_keyword_arraytermexpr(aTHX) | |
868 | static OP *THX_parse_keyword_arraytermexpr(pTHX) | |
869 | { | |
870 | return newANONLIST(parse_termexpr(0)); | |
871 | } | |
872 | ||
873 | #define parse_keyword_arrayarithexpr() THX_parse_keyword_arrayarithexpr(aTHX) | |
874 | static OP *THX_parse_keyword_arrayarithexpr(pTHX) | |
875 | { | |
876 | return newANONLIST(parse_arithexpr(0)); | |
877 | } | |
878 | ||
879 | #define parse_keyword_arrayexprflags() THX_parse_keyword_arrayexprflags(aTHX) | |
880 | static OP *THX_parse_keyword_arrayexprflags(pTHX) | |
881 | { | |
882 | U32 flags = 0; | |
883 | I32 c; | |
884 | OP *o; | |
885 | lex_read_space(0); | |
886 | c = lex_peek_unichar(0); | |
887 | if (c != '!' && c != '?') croak("syntax error"); | |
888 | lex_read_unichar(0); | |
889 | if (c == '?') flags |= PARSE_OPTIONAL; | |
890 | o = parse_listexpr(flags); | |
891 | return o ? newANONLIST(o) : newANONHASH(newOP(OP_STUB, 0)); | |
892 | } | |
893 | ||
83f8bb56 Z |
894 | /* plugin glue */ |
895 | ||
896 | #define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv) | |
897 | static int THX_keyword_active(pTHX_ SV *hintkey_sv) | |
898 | { | |
899 | HE *he; | |
900 | if(!GvHV(PL_hintgv)) return 0; | |
901 | he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0, | |
902 | SvSHARED_HASH(hintkey_sv)); | |
903 | return he && SvTRUE(HeVAL(he)); | |
904 | } | |
905 | ||
906 | static int my_keyword_plugin(pTHX_ | |
907 | char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) | |
908 | { | |
909 | if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) && | |
910 | keyword_active(hintkey_rpn_sv)) { | |
911 | *op_ptr = parse_keyword_rpn(); | |
912 | return KEYWORD_PLUGIN_EXPR; | |
913 | } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) && | |
914 | keyword_active(hintkey_calcrpn_sv)) { | |
915 | *op_ptr = parse_keyword_calcrpn(); | |
916 | return KEYWORD_PLUGIN_STMT; | |
917 | } else if(keyword_len == 9 && strnEQ(keyword_ptr, "stufftest", 9) && | |
918 | keyword_active(hintkey_stufftest_sv)) { | |
919 | *op_ptr = parse_keyword_stufftest(); | |
920 | return KEYWORD_PLUGIN_STMT; | |
921 | } else if(keyword_len == 12 && | |
922 | strnEQ(keyword_ptr, "swaptwostmts", 12) && | |
923 | keyword_active(hintkey_swaptwostmts_sv)) { | |
924 | *op_ptr = parse_keyword_swaptwostmts(); | |
925 | return KEYWORD_PLUGIN_STMT; | |
07ffcb73 Z |
926 | } else if(keyword_len == 8 && strnEQ(keyword_ptr, "looprest", 8) && |
927 | keyword_active(hintkey_looprest_sv)) { | |
928 | *op_ptr = parse_keyword_looprest(); | |
929 | return KEYWORD_PLUGIN_STMT; | |
a7aaec61 Z |
930 | } else if(keyword_len == 14 && strnEQ(keyword_ptr, "scopelessblock", 14) && |
931 | keyword_active(hintkey_scopelessblock_sv)) { | |
932 | *op_ptr = parse_keyword_scopelessblock(); | |
933 | return KEYWORD_PLUGIN_STMT; | |
9eb5c532 Z |
934 | } else if(keyword_len == 10 && strnEQ(keyword_ptr, "stmtasexpr", 10) && |
935 | keyword_active(hintkey_stmtasexpr_sv)) { | |
936 | *op_ptr = parse_keyword_stmtasexpr(); | |
937 | return KEYWORD_PLUGIN_EXPR; | |
938 | } else if(keyword_len == 11 && strnEQ(keyword_ptr, "stmtsasexpr", 11) && | |
939 | keyword_active(hintkey_stmtsasexpr_sv)) { | |
940 | *op_ptr = parse_keyword_stmtsasexpr(); | |
941 | return KEYWORD_PLUGIN_EXPR; | |
e53d8f76 Z |
942 | } else if(keyword_len == 9 && strnEQ(keyword_ptr, "loopblock", 9) && |
943 | keyword_active(hintkey_loopblock_sv)) { | |
944 | *op_ptr = parse_keyword_loopblock(); | |
945 | return KEYWORD_PLUGIN_STMT; | |
946 | } else if(keyword_len == 11 && strnEQ(keyword_ptr, "blockasexpr", 11) && | |
947 | keyword_active(hintkey_blockasexpr_sv)) { | |
948 | *op_ptr = parse_keyword_blockasexpr(); | |
949 | return KEYWORD_PLUGIN_EXPR; | |
361d9b55 Z |
950 | } else if(keyword_len == 9 && strnEQ(keyword_ptr, "swaplabel", 9) && |
951 | keyword_active(hintkey_swaplabel_sv)) { | |
952 | *op_ptr = parse_keyword_swaplabel(); | |
953 | return KEYWORD_PLUGIN_STMT; | |
954 | } else if(keyword_len == 10 && strnEQ(keyword_ptr, "labelconst", 10) && | |
955 | keyword_active(hintkey_labelconst_sv)) { | |
956 | *op_ptr = parse_keyword_labelconst(); | |
957 | return KEYWORD_PLUGIN_EXPR; | |
78cdf107 Z |
958 | } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arrayfullexpr", 13) && |
959 | keyword_active(hintkey_arrayfullexpr_sv)) { | |
960 | *op_ptr = parse_keyword_arrayfullexpr(); | |
961 | return KEYWORD_PLUGIN_EXPR; | |
962 | } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arraylistexpr", 13) && | |
963 | keyword_active(hintkey_arraylistexpr_sv)) { | |
964 | *op_ptr = parse_keyword_arraylistexpr(); | |
965 | return KEYWORD_PLUGIN_EXPR; | |
966 | } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arraytermexpr", 13) && | |
967 | keyword_active(hintkey_arraytermexpr_sv)) { | |
968 | *op_ptr = parse_keyword_arraytermexpr(); | |
969 | return KEYWORD_PLUGIN_EXPR; | |
970 | } else if(keyword_len == 14 && strnEQ(keyword_ptr, "arrayarithexpr", 14) && | |
971 | keyword_active(hintkey_arrayarithexpr_sv)) { | |
972 | *op_ptr = parse_keyword_arrayarithexpr(); | |
973 | return KEYWORD_PLUGIN_EXPR; | |
974 | } else if(keyword_len == 14 && strnEQ(keyword_ptr, "arrayexprflags", 14) && | |
975 | keyword_active(hintkey_arrayexprflags_sv)) { | |
976 | *op_ptr = parse_keyword_arrayexprflags(); | |
977 | return KEYWORD_PLUGIN_EXPR; | |
83f8bb56 Z |
978 | } else { |
979 | return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr); | |
980 | } | |
981 | } | |
982 | ||
f568d64d BM |
983 | static XOP my_xop; |
984 | ||
985 | static OP * | |
986 | pp_xop(pTHX) | |
987 | { | |
988 | return PL_op->op_next; | |
989 | } | |
990 | ||
991 | static void | |
992 | peep_xop(pTHX_ OP *o, OP *oldop) | |
993 | { | |
994 | dMY_CXT; | |
b58757d5 BM |
995 | av_push(MY_CXT.xop_record, newSVpvf("peep:%"UVxf, PTR2UV(o))); |
996 | av_push(MY_CXT.xop_record, newSVpvf("oldop:%"UVxf, PTR2UV(oldop))); | |
f568d64d BM |
997 | } |
998 | ||
7b20c7cd | 999 | XS(XS_XS__APItest__XSUB_XS_VERSION_undef); |
f9cc56fa | 1000 | XS(XS_XS__APItest__XSUB_XS_VERSION_empty); |
88c4b02d | 1001 | XS(XS_XS__APItest__XSUB_XS_APIVERSION_invalid); |
7b20c7cd | 1002 | |
55289a74 NC |
1003 | #include "const-c.inc" |
1004 | ||
ffe53d21 | 1005 | MODULE = XS::APItest PACKAGE = XS::APItest |
0314122a | 1006 | |
55289a74 NC |
1007 | INCLUDE: const-xs.inc |
1008 | ||
ffe53d21 NC |
1009 | INCLUDE: numeric.xs |
1010 | ||
fed3ba5d NC |
1011 | MODULE = XS::APItest::utf8 PACKAGE = XS::APItest::utf8 |
1012 | ||
1013 | int | |
1014 | bytes_cmp_utf8(bytes, utf8) | |
1015 | SV *bytes | |
1016 | SV *utf8 | |
1017 | PREINIT: | |
1018 | const U8 *b; | |
1019 | STRLEN blen; | |
1020 | const U8 *u; | |
1021 | STRLEN ulen; | |
1022 | CODE: | |
1023 | b = (const U8 *)SvPVbyte(bytes, blen); | |
1024 | u = (const U8 *)SvPVbyte(utf8, ulen); | |
1025 | RETVAL = bytes_cmp_utf8(b, blen, u, ulen); | |
1026 | OUTPUT: | |
1027 | RETVAL | |
1028 | ||
7d255dc8 NC |
1029 | MODULE = XS::APItest:Overload PACKAGE = XS::APItest::Overload |
1030 | ||
c33e8be1 | 1031 | void |
25a9ffce | 1032 | amagic_deref_call(sv, what) |
7d255dc8 NC |
1033 | SV *sv |
1034 | int what | |
1035 | PPCODE: | |
7d255dc8 | 1036 | /* The reference is owned by something else. */ |
25a9ffce | 1037 | PUSHs(amagic_deref_call(sv, what)); |
7d255dc8 | 1038 | |
e89bfaa6 NC |
1039 | # I'd certainly like to discourage the use of this macro, given that we now |
1040 | # have amagic_deref_call | |
1041 | ||
c33e8be1 | 1042 | void |
e89bfaa6 NC |
1043 | tryAMAGICunDEREF_var(sv, what) |
1044 | SV *sv | |
1045 | int what | |
1046 | PPCODE: | |
1047 | { | |
1048 | SV **sp = &sv; | |
1049 | switch(what) { | |
1050 | case to_av_amg: | |
1051 | tryAMAGICunDEREF(to_av); | |
1052 | break; | |
1053 | case to_cv_amg: | |
1054 | tryAMAGICunDEREF(to_cv); | |
1055 | break; | |
1056 | case to_gv_amg: | |
1057 | tryAMAGICunDEREF(to_gv); | |
1058 | break; | |
1059 | case to_hv_amg: | |
1060 | tryAMAGICunDEREF(to_hv); | |
1061 | break; | |
1062 | case to_sv_amg: | |
1063 | tryAMAGICunDEREF(to_sv); | |
1064 | break; | |
1065 | default: | |
1066 | croak("Invalid value %d passed to tryAMAGICunDEREF_var", what); | |
1067 | } | |
1068 | } | |
1069 | /* The reference is owned by something else. */ | |
1070 | PUSHs(sv); | |
1071 | ||
7b20c7cd NC |
1072 | MODULE = XS::APItest PACKAGE = XS::APItest::XSUB |
1073 | ||
1074 | BOOT: | |
1075 | newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__); | |
f9cc56fa | 1076 | newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__); |
88c4b02d | 1077 | newXS("XS::APItest::XSUB::XS_APIVERSION_invalid", XS_XS__APItest__XSUB_XS_APIVERSION_invalid, __FILE__); |
7b20c7cd NC |
1078 | |
1079 | void | |
1080 | XS_VERSION_defined(...) | |
1081 | PPCODE: | |
1082 | XS_VERSION_BOOTCHECK; | |
1083 | XSRETURN_EMPTY; | |
1084 | ||
88c4b02d NC |
1085 | void |
1086 | XS_APIVERSION_valid(...) | |
1087 | PPCODE: | |
1088 | XS_APIVERSION_BOOTCHECK; | |
1089 | XSRETURN_EMPTY; | |
1090 | ||
ffe53d21 NC |
1091 | MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash |
1092 | ||
b54b4831 NC |
1093 | void |
1094 | rot13_hash(hash) | |
1095 | HV *hash | |
1096 | CODE: | |
1097 | { | |
1098 | struct ufuncs uf; | |
1099 | uf.uf_val = rot13_key; | |
1100 | uf.uf_set = 0; | |
1101 | uf.uf_index = 0; | |
1102 | ||
1103 | sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf)); | |
1104 | } | |
1105 | ||
53c40a8f NC |
1106 | void |
1107 | bitflip_hash(hash) | |
1108 | HV *hash | |
1109 | CODE: | |
1110 | { | |
1111 | struct ufuncs uf; | |
1112 | uf.uf_val = bitflip_key; | |
1113 | uf.uf_set = 0; | |
1114 | uf.uf_index = 0; | |
1115 | ||
1116 | sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf)); | |
1117 | } | |
1118 | ||
028f8eaa MHM |
1119 | #define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len) |
1120 | ||
0314122a NC |
1121 | bool |
1122 | exists(hash, key_sv) | |
1123 | PREINIT: | |
1124 | STRLEN len; | |
1125 | const char *key; | |
1126 | INPUT: | |
1127 | HV *hash | |
1128 | SV *key_sv | |
1129 | CODE: | |
1130 | key = SvPV(key_sv, len); | |
028f8eaa | 1131 | RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len)); |
0314122a NC |
1132 | OUTPUT: |
1133 | RETVAL | |
1134 | ||
bdee33e4 NC |
1135 | bool |
1136 | exists_ent(hash, key_sv) | |
1137 | PREINIT: | |
1138 | INPUT: | |
1139 | HV *hash | |
1140 | SV *key_sv | |
1141 | CODE: | |
1142 | RETVAL = hv_exists_ent(hash, key_sv, 0); | |
1143 | OUTPUT: | |
1144 | RETVAL | |
1145 | ||
b60cf05a | 1146 | SV * |
55289a74 | 1147 | delete(hash, key_sv, flags = 0) |
b60cf05a NC |
1148 | PREINIT: |
1149 | STRLEN len; | |
1150 | const char *key; | |
1151 | INPUT: | |
1152 | HV *hash | |
1153 | SV *key_sv | |
55289a74 | 1154 | I32 flags; |
b60cf05a NC |
1155 | CODE: |
1156 | key = SvPV(key_sv, len); | |
1157 | /* It's already mortal, so need to increase reference count. */ | |
55289a74 NC |
1158 | RETVAL |
1159 | = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags)); | |
1160 | OUTPUT: | |
1161 | RETVAL | |
1162 | ||
1163 | SV * | |
1164 | delete_ent(hash, key_sv, flags = 0) | |
1165 | INPUT: | |
1166 | HV *hash | |
1167 | SV *key_sv | |
1168 | I32 flags; | |
1169 | CODE: | |
1170 | /* It's already mortal, so need to increase reference count. */ | |
1171 | RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0)); | |
b60cf05a NC |
1172 | OUTPUT: |
1173 | RETVAL | |
1174 | ||
1175 | SV * | |
858117f8 NC |
1176 | store_ent(hash, key, value) |
1177 | PREINIT: | |
1178 | SV *copy; | |
1179 | HE *result; | |
1180 | INPUT: | |
1181 | HV *hash | |
1182 | SV *key | |
1183 | SV *value | |
1184 | CODE: | |
1185 | copy = newSV(0); | |
1186 | result = hv_store_ent(hash, key, copy, 0); | |
1187 | SvSetMagicSV(copy, value); | |
1188 | if (!result) { | |
1189 | SvREFCNT_dec(copy); | |
1190 | XSRETURN_EMPTY; | |
1191 | } | |
1192 | /* It's about to become mortal, so need to increase reference count. | |
1193 | */ | |
1194 | RETVAL = SvREFCNT_inc(HeVAL(result)); | |
1195 | OUTPUT: | |
1196 | RETVAL | |
1197 | ||
858117f8 | 1198 | SV * |
b60cf05a NC |
1199 | store(hash, key_sv, value) |
1200 | PREINIT: | |
1201 | STRLEN len; | |
1202 | const char *key; | |
1203 | SV *copy; | |
1204 | SV **result; | |
1205 | INPUT: | |
1206 | HV *hash | |
1207 | SV *key_sv | |
1208 | SV *value | |
1209 | CODE: | |
1210 | key = SvPV(key_sv, len); | |
1211 | copy = newSV(0); | |
028f8eaa | 1212 | result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0); |
858117f8 | 1213 | SvSetMagicSV(copy, value); |
b60cf05a NC |
1214 | if (!result) { |
1215 | SvREFCNT_dec(copy); | |
1216 | XSRETURN_EMPTY; | |
1217 | } | |
1218 | /* It's about to become mortal, so need to increase reference count. | |
1219 | */ | |
1220 | RETVAL = SvREFCNT_inc(*result); | |
1221 | OUTPUT: | |
1222 | RETVAL | |
1223 | ||
bdee33e4 NC |
1224 | SV * |
1225 | fetch_ent(hash, key_sv) | |
1226 | PREINIT: | |
1227 | HE *result; | |
1228 | INPUT: | |
1229 | HV *hash | |
1230 | SV *key_sv | |
1231 | CODE: | |
1232 | result = hv_fetch_ent(hash, key_sv, 0, 0); | |
1233 | if (!result) { | |
1234 | XSRETURN_EMPTY; | |
1235 | } | |
1236 | /* Force mg_get */ | |
1237 | RETVAL = newSVsv(HeVAL(result)); | |
1238 | OUTPUT: | |
1239 | RETVAL | |
b60cf05a NC |
1240 | |
1241 | SV * | |
1242 | fetch(hash, key_sv) | |
1243 | PREINIT: | |
1244 | STRLEN len; | |
1245 | const char *key; | |
1246 | SV **result; | |
1247 | INPUT: | |
1248 | HV *hash | |
1249 | SV *key_sv | |
1250 | CODE: | |
1251 | key = SvPV(key_sv, len); | |
028f8eaa | 1252 | result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0); |
b60cf05a NC |
1253 | if (!result) { |
1254 | XSRETURN_EMPTY; | |
1255 | } | |
1256 | /* Force mg_get */ | |
1257 | RETVAL = newSVsv(*result); | |
1258 | OUTPUT: | |
1259 | RETVAL | |
2dc92170 | 1260 | |
9568a123 NC |
1261 | #if defined (hv_common) |
1262 | ||
6b4de907 NC |
1263 | SV * |
1264 | common(params) | |
1265 | INPUT: | |
1266 | HV *params | |
1267 | PREINIT: | |
1268 | HE *result; | |
1269 | HV *hv = NULL; | |
1270 | SV *keysv = NULL; | |
1271 | const char *key = NULL; | |
1272 | STRLEN klen = 0; | |
1273 | int flags = 0; | |
1274 | int action = 0; | |
1275 | SV *val = NULL; | |
1276 | U32 hash = 0; | |
1277 | SV **svp; | |
1278 | CODE: | |
1279 | if ((svp = hv_fetchs(params, "hv", 0))) { | |
1280 | SV *const rv = *svp; | |
1281 | if (!SvROK(rv)) | |
1282 | croak("common passed a non-reference for parameter hv"); | |
1283 | hv = (HV *)SvRV(rv); | |
1284 | } | |
1285 | if ((svp = hv_fetchs(params, "keysv", 0))) | |
1286 | keysv = *svp; | |
1287 | if ((svp = hv_fetchs(params, "keypv", 0))) { | |
1288 | key = SvPV_const(*svp, klen); | |
1289 | if (SvUTF8(*svp)) | |
1290 | flags = HVhek_UTF8; | |
1291 | } | |
1292 | if ((svp = hv_fetchs(params, "action", 0))) | |
1293 | action = SvIV(*svp); | |
1294 | if ((svp = hv_fetchs(params, "val", 0))) | |
527df579 | 1295 | val = newSVsv(*svp); |
6b4de907 | 1296 | if ((svp = hv_fetchs(params, "hash", 0))) |
a44093a9 | 1297 | hash = SvUV(*svp); |
6b4de907 | 1298 | |
527df579 NC |
1299 | if ((svp = hv_fetchs(params, "hash_pv", 0))) { |
1300 | PERL_HASH(hash, key, klen); | |
1301 | } | |
58ca560a NC |
1302 | if ((svp = hv_fetchs(params, "hash_sv", 0))) { |
1303 | STRLEN len; | |
1304 | const char *const p = SvPV(keysv, len); | |
1305 | PERL_HASH(hash, p, len); | |
1306 | } | |
527df579 | 1307 | |
a75fcbca | 1308 | result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash); |
6b4de907 NC |
1309 | if (!result) { |
1310 | XSRETURN_EMPTY; | |
1311 | } | |
1312 | /* Force mg_get */ | |
1313 | RETVAL = newSVsv(HeVAL(result)); | |
1314 | OUTPUT: | |
1315 | RETVAL | |
1316 | ||
9568a123 NC |
1317 | #endif |
1318 | ||
439efdfe | 1319 | void |
2dc92170 NC |
1320 | test_hv_free_ent() |
1321 | PPCODE: | |
1322 | test_freeent(&Perl_hv_free_ent); | |
1323 | XSRETURN(4); | |
1324 | ||
439efdfe | 1325 | void |
2dc92170 NC |
1326 | test_hv_delayfree_ent() |
1327 | PPCODE: | |
1328 | test_freeent(&Perl_hv_delayfree_ent); | |
1329 | XSRETURN(4); | |
35ab5632 NC |
1330 | |
1331 | SV * | |
1332 | test_share_unshare_pvn(input) | |
1333 | PREINIT: | |
35ab5632 NC |
1334 | STRLEN len; |
1335 | U32 hash; | |
1336 | char *pvx; | |
1337 | char *p; | |
1338 | INPUT: | |
1339 | SV *input | |
1340 | CODE: | |
1341 | pvx = SvPV(input, len); | |
1342 | PERL_HASH(hash, pvx, len); | |
1343 | p = sharepvn(pvx, len, hash); | |
1344 | RETVAL = newSVpvn(p, len); | |
1345 | unsharepvn(p, len, hash); | |
1346 | OUTPUT: | |
1347 | RETVAL | |
d8c5b3c5 | 1348 | |
9568a123 NC |
1349 | #if PERL_VERSION >= 9 |
1350 | ||
d8c5b3c5 NC |
1351 | bool |
1352 | refcounted_he_exists(key, level=0) | |
1353 | SV *key | |
1354 | IV level | |
1355 | CODE: | |
1356 | if (level) { | |
1357 | croak("level must be zero, not %"IVdf, level); | |
1358 | } | |
20439bc7 | 1359 | RETVAL = (cop_hints_fetch_sv(PL_curcop, key, 0, 0) != &PL_sv_placeholder); |
d8c5b3c5 NC |
1360 | OUTPUT: |
1361 | RETVAL | |
1362 | ||
d8c5b3c5 NC |
1363 | SV * |
1364 | refcounted_he_fetch(key, level=0) | |
1365 | SV *key | |
1366 | IV level | |
1367 | CODE: | |
1368 | if (level) { | |
1369 | croak("level must be zero, not %"IVdf, level); | |
1370 | } | |
20439bc7 | 1371 | RETVAL = cop_hints_fetch_sv(PL_curcop, key, 0, 0); |
d8c5b3c5 NC |
1372 | SvREFCNT_inc(RETVAL); |
1373 | OUTPUT: | |
1374 | RETVAL | |
65bfe90c | 1375 | |
9568a123 | 1376 | #endif |
65bfe90c | 1377 | |
0314122a NC |
1378 | =pod |
1379 | ||
1380 | sub TIEHASH { bless {}, $_[0] } | |
1381 | sub STORE { $_[0]->{$_[1]} = $_[2] } | |
1382 | sub FETCH { $_[0]->{$_[1]} } | |
1383 | sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} } | |
1384 | sub NEXTKEY { each %{$_[0]} } | |
1385 | sub EXISTS { exists $_[0]->{$_[1]} } | |
1386 | sub DELETE { delete $_[0]->{$_[1]} } | |
1387 | sub CLEAR { %{$_[0]} = () } | |
1388 | ||
1389 | =cut | |
1390 | ||
e2fe06dd EB |
1391 | MODULE = XS::APItest:TempLv PACKAGE = XS::APItest::TempLv |
1392 | ||
1393 | void | |
1394 | make_temp_mg_lv(sv) | |
1395 | SV* sv | |
1396 | PREINIT: | |
1397 | SV * const lv = newSV_type(SVt_PVLV); | |
1398 | STRLEN len; | |
1399 | PPCODE: | |
1400 | SvPV(sv, len); | |
1401 | ||
1402 | sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0); | |
1403 | LvTYPE(lv) = 'x'; | |
1404 | LvTARG(lv) = SvREFCNT_inc_simple(sv); | |
1405 | LvTARGOFF(lv) = len == 0 ? 0 : 1; | |
1406 | LvTARGLEN(lv) = len < 2 ? 0 : len-2; | |
1407 | ||
1408 | EXTEND(SP, 1); | |
1409 | ST(0) = sv_2mortal(lv); | |
1410 | XSRETURN(1); | |
1411 | ||
1412 | ||
36c2b1d0 NC |
1413 | MODULE = XS::APItest::PtrTable PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_ |
1414 | ||
1415 | void | |
1416 | ptr_table_new(classname) | |
1417 | const char * classname | |
1418 | PPCODE: | |
1419 | PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new())); | |
1420 | ||
1421 | void | |
1422 | DESTROY(table) | |
1423 | XS::APItest::PtrTable table | |
1424 | CODE: | |
1425 | ptr_table_free(table); | |
1426 | ||
1427 | void | |
992b2363 | 1428 | ptr_table_store(table, from, to) |
36c2b1d0 | 1429 | XS::APItest::PtrTable table |
992b2363 NC |
1430 | SVREF from |
1431 | SVREF to | |
36c2b1d0 | 1432 | CODE: |
992b2363 | 1433 | ptr_table_store(table, from, to); |
36c2b1d0 NC |
1434 | |
1435 | UV | |
992b2363 | 1436 | ptr_table_fetch(table, from) |
36c2b1d0 | 1437 | XS::APItest::PtrTable table |
992b2363 | 1438 | SVREF from |
36c2b1d0 | 1439 | CODE: |
992b2363 | 1440 | RETVAL = PTR2UV(ptr_table_fetch(table, from)); |
36c2b1d0 NC |
1441 | OUTPUT: |
1442 | RETVAL | |
1443 | ||
1444 | void | |
1445 | ptr_table_split(table) | |
1446 | XS::APItest::PtrTable table | |
1447 | ||
1448 | void | |
1449 | ptr_table_clear(table) | |
1450 | XS::APItest::PtrTable table | |
1451 | ||
3e61d65a JH |
1452 | MODULE = XS::APItest PACKAGE = XS::APItest |
1453 | ||
1454 | PROTOTYPES: DISABLE | |
1455 | ||
f568d64d BM |
1456 | HV * |
1457 | xop_custom_ops () | |
1458 | CODE: | |
1459 | RETVAL = PL_custom_ops; | |
1460 | OUTPUT: | |
1461 | RETVAL | |
1462 | ||
1463 | HV * | |
1464 | xop_custom_op_names () | |
1465 | CODE: | |
1466 | PL_custom_op_names = newHV(); | |
1467 | RETVAL = PL_custom_op_names; | |
1468 | OUTPUT: | |
1469 | RETVAL | |
1470 | ||
1471 | HV * | |
1472 | xop_custom_op_descs () | |
1473 | CODE: | |
1474 | PL_custom_op_descs = newHV(); | |
1475 | RETVAL = PL_custom_op_descs; | |
1476 | OUTPUT: | |
1477 | RETVAL | |
1478 | ||
1479 | void | |
1480 | xop_register () | |
1481 | CODE: | |
1482 | XopENTRY_set(&my_xop, xop_name, "my_xop"); | |
1483 | XopENTRY_set(&my_xop, xop_desc, "XOP for testing"); | |
1484 | XopENTRY_set(&my_xop, xop_class, OA_UNOP); | |
1485 | XopENTRY_set(&my_xop, xop_peep, peep_xop); | |
1486 | Perl_custom_op_register(aTHX_ pp_xop, &my_xop); | |
1487 | ||
1488 | void | |
1489 | xop_clear () | |
1490 | CODE: | |
1491 | XopDISABLE(&my_xop, xop_name); | |
1492 | XopDISABLE(&my_xop, xop_desc); | |
1493 | XopDISABLE(&my_xop, xop_class); | |
1494 | XopDISABLE(&my_xop, xop_peep); | |
1495 | ||
1496 | IV | |
1497 | xop_my_xop () | |
1498 | CODE: | |
1499 | RETVAL = PTR2IV(&my_xop); | |
1500 | OUTPUT: | |
1501 | RETVAL | |
1502 | ||
1503 | IV | |
1504 | xop_ppaddr () | |
1505 | CODE: | |
1506 | RETVAL = PTR2IV(pp_xop); | |
1507 | OUTPUT: | |
1508 | RETVAL | |
1509 | ||
1510 | IV | |
1511 | xop_OA_UNOP () | |
1512 | CODE: | |
1513 | RETVAL = OA_UNOP; | |
1514 | OUTPUT: | |
1515 | RETVAL | |
1516 | ||
1517 | AV * | |
1518 | xop_build_optree () | |
1519 | CODE: | |
1520 | dMY_CXT; | |
1521 | UNOP *unop; | |
1522 | OP *kid; | |
1523 | ||
1524 | MY_CXT.xop_record = newAV(); | |
1525 | ||
1526 | kid = newSVOP(OP_CONST, 0, newSViv(42)); | |
1527 | ||
1528 | NewOp(1102, unop, 1, UNOP); | |
1529 | unop->op_type = OP_CUSTOM; | |
1530 | unop->op_ppaddr = pp_xop; | |
1531 | unop->op_flags = OPf_KIDS; | |
1532 | unop->op_private = 0; | |
1533 | unop->op_first = kid; | |
1534 | unop->op_next = NULL; | |
1535 | kid->op_next = (OP*)unop; | |
1536 | ||
b58757d5 BM |
1537 | av_push(MY_CXT.xop_record, newSVpvf("unop:%"UVxf, PTR2UV(unop))); |
1538 | av_push(MY_CXT.xop_record, newSVpvf("kid:%"UVxf, PTR2UV(kid))); | |
f568d64d BM |
1539 | |
1540 | av_push(MY_CXT.xop_record, newSVpvf("NAME:%s", OP_NAME((OP*)unop))); | |
1541 | av_push(MY_CXT.xop_record, newSVpvf("DESC:%s", OP_DESC((OP*)unop))); | |
c33e8be1 | 1542 | av_push(MY_CXT.xop_record, newSVpvf("CLASS:%d", (int)OP_CLASS((OP*)unop))); |
f568d64d BM |
1543 | |
1544 | PL_rpeepp(aTHX_ kid); | |
1545 | ||
1546 | FreeOp(kid); | |
1547 | FreeOp(unop); | |
1548 | ||
1549 | RETVAL = MY_CXT.xop_record; | |
1550 | MY_CXT.xop_record = NULL; | |
1551 | OUTPUT: | |
1552 | RETVAL | |
1553 | ||
85ce96a1 DM |
1554 | BOOT: |
1555 | { | |
1556 | MY_CXT_INIT; | |
03569ecf | 1557 | |
85ce96a1 DM |
1558 | MY_CXT.i = 99; |
1559 | MY_CXT.sv = newSVpv("initial",0); | |
13b6b3bc BM |
1560 | |
1561 | MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI); | |
1562 | MY_CXT.bhk_record = 0; | |
1563 | ||
a88d97bf BM |
1564 | BhkENTRY_set(&bhk_test, bhk_start, blockhook_test_start); |
1565 | BhkENTRY_set(&bhk_test, bhk_pre_end, blockhook_test_pre_end); | |
1566 | BhkENTRY_set(&bhk_test, bhk_post_end, blockhook_test_post_end); | |
1567 | BhkENTRY_set(&bhk_test, bhk_eval, blockhook_test_eval); | |
13b6b3bc BM |
1568 | Perl_blockhook_register(aTHX_ &bhk_test); |
1569 | ||
65bfe90c | 1570 | MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER", |
13b6b3bc | 1571 | GV_ADDMULTI, SVt_PVAV); |
03569ecf BM |
1572 | MY_CXT.cscav = GvAV(MY_CXT.cscgv); |
1573 | ||
a88d97bf BM |
1574 | BhkENTRY_set(&bhk_csc, bhk_start, blockhook_csc_start); |
1575 | BhkENTRY_set(&bhk_csc, bhk_pre_end, blockhook_csc_pre_end); | |
13b6b3bc | 1576 | Perl_blockhook_register(aTHX_ &bhk_csc); |
201c7e1f FR |
1577 | |
1578 | MY_CXT.peep_recorder = newAV(); | |
1579 | MY_CXT.rpeep_recorder = newAV(); | |
1580 | ||
1581 | MY_CXT.orig_peep = PL_peepp; | |
1582 | MY_CXT.orig_rpeep = PL_rpeepp; | |
1583 | PL_peepp = my_peep; | |
1584 | PL_rpeepp = my_rpeep; | |
65bfe90c | 1585 | } |
85ce96a1 DM |
1586 | |
1587 | void | |
1588 | CLONE(...) | |
1589 | CODE: | |
1590 | MY_CXT_CLONE; | |
c33e8be1 | 1591 | PERL_UNUSED_VAR(items); |
85ce96a1 | 1592 | MY_CXT.sv = newSVpv("initial_clone",0); |
65bfe90c | 1593 | MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER", |
13b6b3bc | 1594 | GV_ADDMULTI, SVt_PVAV); |
03569ecf | 1595 | MY_CXT.cscav = NULL; |
13b6b3bc BM |
1596 | MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI); |
1597 | MY_CXT.bhk_record = 0; | |
201c7e1f FR |
1598 | MY_CXT.peep_recorder = newAV(); |
1599 | MY_CXT.rpeep_recorder = newAV(); | |
85ce96a1 | 1600 | |
3e61d65a JH |
1601 | void |
1602 | print_double(val) | |
1603 | double val | |
1604 | CODE: | |
1605 | printf("%5.3f\n",val); | |
1606 | ||
1607 | int | |
1608 | have_long_double() | |
1609 | CODE: | |
1610 | #ifdef HAS_LONG_DOUBLE | |
1611 | RETVAL = 1; | |
1612 | #else | |
1613 | RETVAL = 0; | |
1614 | #endif | |
cabb36f0 CN |
1615 | OUTPUT: |
1616 | RETVAL | |
3e61d65a JH |
1617 | |
1618 | void | |
1619 | print_long_double() | |
1620 | CODE: | |
1621 | #ifdef HAS_LONG_DOUBLE | |
fc0bf671 | 1622 | # if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE) |
3e61d65a JH |
1623 | long double val = 7.0; |
1624 | printf("%5.3" PERL_PRIfldbl "\n",val); | |
1625 | # else | |
1626 | double val = 7.0; | |
1627 | printf("%5.3f\n",val); | |
1628 | # endif | |
1629 | #endif | |
1630 | ||
1631 | void | |
3e61d65a JH |
1632 | print_int(val) |
1633 | int val | |
1634 | CODE: | |
1635 | printf("%d\n",val); | |
1636 | ||
1637 | void | |
1638 | print_long(val) | |
1639 | long val | |
1640 | CODE: | |
1641 | printf("%ld\n",val); | |
1642 | ||
1643 | void | |
1644 | print_float(val) | |
1645 | float val | |
1646 | CODE: | |
1647 | printf("%5.3f\n",val); | |
9d911683 NIS |
1648 | |
1649 | void | |
1650 | print_flush() | |
1651 | CODE: | |
1652 | fflush(stdout); | |
d4b90eee SH |
1653 | |
1654 | void | |
1655 | mpushp() | |
1656 | PPCODE: | |
1657 | EXTEND(SP, 3); | |
1658 | mPUSHp("one", 3); | |
1659 | mPUSHp("two", 3); | |
1660 | mPUSHp("three", 5); | |
1661 | XSRETURN(3); | |
1662 | ||
1663 | void | |
1664 | mpushn() | |
1665 | PPCODE: | |
1666 | EXTEND(SP, 3); | |
1667 | mPUSHn(0.5); | |
1668 | mPUSHn(-0.25); | |
1669 | mPUSHn(0.125); | |
1670 | XSRETURN(3); | |
1671 | ||
1672 | void | |
1673 | mpushi() | |
1674 | PPCODE: | |
1675 | EXTEND(SP, 3); | |
d75b63cf MHM |
1676 | mPUSHi(-1); |
1677 | mPUSHi(2); | |
1678 | mPUSHi(-3); | |
d4b90eee SH |
1679 | XSRETURN(3); |
1680 | ||
1681 | void | |
1682 | mpushu() | |
1683 | PPCODE: | |
1684 | EXTEND(SP, 3); | |
d75b63cf MHM |
1685 | mPUSHu(1); |
1686 | mPUSHu(2); | |
1687 | mPUSHu(3); | |
d4b90eee SH |
1688 | XSRETURN(3); |
1689 | ||
1690 | void | |
1691 | mxpushp() | |
1692 | PPCODE: | |
1693 | mXPUSHp("one", 3); | |
1694 | mXPUSHp("two", 3); | |
1695 | mXPUSHp("three", 5); | |
1696 | XSRETURN(3); | |
1697 | ||
1698 | void | |
1699 | mxpushn() | |
1700 | PPCODE: | |
1701 | mXPUSHn(0.5); | |
1702 | mXPUSHn(-0.25); | |
1703 | mXPUSHn(0.125); | |
1704 | XSRETURN(3); | |
1705 | ||
1706 | void | |
1707 | mxpushi() | |
1708 | PPCODE: | |
d75b63cf MHM |
1709 | mXPUSHi(-1); |
1710 | mXPUSHi(2); | |
1711 | mXPUSHi(-3); | |
d4b90eee SH |
1712 | XSRETURN(3); |
1713 | ||
1714 | void | |
1715 | mxpushu() | |
1716 | PPCODE: | |
d75b63cf MHM |
1717 | mXPUSHu(1); |
1718 | mXPUSHu(2); | |
1719 | mXPUSHu(3); | |
d4b90eee | 1720 | XSRETURN(3); |
d1f347d7 DM |
1721 | |
1722 | ||
1723 | void | |
1724 | call_sv(sv, flags, ...) | |
1725 | SV* sv | |
1726 | I32 flags | |
1727 | PREINIT: | |
1728 | I32 i; | |
1729 | PPCODE: | |
1730 | for (i=0; i<items-2; i++) | |
1731 | ST(i) = ST(i+2); /* pop first two args */ | |
1732 | PUSHMARK(SP); | |
1733 | SP += items - 2; | |
1734 | PUTBACK; | |
1735 | i = call_sv(sv, flags); | |
1736 | SPAGAIN; | |
1737 | EXTEND(SP, 1); | |
1738 | PUSHs(sv_2mortal(newSViv(i))); | |
1739 | ||
1740 | void | |
1741 | call_pv(subname, flags, ...) | |
1742 | char* subname | |
1743 | I32 flags | |
1744 | PREINIT: | |
1745 | I32 i; | |
1746 | PPCODE: | |
1747 | for (i=0; i<items-2; i++) | |
1748 | ST(i) = ST(i+2); /* pop first two args */ | |
1749 | PUSHMARK(SP); | |
1750 | SP += items - 2; | |
1751 | PUTBACK; | |
1752 | i = call_pv(subname, flags); | |
1753 | SPAGAIN; | |
1754 | EXTEND(SP, 1); | |
1755 | PUSHs(sv_2mortal(newSViv(i))); | |
1756 | ||
1757 | void | |
1758 | call_method(methname, flags, ...) | |
1759 | char* methname | |
1760 | I32 flags | |
1761 | PREINIT: | |
1762 | I32 i; | |
1763 | PPCODE: | |
1764 | for (i=0; i<items-2; i++) | |
1765 | ST(i) = ST(i+2); /* pop first two args */ | |
1766 | PUSHMARK(SP); | |
1767 | SP += items - 2; | |
1768 | PUTBACK; | |
1769 | i = call_method(methname, flags); | |
1770 | SPAGAIN; | |
1771 | EXTEND(SP, 1); | |
1772 | PUSHs(sv_2mortal(newSViv(i))); | |
1773 | ||
1774 | void | |
1775 | eval_sv(sv, flags) | |
1776 | SV* sv | |
1777 | I32 flags | |
1778 | PREINIT: | |
1779 | I32 i; | |
1780 | PPCODE: | |
1781 | PUTBACK; | |
1782 | i = eval_sv(sv, flags); | |
1783 | SPAGAIN; | |
1784 | EXTEND(SP, 1); | |
1785 | PUSHs(sv_2mortal(newSViv(i))); | |
1786 | ||
b8e65a9b | 1787 | void |
d1f347d7 DM |
1788 | eval_pv(p, croak_on_error) |
1789 | const char* p | |
1790 | I32 croak_on_error | |
d1f347d7 DM |
1791 | PPCODE: |
1792 | PUTBACK; | |
1793 | EXTEND(SP, 1); | |
1794 | PUSHs(eval_pv(p, croak_on_error)); | |
1795 | ||
1796 | void | |
1797 | require_pv(pv) | |
1798 | const char* pv | |
d1f347d7 DM |
1799 | PPCODE: |
1800 | PUTBACK; | |
1801 | require_pv(pv); | |
1802 | ||
0ca3a874 | 1803 | int |
7a646707 | 1804 | apitest_exception(throw_e) |
0ca3a874 MHM |
1805 | int throw_e |
1806 | OUTPUT: | |
1807 | RETVAL | |
d1f347d7 | 1808 | |
ef469b03 | 1809 | void |
7e7a3dfc GA |
1810 | mycroak(sv) |
1811 | SV* sv | |
ef469b03 | 1812 | CODE: |
7e7a3dfc GA |
1813 | if (SvOK(sv)) { |
1814 | Perl_croak(aTHX_ "%s", SvPV_nolen(sv)); | |
1815 | } | |
1816 | else { | |
1817 | Perl_croak(aTHX_ NULL); | |
1818 | } | |
5d2b1485 NC |
1819 | |
1820 | SV* | |
1821 | strtab() | |
1822 | CODE: | |
1823 | RETVAL = newRV_inc((SV*)PL_strtab); | |
1824 | OUTPUT: | |
1825 | RETVAL | |
85ce96a1 DM |
1826 | |
1827 | int | |
1828 | my_cxt_getint() | |
1829 | CODE: | |
1830 | dMY_CXT; | |
1831 | RETVAL = my_cxt_getint_p(aMY_CXT); | |
1832 | OUTPUT: | |
1833 | RETVAL | |
1834 | ||
1835 | void | |
1836 | my_cxt_setint(i) | |
1837 | int i; | |
1838 | CODE: | |
1839 | dMY_CXT; | |
1840 | my_cxt_setint_p(aMY_CXT_ i); | |
1841 | ||
1842 | void | |
9568a123 NC |
1843 | my_cxt_getsv(how) |
1844 | bool how; | |
85ce96a1 | 1845 | PPCODE: |
85ce96a1 | 1846 | EXTEND(SP, 1); |
9568a123 | 1847 | ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp(); |
85ce96a1 DM |
1848 | XSRETURN(1); |
1849 | ||
1850 | void | |
1851 | my_cxt_setsv(sv) | |
1852 | SV *sv; | |
1853 | CODE: | |
1854 | dMY_CXT; | |
1855 | SvREFCNT_dec(MY_CXT.sv); | |
1856 | my_cxt_setsv_p(sv _aMY_CXT); | |
1857 | SvREFCNT_inc(sv); | |
34482cd6 NC |
1858 | |
1859 | bool | |
1860 | sv_setsv_cow_hashkey_core() | |
1861 | ||
1862 | bool | |
1863 | sv_setsv_cow_hashkey_notcore() | |
84ac5fd7 NC |
1864 | |
1865 | void | |
218787bd VP |
1866 | rmagical_cast(sv, type) |
1867 | SV *sv; | |
1868 | SV *type; | |
1869 | PREINIT: | |
1870 | struct ufuncs uf; | |
1871 | PPCODE: | |
1872 | if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; } | |
1873 | sv = SvRV(sv); | |
1874 | if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; } | |
1875 | uf.uf_val = rmagical_a_dummy; | |
1876 | uf.uf_set = NULL; | |
1877 | uf.uf_index = 0; | |
1878 | if (SvTRUE(type)) { /* b */ | |
1879 | sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0); | |
1880 | } else { /* a */ | |
1881 | sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf)); | |
1882 | } | |
1883 | XSRETURN_YES; | |
1884 | ||
1885 | void | |
1886 | rmagical_flags(sv) | |
1887 | SV *sv; | |
1888 | PPCODE: | |
1889 | if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; } | |
1890 | sv = SvRV(sv); | |
1891 | EXTEND(SP, 3); | |
1892 | mXPUSHu(SvFLAGS(sv) & SVs_GMG); | |
1893 | mXPUSHu(SvFLAGS(sv) & SVs_SMG); | |
1894 | mXPUSHu(SvFLAGS(sv) & SVs_RMG); | |
1895 | XSRETURN(3); | |
1896 | ||
1897 | void | |
90d1f214 BM |
1898 | my_caller(level) |
1899 | I32 level | |
1900 | PREINIT: | |
1901 | const PERL_CONTEXT *cx, *dbcx; | |
1902 | const char *pv; | |
1903 | const GV *gv; | |
1904 | HV *hv; | |
1905 | PPCODE: | |
1906 | cx = caller_cx(level, &dbcx); | |
1907 | EXTEND(SP, 8); | |
1908 | ||
1909 | pv = CopSTASHPV(cx->blk_oldcop); | |
1910 | ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef; | |
1911 | gv = CvGV(cx->blk_sub.cv); | |
1912 | ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef; | |
1913 | ||
1914 | pv = CopSTASHPV(dbcx->blk_oldcop); | |
1915 | ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef; | |
1916 | gv = CvGV(dbcx->blk_sub.cv); | |
1917 | ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef; | |
1918 | ||
20439bc7 Z |
1919 | ST(4) = cop_hints_fetch_pvs(cx->blk_oldcop, "foo", 0); |
1920 | ST(5) = cop_hints_fetch_pvn(cx->blk_oldcop, "foo", 3, 0, 0); | |
1921 | ST(6) = cop_hints_fetch_sv(cx->blk_oldcop, | |
1922 | sv_2mortal(newSVpvn("foo", 3)), 0, 0); | |
90d1f214 | 1923 | |
20439bc7 | 1924 | hv = cop_hints_2hv(cx->blk_oldcop, 0); |
90d1f214 BM |
1925 | ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef; |
1926 | ||
1927 | XSRETURN(8); | |
1928 | ||
1929 | void | |
f9c17636 MB |
1930 | DPeek (sv) |
1931 | SV *sv | |
1932 | ||
1933 | PPCODE: | |
5b1f7359 | 1934 | ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0); |
f9c17636 MB |
1935 | XSRETURN (1); |
1936 | ||
1937 | void | |
84ac5fd7 NC |
1938 | BEGIN() |
1939 | CODE: | |
1940 | sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI)); | |
1941 | ||
1942 | void | |
1943 | CHECK() | |
1944 | CODE: | |
1945 | sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI)); | |
1946 | ||
1947 | void | |
1948 | UNITCHECK() | |
1949 | CODE: | |
0932863f | 1950 | sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI)); |
84ac5fd7 NC |
1951 | |
1952 | void | |
1953 | INIT() | |
1954 | CODE: | |
1955 | sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI)); | |
1956 | ||
1957 | void | |
1958 | END() | |
1959 | CODE: | |
1960 | sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI)); | |
30685b56 NC |
1961 | |
1962 | void | |
1963 | utf16_to_utf8 (sv, ...) | |
1964 | SV* sv | |
1965 | ALIAS: | |
1966 | utf16_to_utf8_reversed = 1 | |
1967 | PREINIT: | |
1968 | STRLEN len; | |
1969 | U8 *source; | |
1970 | SV *dest; | |
1971 | I32 got; /* Gah, badly thought out APIs */ | |
1972 | CODE: | |
1973 | source = (U8 *)SvPVbyte(sv, len); | |
1974 | /* Optionally only convert part of the buffer. */ | |
1975 | if (items > 1) { | |
1976 | len = SvUV(ST(1)); | |
1977 | } | |
1978 | /* Mortalise this right now, as we'll be testing croak()s */ | |
1979 | dest = sv_2mortal(newSV(len * 3 / 2 + 1)); | |
1980 | if (ix) { | |
25f2e844 | 1981 | utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got); |
30685b56 | 1982 | } else { |
25f2e844 | 1983 | utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got); |
30685b56 NC |
1984 | } |
1985 | SvCUR_set(dest, got); | |
1986 | SvPVX(dest)[got] = '\0'; | |
1987 | SvPOK_on(dest); | |
1988 | ST(0) = dest; | |
1989 | XSRETURN(1); | |
879d0c72 | 1990 | |
6bd7445c GG |
1991 | void |
1992 | my_exit(int exitcode) | |
1993 | PPCODE: | |
1994 | my_exit(exitcode); | |
d97c33b5 | 1995 | |
209e41dc NT |
1996 | U8 |
1997 | first_byte(sv) | |
1998 | SV *sv | |
1999 | CODE: | |
2000 | char *s; | |
2001 | STRLEN len; | |
2002 | s = SvPVbyte(sv, len); | |
2003 | RETVAL = s[0]; | |
2004 | OUTPUT: | |
2005 | RETVAL | |
2006 | ||
d97c33b5 DM |
2007 | I32 |
2008 | sv_count() | |
2009 | CODE: | |
2010 | RETVAL = PL_sv_count; | |
2011 | OUTPUT: | |
2012 | RETVAL | |
13b6b3bc BM |
2013 | |
2014 | void | |
2015 | bhk_record(bool on) | |
2016 | CODE: | |
2017 | dMY_CXT; | |
2018 | MY_CXT.bhk_record = on; | |
2019 | if (on) | |
2020 | av_clear(MY_CXT.bhkav); | |
65bfe90c | 2021 | |
defdfed5 | 2022 | void |
d9088386 Z |
2023 | test_magic_chain() |
2024 | PREINIT: | |
2025 | SV *sv; | |
2026 | MAGIC *callmg, *uvarmg; | |
2027 | CODE: | |
2028 | sv = sv_2mortal(newSV(0)); | |
11f9f0ed NC |
2029 | if (SvTYPE(sv) >= SVt_PVMG) croak_fail(); |
2030 | if (SvMAGICAL(sv)) croak_fail(); | |
d9088386 | 2031 | sv_magic(sv, &PL_sv_yes, PERL_MAGIC_checkcall, (char*)&callmg, 0); |
11f9f0ed NC |
2032 | if (SvTYPE(sv) < SVt_PVMG) croak_fail(); |
2033 | if (!SvMAGICAL(sv)) croak_fail(); | |
2034 | if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail(); | |
d9088386 | 2035 | callmg = mg_find(sv, PERL_MAGIC_checkcall); |
11f9f0ed | 2036 | if (!callmg) croak_fail(); |
d9088386 | 2037 | if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg) |
11f9f0ed | 2038 | croak_fail(); |
d9088386 | 2039 | sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0); |
11f9f0ed NC |
2040 | if (SvTYPE(sv) < SVt_PVMG) croak_fail(); |
2041 | if (!SvMAGICAL(sv)) croak_fail(); | |
2042 | if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail(); | |
d9088386 | 2043 | uvarmg = mg_find(sv, PERL_MAGIC_uvar); |
11f9f0ed | 2044 | if (!uvarmg) croak_fail(); |
d9088386 | 2045 | if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg) |
11f9f0ed | 2046 | croak_fail(); |
d9088386 | 2047 | if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg) |
11f9f0ed | 2048 | croak_fail(); |
d9088386 | 2049 | mg_free_type(sv, PERL_MAGIC_vec); |
11f9f0ed NC |
2050 | if (SvTYPE(sv) < SVt_PVMG) croak_fail(); |
2051 | if (!SvMAGICAL(sv)) croak_fail(); | |
2052 | if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail(); | |
2053 | if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail(); | |
d9088386 | 2054 | if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg) |
11f9f0ed | 2055 | croak_fail(); |
d9088386 | 2056 | if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg) |
11f9f0ed | 2057 | croak_fail(); |
d9088386 | 2058 | mg_free_type(sv, PERL_MAGIC_uvar); |
11f9f0ed NC |
2059 | if (SvTYPE(sv) < SVt_PVMG) croak_fail(); |
2060 | if (!SvMAGICAL(sv)) croak_fail(); | |
2061 | if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail(); | |
2062 | if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail(); | |
d9088386 | 2063 | if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg) |
11f9f0ed | 2064 | croak_fail(); |
d9088386 | 2065 | sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0); |
11f9f0ed NC |
2066 | if (SvTYPE(sv) < SVt_PVMG) croak_fail(); |
2067 | if (!SvMAGICAL(sv)) croak_fail(); | |
2068 | if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail(); | |
d9088386 | 2069 | uvarmg = mg_find(sv, PERL_MAGIC_uvar); |
11f9f0ed | 2070 | if (!uvarmg) croak_fail(); |
d9088386 | 2071 | if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg) |
11f9f0ed | 2072 | croak_fail(); |
d9088386 | 2073 | if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg) |
11f9f0ed | 2074 | croak_fail(); |
d9088386 | 2075 | mg_free_type(sv, PERL_MAGIC_checkcall); |
11f9f0ed NC |
2076 | if (SvTYPE(sv) < SVt_PVMG) croak_fail(); |
2077 | if (!SvMAGICAL(sv)) croak_fail(); | |
2078 | if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail(); | |
2079 | if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail(); | |
d9088386 | 2080 | if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg) |
11f9f0ed | 2081 | croak_fail(); |
d9088386 | 2082 | mg_free_type(sv, PERL_MAGIC_uvar); |
11f9f0ed NC |
2083 | if (SvMAGICAL(sv)) croak_fail(); |
2084 | if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail(); | |
2085 | if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail(); | |
d9088386 Z |
2086 | |
2087 | void | |
2088 | test_op_contextualize() | |
2089 | PREINIT: | |
2090 | OP *o; | |
2091 | CODE: | |
2092 | o = newSVOP(OP_CONST, 0, newSViv(0)); | |
2093 | o->op_flags &= ~OPf_WANT; | |
2094 | o = op_contextualize(o, G_SCALAR); | |
2095 | if (o->op_type != OP_CONST || | |
2096 | (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR) | |
11f9f0ed | 2097 | croak_fail(); |
d9088386 Z |
2098 | op_free(o); |
2099 | o = newSVOP(OP_CONST, 0, newSViv(0)); | |
2100 | o->op_flags &= ~OPf_WANT; | |
2101 | o = op_contextualize(o, G_ARRAY); | |
2102 | if (o->op_type != OP_CONST || | |
2103 | (o->op_flags & OPf_WANT) != OPf_WANT_LIST) | |
11f9f0ed | 2104 | croak_fail(); |
d9088386 Z |
2105 | op_free(o); |
2106 | o = newSVOP(OP_CONST, 0, newSViv(0)); | |
2107 | o->op_flags &= ~OPf_WANT; | |
2108 | o = op_contextualize(o, G_VOID); | |
11f9f0ed | 2109 | if (o->op_type != OP_NULL) croak_fail(); |
d9088386 Z |
2110 | op_free(o); |
2111 | ||
2112 | void | |
2113 | test_rv2cv_op_cv() | |
2114 | PROTOTYPE: | |
2115 | PREINIT: | |
2116 | GV *troc_gv, *wibble_gv; | |
2117 | CV *troc_cv; | |
2118 | OP *o; | |
2119 | CODE: | |
2120 | troc_gv = gv_fetchpv("XS::APItest::test_rv2cv_op_cv", 0, SVt_PVGV); | |
2121 | troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0); | |
2122 | wibble_gv = gv_fetchpv("XS::APItest::wibble", 0, SVt_PVGV); | |
2123 | o = newCVREF(0, newGVOP(OP_GV, 0, troc_gv)); | |
11f9f0ed | 2124 | if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail(); |
d9088386 | 2125 | if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv) |
11f9f0ed | 2126 | croak_fail(); |
d9088386 | 2127 | o->op_private |= OPpENTERSUB_AMPER; |
11f9f0ed NC |
2128 | if (rv2cv_op_cv(o, 0)) croak_fail(); |
2129 | if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail(); | |
d9088386 | 2130 | o->op_private &= ~OPpENTERSUB_AMPER; |
11f9f0ed NC |
2131 | if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail(); |
2132 | if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail(); | |
2133 | if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail(); | |
d9088386 Z |
2134 | op_free(o); |
2135 | o = newSVOP(OP_CONST, 0, newSVpv("XS::APItest::test_rv2cv_op_cv", 0)); | |
2136 | o->op_private = OPpCONST_BARE; | |
2137 | o = newCVREF(0, o); | |
11f9f0ed | 2138 | if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail(); |
d9088386 | 2139 | if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv) |
11f9f0ed | 2140 | croak_fail(); |
d9088386 | 2141 | o->op_private |= OPpENTERSUB_AMPER; |
11f9f0ed NC |
2142 | if (rv2cv_op_cv(o, 0)) croak_fail(); |
2143 | if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail(); | |
d9088386 Z |
2144 | op_free(o); |
2145 | o = newCVREF(0, newSVOP(OP_CONST, 0, newRV_inc((SV*)troc_cv))); | |
11f9f0ed | 2146 | if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail(); |
d9088386 | 2147 | if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv) |
11f9f0ed | 2148 | croak_fail(); |
d9088386 | 2149 | o->op_private |= OPpENTERSUB_AMPER; |
11f9f0ed NC |
2150 | if (rv2cv_op_cv(o, 0)) croak_fail(); |
2151 | if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail(); | |
d9088386 | 2152 | o->op_private &= ~OPpENTERSUB_AMPER; |
11f9f0ed NC |
2153 | if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail(); |
2154 | if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail(); | |
2155 | if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail(); | |
d9088386 Z |
2156 | op_free(o); |
2157 | o = newCVREF(0, newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0)))); | |
11f9f0ed NC |
2158 | if (rv2cv_op_cv(o, 0)) croak_fail(); |
2159 | if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail(); | |
d9088386 | 2160 | o->op_private |= OPpENTERSUB_AMPER; |
11f9f0ed NC |
2161 | if (rv2cv_op_cv(o, 0)) croak_fail(); |
2162 | if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail(); | |
d9088386 | 2163 | o->op_private &= ~OPpENTERSUB_AMPER; |
11f9f0ed NC |
2164 | if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail(); |
2165 | if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY)) croak_fail(); | |
2166 | if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail(); | |
d9088386 Z |
2167 | op_free(o); |
2168 | o = newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0))); | |
11f9f0ed NC |
2169 | if (rv2cv_op_cv(o, 0)) croak_fail(); |
2170 | if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail(); | |
d9088386 Z |
2171 | op_free(o); |
2172 | ||
2173 | void | |
2174 | test_cv_getset_call_checker() | |
2175 | PREINIT: | |
2176 | CV *troc_cv, *tsh_cv; | |
2177 | Perl_call_checker ckfun; | |
2178 | SV *ckobj; | |
2179 | CODE: | |
2180 | #define check_cc(cv, xckfun, xckobj) \ | |
2181 | do { \ | |
2182 | cv_get_call_checker((cv), &ckfun, &ckobj); \ | |
779bc08a NC |
2183 | if (ckfun != (xckfun)) croak_fail_ne(FPTR2DPTR(void *, ckfun), xckfun); \ |
2184 | if (ckobj != (xckobj)) croak_fail_ne(FPTR2DPTR(void *, ckobj), xckobj); \ | |
d9088386 Z |
2185 | } while(0) |
2186 | troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0); | |
2187 | tsh_cv = get_cv("XS::APItest::test_savehints", 0); | |
2188 | check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv); | |
2189 | check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv); | |
2190 | cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list, | |
2191 | &PL_sv_yes); | |
2192 | check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv); | |
2193 | check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes); | |
2194 | cv_set_call_checker(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no); | |
2195 | check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no); | |
2196 | check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes); | |
2197 | cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list, | |
2198 | (SV*)tsh_cv); | |
2199 | check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no); | |
2200 | check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv); | |
2201 | cv_set_call_checker(troc_cv, Perl_ck_entersub_args_proto_or_list, | |
2202 | (SV*)troc_cv); | |
2203 | check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv); | |
2204 | check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv); | |
11f9f0ed NC |
2205 | if (SvMAGICAL((SV*)troc_cv) || SvMAGIC((SV*)troc_cv)) croak_fail(); |
2206 | if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail(); | |
d9088386 Z |
2207 | #undef check_cc |
2208 | ||
2209 | void | |
2210 | cv_set_call_checker_lists(CV *cv) | |
2211 | CODE: | |
2212 | cv_set_call_checker(cv, THX_ck_entersub_args_lists, &PL_sv_undef); | |
2213 | ||
2214 | void | |
2215 | cv_set_call_checker_scalars(CV *cv) | |
2216 | CODE: | |
2217 | cv_set_call_checker(cv, THX_ck_entersub_args_scalars, &PL_sv_undef); | |
2218 | ||
2219 | void | |
2220 | cv_set_call_checker_proto(CV *cv, SV *proto) | |
2221 | CODE: | |
2222 | if (SvROK(proto)) | |
2223 | proto = SvRV(proto); | |
2224 | cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto); | |
2225 | ||
2226 | void | |
2227 | cv_set_call_checker_proto_or_list(CV *cv, SV *proto) | |
2228 | CODE: | |
2229 | if (SvROK(proto)) | |
2230 | proto = SvRV(proto); | |
2231 | cv_set_call_checker(cv, Perl_ck_entersub_args_proto_or_list, proto); | |
2232 | ||
2233 | void | |
2234 | cv_set_call_checker_multi_sum(CV *cv) | |
2235 | CODE: | |
2236 | cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef); | |
2237 | ||
2238 | void | |
20439bc7 Z |
2239 | test_cophh() |
2240 | PREINIT: | |
2241 | COPHH *a, *b; | |
2242 | CODE: | |
2243 | #define check_ph(EXPR) \ | |
2244 | do { if((EXPR) != &PL_sv_placeholder) croak("fail"); } while(0) | |
2245 | #define check_iv(EXPR, EXPECT) \ | |
2246 | do { if(SvIV(EXPR) != (EXPECT)) croak("fail"); } while(0) | |
2247 | #define msvpvs(STR) sv_2mortal(newSVpvs(STR)) | |
2248 | #define msviv(VALUE) sv_2mortal(newSViv(VALUE)) | |
2249 | a = cophh_new_empty(); | |
2250 | check_ph(cophh_fetch_pvn(a, "foo_1", 5, 0, 0)); | |
2251 | check_ph(cophh_fetch_pvs(a, "foo_1", 0)); | |
2252 | check_ph(cophh_fetch_pv(a, "foo_1", 0, 0)); | |
2253 | check_ph(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0)); | |
2254 | a = cophh_store_pvn(a, "foo_1abc", 5, 0, msviv(111), 0); | |
2255 | a = cophh_store_pvs(a, "foo_2", msviv(222), 0); | |
2256 | a = cophh_store_pv(a, "foo_3", 0, msviv(333), 0); | |
2257 | a = cophh_store_sv(a, msvpvs("foo_4"), 0, msviv(444), 0); | |
2258 | check_iv(cophh_fetch_pvn(a, "foo_1xyz", 5, 0, 0), 111); | |
2259 | check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111); | |
2260 | check_iv(cophh_fetch_pv(a, "foo_1", 0, 0), 111); | |
2261 | check_iv(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0), 111); | |
2262 | check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222); | |
2263 | check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333); | |
2264 | check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444); | |
2265 | check_ph(cophh_fetch_pvs(a, "foo_5", 0)); | |
2266 | b = cophh_copy(a); | |
2267 | b = cophh_store_pvs(b, "foo_1", msviv(1111), 0); | |
2268 | check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111); | |
2269 | check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222); | |
2270 | check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333); | |
2271 | check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444); | |
2272 | check_ph(cophh_fetch_pvs(a, "foo_5", 0)); | |
2273 | check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111); | |
2274 | check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222); | |
2275 | check_iv(cophh_fetch_pvs(b, "foo_3", 0), 333); | |
2276 | check_iv(cophh_fetch_pvs(b, "foo_4", 0), 444); | |
2277 | check_ph(cophh_fetch_pvs(b, "foo_5", 0)); | |
2278 | a = cophh_delete_pvn(a, "foo_1abc", 5, 0, 0); | |
2279 | a = cophh_delete_pvs(a, "foo_2", 0); | |
2280 | b = cophh_delete_pv(b, "foo_3", 0, 0); | |
2281 | b = cophh_delete_sv(b, msvpvs("foo_4"), 0, 0); | |
2282 | check_ph(cophh_fetch_pvs(a, "foo_1", 0)); | |
2283 | check_ph(cophh_fetch_pvs(a, "foo_2", 0)); | |
2284 | check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333); | |
2285 | check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444); | |
2286 | check_ph(cophh_fetch_pvs(a, "foo_5", 0)); | |
2287 | check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111); | |
2288 | check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222); | |
2289 | check_ph(cophh_fetch_pvs(b, "foo_3", 0)); | |
2290 | check_ph(cophh_fetch_pvs(b, "foo_4", 0)); | |
2291 | check_ph(cophh_fetch_pvs(b, "foo_5", 0)); | |
2292 | b = cophh_delete_pvs(b, "foo_3", 0); | |
2293 | b = cophh_delete_pvs(b, "foo_5", 0); | |
2294 | check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111); | |
2295 | check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222); | |
2296 | check_ph(cophh_fetch_pvs(b, "foo_3", 0)); | |
2297 | check_ph(cophh_fetch_pvs(b, "foo_4", 0)); | |
2298 | check_ph(cophh_fetch_pvs(b, "foo_5", 0)); | |
2299 | cophh_free(b); | |
2300 | check_ph(cophh_fetch_pvs(a, "foo_1", 0)); | |
2301 | check_ph(cophh_fetch_pvs(a, "foo_2", 0)); | |
2302 | check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333); | |
2303 | check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444); | |
2304 | check_ph(cophh_fetch_pvs(a, "foo_5", 0)); | |
2305 | a = cophh_store_pvs(a, "foo_1", msviv(11111), COPHH_KEY_UTF8); | |
2306 | a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0); | |
2307 | a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8); | |
2308 | a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8); | |
2309 | a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8); | |
2310 | check_iv(cophh_fetch_pvs(a, "foo_1", 0), 11111); | |
2311 | check_iv(cophh_fetch_pvs(a, "foo_1", COPHH_KEY_UTF8), 11111); | |
2312 | check_iv(cophh_fetch_pvs(a, "foo_\xaa", 0), 123); | |
2313 | check_iv(cophh_fetch_pvs(a, "foo_\xc2\xaa", COPHH_KEY_UTF8), 123); | |
2314 | check_ph(cophh_fetch_pvs(a, "foo_\xc2\xaa", 0)); | |
2315 | check_iv(cophh_fetch_pvs(a, "foo_\xbb", 0), 456); | |
2316 | check_iv(cophh_fetch_pvs(a, "foo_\xc2\xbb", COPHH_KEY_UTF8), 456); | |
2317 | check_ph(cophh_fetch_pvs(a, "foo_\xc2\xbb", 0)); | |
2318 | check_iv(cophh_fetch_pvs(a, "foo_\xcc", 0), 789); | |
2319 | check_iv(cophh_fetch_pvs(a, "foo_\xc3\x8c", COPHH_KEY_UTF8), 789); | |
2320 | check_ph(cophh_fetch_pvs(a, "foo_\xc2\x8c", 0)); | |
2321 | check_iv(cophh_fetch_pvs(a, "foo_\xd9\xa6", COPHH_KEY_UTF8), 666); | |
2322 | check_ph(cophh_fetch_pvs(a, "foo_\xd9\xa6", 0)); | |
3987a177 Z |
2323 | ENTER; |
2324 | SAVEFREECOPHH(a); | |
2325 | LEAVE; | |
20439bc7 Z |
2326 | #undef check_ph |
2327 | #undef check_iv | |
2328 | #undef msvpvs | |
2329 | #undef msviv | |
2330 | ||
2331 | HV * | |
2332 | example_cophh_2hv() | |
2333 | PREINIT: | |
2334 | COPHH *a; | |
2335 | CODE: | |
2336 | #define msviv(VALUE) sv_2mortal(newSViv(VALUE)) | |
2337 | a = cophh_new_empty(); | |
2338 | a = cophh_store_pvs(a, "foo_0", msviv(999), 0); | |
2339 | a = cophh_store_pvs(a, "foo_1", msviv(111), 0); | |
2340 | a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0); | |
2341 | a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8); | |
2342 | a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8); | |
2343 | a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8); | |
2344 | a = cophh_delete_pvs(a, "foo_0", 0); | |
2345 | a = cophh_delete_pvs(a, "foo_2", 0); | |
2346 | RETVAL = cophh_2hv(a, 0); | |
2347 | cophh_free(a); | |
2348 | #undef msviv | |
2349 | OUTPUT: | |
2350 | RETVAL | |
2351 | ||
2352 | void | |
defdfed5 Z |
2353 | test_savehints() |
2354 | PREINIT: | |
2355 | SV **svp, *sv; | |
2356 | CODE: | |
2357 | #define store_hint(KEY, VALUE) \ | |
2358 | sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE)) | |
2359 | #define hint_ok(KEY, EXPECT) \ | |
2360 | ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \ | |
2361 | (sv = *svp) && SvIV(sv) == (EXPECT) && \ | |
20439bc7 | 2362 | (sv = cop_hints_fetch_pvs(&PL_compiling, KEY, 0)) && \ |
defdfed5 Z |
2363 | SvIV(sv) == (EXPECT)) |
2364 | #define check_hint(KEY, EXPECT) \ | |
11f9f0ed | 2365 | do { if (!hint_ok(KEY, EXPECT)) croak_fail(); } while(0) |
defdfed5 Z |
2366 | PL_hints |= HINT_LOCALIZE_HH; |
2367 | ENTER; | |
2368 | SAVEHINTS(); | |
2369 | PL_hints &= HINT_INTEGER; | |
2370 | store_hint("t0", 123); | |
2371 | store_hint("t1", 456); | |
11f9f0ed | 2372 | if (PL_hints & HINT_INTEGER) croak_fail(); |
defdfed5 Z |
2373 | check_hint("t0", 123); check_hint("t1", 456); |
2374 | ENTER; | |
2375 | SAVEHINTS(); | |
11f9f0ed | 2376 | if (PL_hints & HINT_INTEGER) croak_fail(); |
defdfed5 Z |
2377 | check_hint("t0", 123); check_hint("t1", 456); |
2378 | PL_hints |= HINT_INTEGER; | |
2379 | store_hint("t0", 321); | |
11f9f0ed | 2380 | if (!(PL_hints & HINT_INTEGER)) croak_fail(); |
defdfed5 Z |
2381 | check_hint("t0", 321); check_hint("t1", 456); |
2382 | LEAVE; | |
11f9f0ed | 2383 | if (PL_hints & HINT_INTEGER) croak_fail(); |
defdfed5 Z |
2384 | check_hint("t0", 123); check_hint("t1", 456); |
2385 | ENTER; | |
2386 | SAVEHINTS(); | |
11f9f0ed | 2387 | if (PL_hints & HINT_INTEGER) croak_fail(); |
defdfed5 Z |
2388 | check_hint("t0", 123); check_hint("t1", 456); |
2389 | store_hint("t1", 654); | |
11f9f0ed | 2390 | if (PL_hints & HINT_INTEGER) croak_fail(); |
defdfed5 Z |
2391 | check_hint("t0", 123); check_hint("t1", 654); |
2392 | LEAVE; | |
11f9f0ed | 2393 | if (PL_hints & HINT_INTEGER) croak_fail(); |
defdfed5 Z |
2394 | check_hint("t0", 123); check_hint("t1", 456); |
2395 | LEAVE; | |
2396 | #undef store_hint | |
2397 | #undef hint_ok | |
2398 | #undef check_hint | |
2399 | ||
2400 | void | |
2401 | test_copyhints() | |
2402 | PREINIT: | |
2403 | HV *a, *b; | |
2404 | CODE: | |
2405 | PL_hints |= HINT_LOCALIZE_HH; | |
2406 | ENTER; | |
2407 | SAVEHINTS(); | |
2408 | sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123); | |
20439bc7 Z |
2409 | if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123) |
2410 | croak_fail(); | |
defdfed5 Z |
2411 | a = newHVhv(GvHV(PL_hintgv)); |
2412 | sv_2mortal((SV*)a); | |
2413 | sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456); | |
20439bc7 Z |
2414 | if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123) |
2415 | croak_fail(); | |
defdfed5 Z |
2416 | b = hv_copy_hints_hv(a); |
2417 | sv_2mortal((SV*)b); | |
2418 | sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789); | |
20439bc7 Z |
2419 | if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 789) |
2420 | croak_fail(); | |
defdfed5 Z |
2421 | LEAVE; |
2422 | ||
201c7e1f | 2423 | void |
2fcb4757 Z |
2424 | test_op_list() |
2425 | PREINIT: | |
2426 | OP *a; | |
2427 | CODE: | |
2428 | #define iv_op(iv) newSVOP(OP_CONST, 0, newSViv(iv)) | |
2429 | #define check_op(o, expect) \ | |
2430 | do { \ | |
2431 | if (strcmp(test_op_list_describe(o), (expect))) \ | |
2432 | croak("fail %s %s", test_op_list_describe(o), (expect)); \ | |
2433 | } while(0) | |
2434 | a = op_append_elem(OP_LIST, NULL, NULL); | |
2435 | check_op(a, ""); | |
2436 | a = op_append_elem(OP_LIST, iv_op(1), a); | |
2437 | check_op(a, "const(1)."); | |
2438 | a = op_append_elem(OP_LIST, NULL, a); | |
2439 | check_op(a, "const(1)."); | |
2440 | a = op_append_elem(OP_LIST, a, iv_op(2)); | |
2441 | check_op(a, "list[pushmark.const(1).const(2).]"); | |
2442 | a = op_append_elem(OP_LIST, a, iv_op(3)); | |
2443 | check_op(a, "list[pushmark.const(1).const(2).const(3).]"); | |
2444 | a = op_append_elem(OP_LIST, a, NULL); | |
2445 | check_op(a, "list[pushmark.const(1).const(2).const(3).]"); | |
2446 | a = op_append_elem(OP_LIST, NULL, a); | |
2447 | check_op(a, "list[pushmark.const(1).const(2).const(3).]"); | |
2448 | a = op_append_elem(OP_LIST, iv_op(4), a); | |
2449 | check_op(a, "list[pushmark.const(4)." | |
2450 | "list[pushmark.const(1).const(2).const(3).]]"); | |
2451 | a = op_append_elem(OP_LIST, a, iv_op(5)); | |
2452 | check_op(a, "list[pushmark.const(4)." | |
2453 | "list[pushmark.const(1).const(2).const(3).]const(5).]"); | |
2454 | a = op_append_elem(OP_LIST, a, | |
2455 | op_append_elem(OP_LIST, iv_op(7), iv_op(6))); | |
2456 | check_op(a, "list[pushmark.const(4)." | |
2457 | "list[pushmark.const(1).const(2).const(3).]const(5)." | |
2458 | "list[pushmark.const(7).const(6).]]"); | |
2459 | op_free(a); | |
2460 | a = op_append_elem(OP_LINESEQ, iv_op(1), iv_op(2)); | |
2461 | check_op(a, "lineseq[const(1).const(2).]"); | |
2462 | a = op_append_elem(OP_LINESEQ, a, iv_op(3)); | |
2463 | check_op(a, "lineseq[const(1).const(2).const(3).]"); | |
2464 | op_free(a); | |
2465 | a = op_append_elem(OP_LINESEQ, | |
2466 | op_append_elem(OP_LIST, iv_op(1), iv_op(2)), | |
2467 | iv_op(3)); | |
2468 | check_op(a, "lineseq[list[pushmark.const(1).const(2).]const(3).]"); | |
2469 | op_free(a); | |
2470 | a = op_prepend_elem(OP_LIST, NULL, NULL); | |
2471 | check_op(a, ""); | |
2472 | a = op_prepend_elem(OP_LIST, a, iv_op(1)); | |
2473 | check_op(a, "const(1)."); | |
2474 | a = op_prepend_elem(OP_LIST, a, NULL); | |
2475 | check_op(a, "const(1)."); | |
2476 | a = op_prepend_elem(OP_LIST, iv_op(2), a); | |
2477 | check_op(a, "list[pushmark.const(2).const(1).]"); | |
2478 | a = op_prepend_elem(OP_LIST, iv_op(3), a); | |
2479 | check_op(a, "list[pushmark.const(3).const(2).const(1).]"); | |
2480 | a = op_prepend_elem(OP_LIST, NULL, a); | |
2481 | check_op(a, "list[pushmark.const(3).const(2).const(1).]"); | |
2482 | a = op_prepend_elem(OP_LIST, a, NULL); | |
2483 | check_op(a, "list[pushmark.const(3).const(2).const(1).]"); | |
2484 | a = op_prepend_elem(OP_LIST, a, iv_op(4)); | |
2485 | check_op(a, "list[pushmark." | |
2486 | "list[pushmark.const(3).const(2).const(1).]const(4).]"); | |
2487 | a = op_prepend_elem(OP_LIST, iv_op(5), a); | |
2488 | check_op(a, "list[pushmark.const(5)." | |
2489 | "list[pushmark.const(3).const(2).const(1).]const(4).]"); | |
2490 | a = op_prepend_elem(OP_LIST, | |
2491 | op_prepend_elem(OP_LIST, iv_op(6), iv_op(7)), a); | |
2492 | check_op(a, "list[pushmark.list[pushmark.const(6).const(7).]const(5)." | |
2493 | "list[pushmark.const(3).const(2).const(1).]const(4).]"); | |
2494 | op_free(a); | |
2495 | a = op_prepend_elem(OP_LINESEQ, iv_op(2), iv_op(1)); | |
2496 | check_op(a, "lineseq[const(2).const(1).]"); | |
2497 | a = op_prepend_elem(OP_LINESEQ, iv_op(3), a); | |
2498 | check_op(a, "lineseq[const(3).const(2).const(1).]"); | |
2499 | op_free(a); | |
2500 | a = op_prepend_elem(OP_LINESEQ, iv_op(3), | |
2501 | op_prepend_elem(OP_LIST, iv_op(2), iv_op(1))); | |
2502 | check_op(a, "lineseq[const(3).list[pushmark.const(2).const(1).]]"); | |
2503 | op_free(a); | |
2504 | a = op_append_list(OP_LINESEQ, NULL, NULL); | |
2505 | check_op(a, ""); | |
2506 | a = op_append_list(OP_LINESEQ, iv_op(1), a); | |
2507 | check_op(a, "const(1)."); | |
2508 | a = op_append_list(OP_LINESEQ, NULL, a); | |
2509 | check_op(a, "const(1)."); | |
2510 | a = op_append_list(OP_LINESEQ, a, iv_op(2)); | |
2511 | check_op(a, "lineseq[const(1).const(2).]"); | |
2512 | a = op_append_list(OP_LINESEQ, a, iv_op(3)); | |
2513 | check_op(a, "lineseq[const(1).const(2).const(3).]"); | |
2514 | a = op_append_list(OP_LINESEQ, iv_op(4), a); | |
2515 | check_op(a, "lineseq[const(4).const(1).const(2).const(3).]"); | |
2516 | a = op_append_list(OP_LINESEQ, a, NULL); | |
2517 | check_op(a, "lineseq[const(4).const(1).const(2).const(3).]"); | |
2518 | a = op_append_list(OP_LINESEQ, NULL, a); | |
2519 | check_op(a, "lineseq[const(4).const(1).const(2).const(3).]"); | |
2520 | a = op_append_list(OP_LINESEQ, a, | |
2521 | op_append_list(OP_LINESEQ, iv_op(5), iv_op(6))); | |
2522 | check_op(a, "lineseq[const(4).const(1).const(2).const(3)." | |
2523 | "const(5).const(6).]"); | |
2524 | op_free(a); | |
2525 | a = op_append_list(OP_LINESEQ, | |
2526 | op_append_list(OP_LINESEQ, iv_op(1), iv_op(2)), | |
2527 | op_append_list(OP_LIST, iv_op(3), iv_op(4))); | |
2528 | check_op(a, "lineseq[const(1).const(2)." | |
2529 | "list[pushmark.const(3).const(4).]]"); | |
2530 | op_free(a); | |
2531 | a = op_append_list(OP_LINESEQ, | |
2532 | op_append_list(OP_LIST, iv_op(1), iv_op(2)), | |
2533 | op_append_list(OP_LINESEQ, iv_op(3), iv_op(4))); | |
2534 | check_op(a, "lineseq[list[pushmark.const(1).const(2).]" | |
2535 | "const(3).const(4).]"); | |
2536 | op_free(a); | |
2fcb4757 Z |
2537 | #undef check_op |
2538 | ||
2539 | void | |
5983a79d BM |
2540 | test_op_linklist () |
2541 | PREINIT: | |
2542 | OP *o; | |
2543 | CODE: | |
2544 | #define check_ll(o, expect) \ | |
2545 | STMT_START { \ | |
2546 | if (strNE(test_op_linklist_describe(o), (expect))) \ | |
2547 | croak("fail %s %s", test_op_linklist_describe(o), (expect)); \ | |
2548 | } STMT_END | |
2549 | o = iv_op(1); | |
2550 | check_ll(o, ".const1"); | |
2551 | op_free(o); | |
2552 | ||
2553 | o = mkUNOP(OP_NOT, iv_op(1)); | |
2554 | check_ll(o, ".const1.not"); | |
2555 | op_free(o); | |
2556 | ||
2557 | o = mkUNOP(OP_NOT, mkUNOP(OP_NEGATE, iv_op(1))); | |
2558 | check_ll(o, ".const1.negate.not"); | |
2559 | op_free(o); | |
2560 | ||
2561 | o = mkBINOP(OP_ADD, iv_op(1), iv_op(2)); | |
2562 | check_ll(o, ".const1.const2.add"); | |
2563 | op_free(o); | |
2564 | ||
2565 | o = mkBINOP(OP_ADD, mkUNOP(OP_NOT, iv_op(1)), iv_op(2)); | |
2566 | check_ll(o, ".const1.not.const2.add"); | |
2567 | op_free(o); | |
2568 | ||
2569 | o = mkUNOP(OP_NOT, mkBINOP(OP_ADD, iv_op(1), iv_op(2))); | |
2570 | check_ll(o, ".const1.const2.add.not"); | |
2571 | op_free(o); | |
2572 | ||
2573 | o = mkLISTOP(OP_LINESEQ, iv_op(1), iv_op(2), iv_op(3)); | |
2574 | check_ll(o, ".const1.const2.const3.lineseq"); | |
2575 | op_free(o); | |
2576 | ||
2577 | o = mkLISTOP(OP_LINESEQ, | |
2578 | mkBINOP(OP_ADD, iv_op(1), iv_op(2)), | |
2579 | mkUNOP(OP_NOT, iv_op(3)), | |
2580 | mkLISTOP(OP_SUBSTR, iv_op(4), iv_op(5), iv_op(6))); | |
2581 | check_ll(o, ".const1.const2.add.const3.not" | |
2582 | ".const4.const5.const6.substr.lineseq"); | |
2583 | op_free(o); | |
2584 | ||
2585 | o = mkBINOP(OP_ADD, iv_op(1), iv_op(2)); | |
2586 | LINKLIST(o); | |
2587 | o = mkBINOP(OP_SUBTRACT, o, iv_op(3)); | |
2588 | check_ll(o, ".const1.const2.add.const3.subtract"); | |
2589 | op_free(o); | |
2590 | #undef check_ll | |
2591 | #undef iv_op | |
2592 | ||
2593 | void | |
201c7e1f FR |
2594 | peep_enable () |
2595 | PREINIT: | |
2596 | dMY_CXT; | |
2597 | CODE: | |
2598 | av_clear(MY_CXT.peep_recorder); | |
2599 | av_clear(MY_CXT.rpeep_recorder); | |
2600 | MY_CXT.peep_recording = 1; | |
2601 | ||
2602 | void | |
2603 | peep_disable () | |
2604 | PREINIT: | |
2605 | dMY_CXT; | |
2606 | CODE: | |
2607 | MY_CXT.peep_recording = 0; | |
2608 | ||
2609 | SV * | |
2610 | peep_record () | |
2611 | PREINIT: | |
2612 | dMY_CXT; | |
2613 | CODE: | |
95d2461a | 2614 | RETVAL = newRV_inc((SV *)MY_CXT.peep_recorder); |
201c7e1f FR |
2615 | OUTPUT: |
2616 | RETVAL | |
2617 | ||
2618 | SV * | |
2619 | rpeep_record () | |
2620 | PREINIT: | |
2621 | dMY_CXT; | |
2622 | CODE: | |
95d2461a | 2623 | RETVAL = newRV_inc((SV *)MY_CXT.rpeep_recorder); |
201c7e1f FR |
2624 | OUTPUT: |
2625 | RETVAL | |
2626 | ||
9c540340 DM |
2627 | =pod |
2628 | ||
2629 | multicall_each: call a sub for each item in the list. Used to test MULTICALL | |
2630 | ||
2631 | =cut | |
2632 | ||
2633 | void | |
2634 | multicall_each(block,...) | |
2635 | SV * block | |
2636 | PROTOTYPE: &@ | |
2637 | CODE: | |
2638 | { | |
2639 | dMULTICALL; | |
2640 | int index; | |
2641 | GV *gv; | |
2642 | HV *stash; | |
2643 | I32 gimme = G_SCALAR; | |
2644 | SV **args = &PL_stack_base[ax]; | |
2645 | CV *cv; | |
2646 | ||
2647 | if(items <= 1) { | |
2648 | XSRETURN_UNDEF; | |
2649 | } | |
2650 | cv = sv_2cv(block, &stash, &gv, 0); | |
2651 | if (cv == Nullcv) { | |
2652 | croak("multicall_each: not a subroutine reference"); | |
2653 | } | |
2654 | PUSH_MULTICALL(cv); | |
2655 | SAVESPTR(GvSV(PL_defgv)); | |
2656 | ||
2657 | for(index = 1 ; index < items ; index++) { | |
2658 | GvSV(PL_defgv) = args[index]; | |
2659 | MULTICALL; | |
2660 | } | |
2661 | POP_MULTICALL; | |
2662 | XSRETURN_UNDEF; | |
2663 | } | |
2664 | ||
2665 | ||
88b5a879 GF |
2666 | SV* |
2667 | take_svref(SVREF sv) | |
2668 | CODE: | |
2669 | RETVAL = newRV_inc(sv); | |
2670 | OUTPUT: | |
2671 | RETVAL | |
2672 | ||
2673 | SV* | |
2674 | take_avref(AV* av) | |
2675 | CODE: | |
2676 | RETVAL = newRV_inc((SV*)av); | |
2677 | OUTPUT: | |
2678 | RETVAL | |
2679 | ||
2680 | SV* | |
2681 | take_hvref(HV* hv) | |
2682 | CODE: | |
2683 | RETVAL = newRV_inc((SV*)hv); | |
2684 | OUTPUT: | |
2685 | RETVAL | |
2686 | ||
2687 | ||
2688 | SV* | |
2689 | take_cvref(CV* cv) | |
2690 | CODE: | |
2691 | RETVAL = newRV_inc((SV*)cv); | |
2692 | OUTPUT: | |
2693 | RETVAL | |
2694 | ||
2695 | ||
e2fe06dd EB |
2696 | BOOT: |
2697 | { | |
2698 | HV* stash; | |
2699 | SV** meth = NULL; | |
2700 | CV* cv; | |
2701 | stash = gv_stashpv("XS::APItest::TempLv", 0); | |
2702 | if (stash) | |
2703 | meth = hv_fetchs(stash, "make_temp_mg_lv", 0); | |
2704 | if (!meth) | |
2705 | croak("lost method 'make_temp_mg_lv'"); | |
2706 | cv = GvCV(*meth); | |
2707 | CvLVALUE_on(cv); | |
2708 | } | |
83f8bb56 Z |
2709 | |
2710 | BOOT: | |
2711 | { | |
2712 | hintkey_rpn_sv = newSVpvs_share("XS::APItest/rpn"); | |
2713 | hintkey_calcrpn_sv = newSVpvs_share("XS::APItest/calcrpn"); | |
2714 | hintkey_stufftest_sv = newSVpvs_share("XS::APItest/stufftest"); | |
2715 | hintkey_swaptwostmts_sv = newSVpvs_share("XS::APItest/swaptwostmts"); | |
07ffcb73 | 2716 | hintkey_looprest_sv = newSVpvs_share("XS::APItest/looprest"); |
a7aaec61 | 2717 | hintkey_scopelessblock_sv = newSVpvs_share("XS::APItest/scopelessblock"); |
9eb5c532 Z |
2718 | hintkey_stmtasexpr_sv = newSVpvs_share("XS::APItest/stmtasexpr"); |
2719 | hintkey_stmtsasexpr_sv = newSVpvs_share("XS::APItest/stmtsasexpr"); | |
e53d8f76 Z |
2720 | hintkey_loopblock_sv = newSVpvs_share("XS::APItest/loopblock"); |
2721 | hintkey_blockasexpr_sv = newSVpvs_share("XS::APItest/blockasexpr"); | |
361d9b55 Z |
2722 | hintkey_swaplabel_sv = newSVpvs_share("XS::APItest/swaplabel"); |
2723 | hintkey_labelconst_sv = newSVpvs_share("XS::APItest/labelconst"); | |
78cdf107 Z |
2724 | hintkey_arrayfullexpr_sv = newSVpvs_share("XS::APItest/arrayfullexpr"); |
2725 | hintkey_arraylistexpr_sv = newSVpvs_share("XS::APItest/arraylistexpr"); | |
2726 | hintkey_arraytermexpr_sv = newSVpvs_share("XS::APItest/arraytermexpr"); | |
2727 | hintkey_arrayarithexpr_sv = newSVpvs_share("XS::APItest/arrayarithexpr"); | |
2728 | hintkey_arrayexprflags_sv = newSVpvs_share("XS::APItest/arrayexprflags"); | |
83f8bb56 Z |
2729 | next_keyword_plugin = PL_keyword_plugin; |
2730 | PL_keyword_plugin = my_keyword_plugin; | |
2731 | } | |
8f89e5a9 Z |
2732 | |
2733 | void | |
2734 | establish_cleanup(...) | |
2735 | PROTOTYPE: $ | |
2736 | CODE: | |
c33e8be1 | 2737 | PERL_UNUSED_VAR(items); |
8f89e5a9 Z |
2738 | croak("establish_cleanup called as a function"); |
2739 | ||
2740 | BOOT: | |
2741 | { | |
2742 | CV *estcv = get_cv("XS::APItest::establish_cleanup", 0); | |
2743 | cv_set_call_checker(estcv, THX_ck_entersub_establish_cleanup, (SV*)estcv); | |
2744 | } | |
3ad73efd Z |
2745 | |
2746 | void | |
2747 | postinc(...) | |
2748 | PROTOTYPE: $ | |
2749 | CODE: | |
c33e8be1 | 2750 | PERL_UNUSED_VAR(items); |
3ad73efd Z |
2751 | croak("postinc called as a function"); |
2752 | ||
2753 | BOOT: | |
2754 | { | |
2755 | CV *asscv = get_cv("XS::APItest::postinc", 0); | |
2756 | cv_set_call_checker(asscv, THX_ck_entersub_postinc, (SV*)asscv); | |
2757 | } | |
26ab20ee FR |
2758 | |
2759 | MODULE = XS::APItest PACKAGE = XS::APItest::Magic | |
2760 | ||
2761 | PROTOTYPES: DISABLE | |
2762 | ||
2763 | void | |
2764 | sv_magic_foo(SV *sv, SV *thingy) | |
2765 | ALIAS: | |
2766 | sv_magic_bar = 1 | |
2767 | CODE: | |
2768 | sv_magicext(SvRV(sv), NULL, PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo, (const char *)thingy, 0); | |
2769 | ||
2770 | SV * | |
2771 | mg_find_foo(SV *sv) | |
2772 | ALIAS: | |
2773 | mg_find_bar = 1 | |
2774 | CODE: | |
2775 | MAGIC *mg = mg_findext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo); | |
2776 | RETVAL = mg ? SvREFCNT_inc((SV *)mg->mg_ptr) : &PL_sv_undef; | |
2777 | OUTPUT: | |
2778 | RETVAL | |
2779 | ||
2780 | void | |
2781 | sv_unmagic_foo(SV *sv) | |
2782 | ALIAS: | |
2783 | sv_unmagic_bar = 1 | |
2784 | CODE: | |
2785 | sv_unmagicext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo); |