This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update release manager's guide regarding perldelta
[perl5.git] / ext / XS-APItest / APItest.xs
CommitLineData
6a93a7e5 1#define PERL_IN_XS_APITEST
3e61d65a
JH
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
5
36c2b1d0
NC
6typedef SV *SVREF;
7typedef PTR_TBL_t *XS__APItest__PtrTable;
85ce96a1
DM
8
9/* for my_cxt tests */
10
11#define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
12
13typedef struct {
14 int i;
15 SV *sv;
03569ecf
BM
16 GV *cscgv;
17 AV *cscav;
13b6b3bc
BM
18 AV *bhkav;
19 bool bhk_record;
85ce96a1
DM
20} my_cxt_t;
21
22START_MY_CXT
23
24/* indirect functions to test the [pa]MY_CXT macros */
f16dd614 25
85ce96a1
DM
26int
27my_cxt_getint_p(pMY_CXT)
28{
29 return MY_CXT.i;
30}
f16dd614 31
85ce96a1
DM
32void
33my_cxt_setint_p(pMY_CXT_ int i)
34{
35 MY_CXT.i = i;
36}
f16dd614
DM
37
38SV*
9568a123 39my_cxt_getsv_interp_context(void)
f16dd614 40{
f16dd614
DM
41 dTHX;
42 dMY_CXT_INTERP(my_perl);
9568a123
NC
43 return MY_CXT.sv;
44}
45
46SV*
47my_cxt_getsv_interp(void)
48{
f16dd614 49 dMY_CXT;
f16dd614
DM
50 return MY_CXT.sv;
51}
52
85ce96a1
DM
53void
54my_cxt_setsv_p(SV* sv _pMY_CXT)
55{
56 MY_CXT.sv = sv;
57}
58
59
9b5c3821 60/* from exception.c */
7a646707 61int apitest_exception(int);
0314122a 62
ff66e713
SH
63/* from core_or_not.inc */
64bool sv_setsv_cow_hashkey_core(void);
65bool sv_setsv_cow_hashkey_notcore(void);
66
2dc92170
NC
67/* A routine to test hv_delayfree_ent
68 (which itself is tested by testing on hv_free_ent */
69
70typedef void (freeent_function)(pTHX_ HV *, register HE *);
71
72void
73test_freeent(freeent_function *f) {
74 dTHX;
75 dSP;
76 HV *test_hash = newHV();
77 HE *victim;
78 SV *test_scalar;
79 U32 results[4];
80 int i;
81
8afd2d2e
NC
82#ifdef PURIFY
83 victim = (HE*)safemalloc(sizeof(HE));
84#else
2dc92170
NC
85 /* Storing then deleting something should ensure that a hash entry is
86 available. */
87 hv_store(test_hash, "", 0, &PL_sv_yes, 0);
88 hv_delete(test_hash, "", 0, 0);
89
90 /* We need to "inline" new_he here as it's static, and the functions we
91 test expect to be able to call del_HE on the HE */
6a93a7e5 92 if (!PL_body_roots[HE_SVSLOT])
2dc92170 93 croak("PL_he_root is 0");
8a722a80 94 victim = (HE*) PL_body_roots[HE_SVSLOT];
6a93a7e5 95 PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
8afd2d2e 96#endif
2dc92170
NC
97
98 victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
99
100 test_scalar = newSV(0);
101 SvREFCNT_inc(test_scalar);
de616631 102 HeVAL(victim) = test_scalar;
2dc92170
NC
103
104 /* Need this little game else we free the temps on the return stack. */
105 results[0] = SvREFCNT(test_scalar);
106 SAVETMPS;
107 results[1] = SvREFCNT(test_scalar);
108 f(aTHX_ test_hash, victim);
109 results[2] = SvREFCNT(test_scalar);
110 FREETMPS;
111 results[3] = SvREFCNT(test_scalar);
112
113 i = 0;
114 do {
115 mPUSHu(results[i]);
116 } while (++i < sizeof(results)/sizeof(results[0]));
117
118 /* Goodbye to our extra reference. */
119 SvREFCNT_dec(test_scalar);
120}
121
b54b4831
NC
122
123static I32
53c40a8f
NC
124bitflip_key(pTHX_ IV action, SV *field) {
125 MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
126 SV *keysv;
127 if (mg && (keysv = mg->mg_obj)) {
128 STRLEN len;
129 const char *p = SvPV(keysv, len);
130
131 if (len) {
132 SV *newkey = newSV(len);
133 char *new_p = SvPVX(newkey);
134
135 if (SvUTF8(keysv)) {
136 const char *const end = p + len;
137 while (p < end) {
138 STRLEN len;
a75fcbca
SP
139 UV chr = utf8_to_uvuni((U8 *)p, &len);
140 new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32);
53c40a8f
NC
141 p += len;
142 }
143 SvUTF8_on(newkey);
144 } else {
145 while (len--)
146 *new_p++ = *p++ ^ 32;
147 }
148 *new_p = '\0';
149 SvCUR_set(newkey, SvCUR(keysv));
150 SvPOK_on(newkey);
151
152 mg->mg_obj = newkey;
153 }
154 }
155 return 0;
156}
157
158static I32
b54b4831
NC
159rot13_key(pTHX_ IV action, SV *field) {
160 MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
161 SV *keysv;
162 if (mg && (keysv = mg->mg_obj)) {
163 STRLEN len;
164 const char *p = SvPV(keysv, len);
165
166 if (len) {
167 SV *newkey = newSV(len);
168 char *new_p = SvPVX(newkey);
169
170 /* There's a deliberate fencepost error here to loop len + 1 times
171 to copy the trailing \0 */
172 do {
173 char new_c = *p++;
174 /* Try doing this cleanly and clearly in EBCDIC another way: */
175 switch (new_c) {
176 case 'A': new_c = 'N'; break;
177 case 'B': new_c = 'O'; break;
178 case 'C': new_c = 'P'; break;
179 case 'D': new_c = 'Q'; break;
180 case 'E': new_c = 'R'; break;
181 case 'F': new_c = 'S'; break;
182 case 'G': new_c = 'T'; break;
183 case 'H': new_c = 'U'; break;
184 case 'I': new_c = 'V'; break;
185 case 'J': new_c = 'W'; break;
186 case 'K': new_c = 'X'; break;
187 case 'L': new_c = 'Y'; break;
188 case 'M': new_c = 'Z'; break;
189 case 'N': new_c = 'A'; break;
190 case 'O': new_c = 'B'; break;
191 case 'P': new_c = 'C'; break;
192 case 'Q': new_c = 'D'; break;
193 case 'R': new_c = 'E'; break;
194 case 'S': new_c = 'F'; break;
195 case 'T': new_c = 'G'; break;
196 case 'U': new_c = 'H'; break;
197 case 'V': new_c = 'I'; break;
198 case 'W': new_c = 'J'; break;
199 case 'X': new_c = 'K'; break;
200 case 'Y': new_c = 'L'; break;
201 case 'Z': new_c = 'M'; break;
202 case 'a': new_c = 'n'; break;
203 case 'b': new_c = 'o'; break;
204 case 'c': new_c = 'p'; break;
205 case 'd': new_c = 'q'; break;
206 case 'e': new_c = 'r'; break;
207 case 'f': new_c = 's'; break;
208 case 'g': new_c = 't'; break;
209 case 'h': new_c = 'u'; break;
210 case 'i': new_c = 'v'; break;
211 case 'j': new_c = 'w'; break;
212 case 'k': new_c = 'x'; break;
213 case 'l': new_c = 'y'; break;
214 case 'm': new_c = 'z'; break;
215 case 'n': new_c = 'a'; break;
216 case 'o': new_c = 'b'; break;
217 case 'p': new_c = 'c'; break;
218 case 'q': new_c = 'd'; break;
219 case 'r': new_c = 'e'; break;
220 case 's': new_c = 'f'; break;
221 case 't': new_c = 'g'; break;
222 case 'u': new_c = 'h'; break;
223 case 'v': new_c = 'i'; break;
224 case 'w': new_c = 'j'; break;
225 case 'x': new_c = 'k'; break;
226 case 'y': new_c = 'l'; break;
227 case 'z': new_c = 'm'; break;
228 }
229 *new_p++ = new_c;
230 } while (len--);
231 SvCUR_set(newkey, SvCUR(keysv));
232 SvPOK_on(newkey);
233 if (SvUTF8(keysv))
234 SvUTF8_on(newkey);
235
236 mg->mg_obj = newkey;
237 }
238 }
239 return 0;
240}
241
218787bd
VP
242STATIC I32
243rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
244 return 0;
245}
246
247STATIC MGVTBL rmagical_b = { 0 };
248
03569ecf 249STATIC void
13b6b3bc 250blockhook_csc_start(pTHX_ int full)
03569ecf
BM
251{
252 dMY_CXT;
253 AV *const cur = GvAV(MY_CXT.cscgv);
254
255 SAVEGENERICSV(GvAV(MY_CXT.cscgv));
256
257 if (cur) {
258 I32 i;
d024465f 259 AV *const new_av = newAV();
03569ecf
BM
260
261 for (i = 0; i <= av_len(cur); i++) {
d024465f 262 av_store(new_av, i, newSVsv(*av_fetch(cur, i, 0)));
03569ecf
BM
263 }
264
d024465f 265 GvAV(MY_CXT.cscgv) = new_av;
03569ecf
BM
266 }
267}
268
269STATIC void
13b6b3bc 270blockhook_csc_pre_end(pTHX_ OP **o)
03569ecf
BM
271{
272 dMY_CXT;
273
274 /* if we hit the end of a scope we missed the start of, we need to
275 * unconditionally clear @CSC */
52db365a 276 if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) {
03569ecf 277 av_clear(MY_CXT.cscav);
52db365a 278 }
03569ecf
BM
279
280}
281
13b6b3bc
BM
282STATIC void
283blockhook_test_start(pTHX_ int full)
284{
285 dMY_CXT;
286 AV *av;
287
288 if (MY_CXT.bhk_record) {
289 av = newAV();
290 av_push(av, newSVpvs("start"));
291 av_push(av, newSViv(full));
292 av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
293 }
294}
295
296STATIC void
297blockhook_test_pre_end(pTHX_ OP **o)
298{
299 dMY_CXT;
300
301 if (MY_CXT.bhk_record)
302 av_push(MY_CXT.bhkav, newSVpvs("pre_end"));
303}
304
305STATIC void
306blockhook_test_post_end(pTHX_ OP **o)
307{
308 dMY_CXT;
309
310 if (MY_CXT.bhk_record)
311 av_push(MY_CXT.bhkav, newSVpvs("post_end"));
312}
313
314STATIC void
315blockhook_test_eval(pTHX_ OP *const o)
316{
317 dMY_CXT;
318 AV *av;
319
320 if (MY_CXT.bhk_record) {
321 av = newAV();
322 av_push(av, newSVpvs("eval"));
323 av_push(av, newSVpv(OP_NAME(o), 0));
324 av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
325 }
326}
327
328STATIC BHK bhk_csc, bhk_test;
329
55289a74
NC
330#include "const-c.inc"
331
0314122a
NC
332MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
333
55289a74
NC
334INCLUDE: const-xs.inc
335
b54b4831
NC
336void
337rot13_hash(hash)
338 HV *hash
339 CODE:
340 {
341 struct ufuncs uf;
342 uf.uf_val = rot13_key;
343 uf.uf_set = 0;
344 uf.uf_index = 0;
345
346 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
347 }
348
53c40a8f
NC
349void
350bitflip_hash(hash)
351 HV *hash
352 CODE:
353 {
354 struct ufuncs uf;
355 uf.uf_val = bitflip_key;
356 uf.uf_set = 0;
357 uf.uf_index = 0;
358
359 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
360 }
361
028f8eaa
MHM
362#define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
363
0314122a
NC
364bool
365exists(hash, key_sv)
366 PREINIT:
367 STRLEN len;
368 const char *key;
369 INPUT:
370 HV *hash
371 SV *key_sv
372 CODE:
373 key = SvPV(key_sv, len);
028f8eaa 374 RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
0314122a
NC
375 OUTPUT:
376 RETVAL
377
bdee33e4
NC
378bool
379exists_ent(hash, key_sv)
380 PREINIT:
381 INPUT:
382 HV *hash
383 SV *key_sv
384 CODE:
385 RETVAL = hv_exists_ent(hash, key_sv, 0);
386 OUTPUT:
387 RETVAL
388
b60cf05a 389SV *
55289a74 390delete(hash, key_sv, flags = 0)
b60cf05a
NC
391 PREINIT:
392 STRLEN len;
393 const char *key;
394 INPUT:
395 HV *hash
396 SV *key_sv
55289a74 397 I32 flags;
b60cf05a
NC
398 CODE:
399 key = SvPV(key_sv, len);
400 /* It's already mortal, so need to increase reference count. */
55289a74
NC
401 RETVAL
402 = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
403 OUTPUT:
404 RETVAL
405
406SV *
407delete_ent(hash, key_sv, flags = 0)
408 INPUT:
409 HV *hash
410 SV *key_sv
411 I32 flags;
412 CODE:
413 /* It's already mortal, so need to increase reference count. */
414 RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
b60cf05a
NC
415 OUTPUT:
416 RETVAL
417
418SV *
858117f8
NC
419store_ent(hash, key, value)
420 PREINIT:
421 SV *copy;
422 HE *result;
423 INPUT:
424 HV *hash
425 SV *key
426 SV *value
427 CODE:
428 copy = newSV(0);
429 result = hv_store_ent(hash, key, copy, 0);
430 SvSetMagicSV(copy, value);
431 if (!result) {
432 SvREFCNT_dec(copy);
433 XSRETURN_EMPTY;
434 }
435 /* It's about to become mortal, so need to increase reference count.
436 */
437 RETVAL = SvREFCNT_inc(HeVAL(result));
438 OUTPUT:
439 RETVAL
440
858117f8 441SV *
b60cf05a
NC
442store(hash, key_sv, value)
443 PREINIT:
444 STRLEN len;
445 const char *key;
446 SV *copy;
447 SV **result;
448 INPUT:
449 HV *hash
450 SV *key_sv
451 SV *value
452 CODE:
453 key = SvPV(key_sv, len);
454 copy = newSV(0);
028f8eaa 455 result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
858117f8 456 SvSetMagicSV(copy, value);
b60cf05a
NC
457 if (!result) {
458 SvREFCNT_dec(copy);
459 XSRETURN_EMPTY;
460 }
461 /* It's about to become mortal, so need to increase reference count.
462 */
463 RETVAL = SvREFCNT_inc(*result);
464 OUTPUT:
465 RETVAL
466
bdee33e4
NC
467SV *
468fetch_ent(hash, key_sv)
469 PREINIT:
470 HE *result;
471 INPUT:
472 HV *hash
473 SV *key_sv
474 CODE:
475 result = hv_fetch_ent(hash, key_sv, 0, 0);
476 if (!result) {
477 XSRETURN_EMPTY;
478 }
479 /* Force mg_get */
480 RETVAL = newSVsv(HeVAL(result));
481 OUTPUT:
482 RETVAL
b60cf05a
NC
483
484SV *
485fetch(hash, key_sv)
486 PREINIT:
487 STRLEN len;
488 const char *key;
489 SV **result;
490 INPUT:
491 HV *hash
492 SV *key_sv
493 CODE:
494 key = SvPV(key_sv, len);
028f8eaa 495 result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
b60cf05a
NC
496 if (!result) {
497 XSRETURN_EMPTY;
498 }
499 /* Force mg_get */
500 RETVAL = newSVsv(*result);
501 OUTPUT:
502 RETVAL
2dc92170 503
9568a123
NC
504#if defined (hv_common)
505
6b4de907
NC
506SV *
507common(params)
508 INPUT:
509 HV *params
510 PREINIT:
511 HE *result;
512 HV *hv = NULL;
513 SV *keysv = NULL;
514 const char *key = NULL;
515 STRLEN klen = 0;
516 int flags = 0;
517 int action = 0;
518 SV *val = NULL;
519 U32 hash = 0;
520 SV **svp;
521 CODE:
522 if ((svp = hv_fetchs(params, "hv", 0))) {
523 SV *const rv = *svp;
524 if (!SvROK(rv))
525 croak("common passed a non-reference for parameter hv");
526 hv = (HV *)SvRV(rv);
527 }
528 if ((svp = hv_fetchs(params, "keysv", 0)))
529 keysv = *svp;
530 if ((svp = hv_fetchs(params, "keypv", 0))) {
531 key = SvPV_const(*svp, klen);
532 if (SvUTF8(*svp))
533 flags = HVhek_UTF8;
534 }
535 if ((svp = hv_fetchs(params, "action", 0)))
536 action = SvIV(*svp);
537 if ((svp = hv_fetchs(params, "val", 0)))
527df579 538 val = newSVsv(*svp);
6b4de907 539 if ((svp = hv_fetchs(params, "hash", 0)))
a44093a9 540 hash = SvUV(*svp);
6b4de907 541
527df579
NC
542 if ((svp = hv_fetchs(params, "hash_pv", 0))) {
543 PERL_HASH(hash, key, klen);
544 }
58ca560a
NC
545 if ((svp = hv_fetchs(params, "hash_sv", 0))) {
546 STRLEN len;
547 const char *const p = SvPV(keysv, len);
548 PERL_HASH(hash, p, len);
549 }
527df579 550
a75fcbca 551 result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
6b4de907
NC
552 if (!result) {
553 XSRETURN_EMPTY;
554 }
555 /* Force mg_get */
556 RETVAL = newSVsv(HeVAL(result));
557 OUTPUT:
558 RETVAL
559
9568a123
NC
560#endif
561
439efdfe 562void
2dc92170
NC
563test_hv_free_ent()
564 PPCODE:
565 test_freeent(&Perl_hv_free_ent);
566 XSRETURN(4);
567
439efdfe 568void
2dc92170
NC
569test_hv_delayfree_ent()
570 PPCODE:
571 test_freeent(&Perl_hv_delayfree_ent);
572 XSRETURN(4);
35ab5632
NC
573
574SV *
575test_share_unshare_pvn(input)
576 PREINIT:
35ab5632
NC
577 STRLEN len;
578 U32 hash;
579 char *pvx;
580 char *p;
581 INPUT:
582 SV *input
583 CODE:
584 pvx = SvPV(input, len);
585 PERL_HASH(hash, pvx, len);
586 p = sharepvn(pvx, len, hash);
587 RETVAL = newSVpvn(p, len);
588 unsharepvn(p, len, hash);
589 OUTPUT:
590 RETVAL
d8c5b3c5 591
9568a123
NC
592#if PERL_VERSION >= 9
593
d8c5b3c5
NC
594bool
595refcounted_he_exists(key, level=0)
596 SV *key
597 IV level
598 CODE:
599 if (level) {
600 croak("level must be zero, not %"IVdf, level);
601 }
602 RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
603 key, NULL, 0, 0, 0)
604 != &PL_sv_placeholder);
605 OUTPUT:
606 RETVAL
607
d8c5b3c5
NC
608SV *
609refcounted_he_fetch(key, level=0)
610 SV *key
611 IV level
612 CODE:
613 if (level) {
614 croak("level must be zero, not %"IVdf, level);
615 }
616 RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
617 NULL, 0, 0, 0);
618 SvREFCNT_inc(RETVAL);
619 OUTPUT:
620 RETVAL
65bfe90c 621
9568a123 622#endif
65bfe90c 623
0314122a
NC
624=pod
625
626sub TIEHASH { bless {}, $_[0] }
627sub STORE { $_[0]->{$_[1]} = $_[2] }
628sub FETCH { $_[0]->{$_[1]} }
629sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
630sub NEXTKEY { each %{$_[0]} }
631sub EXISTS { exists $_[0]->{$_[1]} }
632sub DELETE { delete $_[0]->{$_[1]} }
633sub CLEAR { %{$_[0]} = () }
634
635=cut
636
e2fe06dd
EB
637MODULE = XS::APItest:TempLv PACKAGE = XS::APItest::TempLv
638
639void
640make_temp_mg_lv(sv)
641SV* sv
642 PREINIT:
643 SV * const lv = newSV_type(SVt_PVLV);
644 STRLEN len;
645 PPCODE:
646 SvPV(sv, len);
647
648 sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
649 LvTYPE(lv) = 'x';
650 LvTARG(lv) = SvREFCNT_inc_simple(sv);
651 LvTARGOFF(lv) = len == 0 ? 0 : 1;
652 LvTARGLEN(lv) = len < 2 ? 0 : len-2;
653
654 EXTEND(SP, 1);
655 ST(0) = sv_2mortal(lv);
656 XSRETURN(1);
657
658
36c2b1d0
NC
659MODULE = XS::APItest::PtrTable PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
660
661void
662ptr_table_new(classname)
663const char * classname
664 PPCODE:
665 PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
666
667void
668DESTROY(table)
669XS::APItest::PtrTable table
670 CODE:
671 ptr_table_free(table);
672
673void
992b2363 674ptr_table_store(table, from, to)
36c2b1d0 675XS::APItest::PtrTable table
992b2363
NC
676SVREF from
677SVREF to
36c2b1d0 678 CODE:
992b2363 679 ptr_table_store(table, from, to);
36c2b1d0
NC
680
681UV
992b2363 682ptr_table_fetch(table, from)
36c2b1d0 683XS::APItest::PtrTable table
992b2363 684SVREF from
36c2b1d0 685 CODE:
992b2363 686 RETVAL = PTR2UV(ptr_table_fetch(table, from));
36c2b1d0
NC
687 OUTPUT:
688 RETVAL
689
690void
691ptr_table_split(table)
692XS::APItest::PtrTable table
693
694void
695ptr_table_clear(table)
696XS::APItest::PtrTable table
697
3e61d65a
JH
698MODULE = XS::APItest PACKAGE = XS::APItest
699
700PROTOTYPES: DISABLE
701
85ce96a1
DM
702BOOT:
703{
704 MY_CXT_INIT;
03569ecf 705
85ce96a1
DM
706 MY_CXT.i = 99;
707 MY_CXT.sv = newSVpv("initial",0);
13b6b3bc
BM
708
709 MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
710 MY_CXT.bhk_record = 0;
711
712 BhkENTRY_set(&bhk_test, start, blockhook_test_start);
713 BhkENTRY_set(&bhk_test, pre_end, blockhook_test_pre_end);
714 BhkENTRY_set(&bhk_test, post_end, blockhook_test_post_end);
715 BhkENTRY_set(&bhk_test, eval, blockhook_test_eval);
716 Perl_blockhook_register(aTHX_ &bhk_test);
717
65bfe90c 718 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
13b6b3bc 719 GV_ADDMULTI, SVt_PVAV);
03569ecf
BM
720 MY_CXT.cscav = GvAV(MY_CXT.cscgv);
721
13b6b3bc
BM
722 BhkENTRY_set(&bhk_csc, start, blockhook_csc_start);
723 BhkENTRY_set(&bhk_csc, pre_end, blockhook_csc_pre_end);
724 Perl_blockhook_register(aTHX_ &bhk_csc);
65bfe90c 725}
85ce96a1
DM
726
727void
728CLONE(...)
729 CODE:
730 MY_CXT_CLONE;
731 MY_CXT.sv = newSVpv("initial_clone",0);
65bfe90c 732 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
13b6b3bc 733 GV_ADDMULTI, SVt_PVAV);
03569ecf 734 MY_CXT.cscav = NULL;
13b6b3bc
BM
735 MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
736 MY_CXT.bhk_record = 0;
85ce96a1 737
3e61d65a
JH
738void
739print_double(val)
740 double val
741 CODE:
742 printf("%5.3f\n",val);
743
744int
745have_long_double()
746 CODE:
747#ifdef HAS_LONG_DOUBLE
748 RETVAL = 1;
749#else
750 RETVAL = 0;
751#endif
cabb36f0
CN
752 OUTPUT:
753 RETVAL
3e61d65a
JH
754
755void
756print_long_double()
757 CODE:
758#ifdef HAS_LONG_DOUBLE
fc0bf671 759# if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
3e61d65a
JH
760 long double val = 7.0;
761 printf("%5.3" PERL_PRIfldbl "\n",val);
762# else
763 double val = 7.0;
764 printf("%5.3f\n",val);
765# endif
766#endif
767
768void
3e61d65a
JH
769print_int(val)
770 int val
771 CODE:
772 printf("%d\n",val);
773
774void
775print_long(val)
776 long val
777 CODE:
778 printf("%ld\n",val);
779
780void
781print_float(val)
782 float val
783 CODE:
784 printf("%5.3f\n",val);
9d911683
NIS
785
786void
787print_flush()
788 CODE:
789 fflush(stdout);
d4b90eee
SH
790
791void
792mpushp()
793 PPCODE:
794 EXTEND(SP, 3);
795 mPUSHp("one", 3);
796 mPUSHp("two", 3);
797 mPUSHp("three", 5);
798 XSRETURN(3);
799
800void
801mpushn()
802 PPCODE:
803 EXTEND(SP, 3);
804 mPUSHn(0.5);
805 mPUSHn(-0.25);
806 mPUSHn(0.125);
807 XSRETURN(3);
808
809void
810mpushi()
811 PPCODE:
812 EXTEND(SP, 3);
d75b63cf
MHM
813 mPUSHi(-1);
814 mPUSHi(2);
815 mPUSHi(-3);
d4b90eee
SH
816 XSRETURN(3);
817
818void
819mpushu()
820 PPCODE:
821 EXTEND(SP, 3);
d75b63cf
MHM
822 mPUSHu(1);
823 mPUSHu(2);
824 mPUSHu(3);
d4b90eee
SH
825 XSRETURN(3);
826
827void
828mxpushp()
829 PPCODE:
830 mXPUSHp("one", 3);
831 mXPUSHp("two", 3);
832 mXPUSHp("three", 5);
833 XSRETURN(3);
834
835void
836mxpushn()
837 PPCODE:
838 mXPUSHn(0.5);
839 mXPUSHn(-0.25);
840 mXPUSHn(0.125);
841 XSRETURN(3);
842
843void
844mxpushi()
845 PPCODE:
d75b63cf
MHM
846 mXPUSHi(-1);
847 mXPUSHi(2);
848 mXPUSHi(-3);
d4b90eee
SH
849 XSRETURN(3);
850
851void
852mxpushu()
853 PPCODE:
d75b63cf
MHM
854 mXPUSHu(1);
855 mXPUSHu(2);
856 mXPUSHu(3);
d4b90eee 857 XSRETURN(3);
d1f347d7
DM
858
859
860void
861call_sv(sv, flags, ...)
862 SV* sv
863 I32 flags
864 PREINIT:
865 I32 i;
866 PPCODE:
867 for (i=0; i<items-2; i++)
868 ST(i) = ST(i+2); /* pop first two args */
869 PUSHMARK(SP);
870 SP += items - 2;
871 PUTBACK;
872 i = call_sv(sv, flags);
873 SPAGAIN;
874 EXTEND(SP, 1);
875 PUSHs(sv_2mortal(newSViv(i)));
876
877void
878call_pv(subname, flags, ...)
879 char* subname
880 I32 flags
881 PREINIT:
882 I32 i;
883 PPCODE:
884 for (i=0; i<items-2; i++)
885 ST(i) = ST(i+2); /* pop first two args */
886 PUSHMARK(SP);
887 SP += items - 2;
888 PUTBACK;
889 i = call_pv(subname, flags);
890 SPAGAIN;
891 EXTEND(SP, 1);
892 PUSHs(sv_2mortal(newSViv(i)));
893
894void
895call_method(methname, flags, ...)
896 char* methname
897 I32 flags
898 PREINIT:
899 I32 i;
900 PPCODE:
901 for (i=0; i<items-2; i++)
902 ST(i) = ST(i+2); /* pop first two args */
903 PUSHMARK(SP);
904 SP += items - 2;
905 PUTBACK;
906 i = call_method(methname, flags);
907 SPAGAIN;
908 EXTEND(SP, 1);
909 PUSHs(sv_2mortal(newSViv(i)));
910
911void
912eval_sv(sv, flags)
913 SV* sv
914 I32 flags
915 PREINIT:
916 I32 i;
917 PPCODE:
918 PUTBACK;
919 i = eval_sv(sv, flags);
920 SPAGAIN;
921 EXTEND(SP, 1);
922 PUSHs(sv_2mortal(newSViv(i)));
923
b8e65a9b 924void
d1f347d7
DM
925eval_pv(p, croak_on_error)
926 const char* p
927 I32 croak_on_error
d1f347d7
DM
928 PPCODE:
929 PUTBACK;
930 EXTEND(SP, 1);
931 PUSHs(eval_pv(p, croak_on_error));
932
933void
934require_pv(pv)
935 const char* pv
d1f347d7
DM
936 PPCODE:
937 PUTBACK;
938 require_pv(pv);
939
0ca3a874 940int
7a646707 941apitest_exception(throw_e)
0ca3a874
MHM
942 int throw_e
943 OUTPUT:
944 RETVAL
d1f347d7 945
ef469b03 946void
7e7a3dfc
GA
947mycroak(sv)
948 SV* sv
ef469b03 949 CODE:
7e7a3dfc
GA
950 if (SvOK(sv)) {
951 Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
952 }
953 else {
954 Perl_croak(aTHX_ NULL);
955 }
5d2b1485
NC
956
957SV*
958strtab()
959 CODE:
960 RETVAL = newRV_inc((SV*)PL_strtab);
961 OUTPUT:
962 RETVAL
85ce96a1
DM
963
964int
965my_cxt_getint()
966 CODE:
967 dMY_CXT;
968 RETVAL = my_cxt_getint_p(aMY_CXT);
969 OUTPUT:
970 RETVAL
971
972void
973my_cxt_setint(i)
974 int i;
975 CODE:
976 dMY_CXT;
977 my_cxt_setint_p(aMY_CXT_ i);
978
979void
9568a123
NC
980my_cxt_getsv(how)
981 bool how;
85ce96a1 982 PPCODE:
85ce96a1 983 EXTEND(SP, 1);
9568a123 984 ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
85ce96a1
DM
985 XSRETURN(1);
986
987void
988my_cxt_setsv(sv)
989 SV *sv;
990 CODE:
991 dMY_CXT;
992 SvREFCNT_dec(MY_CXT.sv);
993 my_cxt_setsv_p(sv _aMY_CXT);
994 SvREFCNT_inc(sv);
34482cd6
NC
995
996bool
997sv_setsv_cow_hashkey_core()
998
999bool
1000sv_setsv_cow_hashkey_notcore()
84ac5fd7
NC
1001
1002void
218787bd
VP
1003rmagical_cast(sv, type)
1004 SV *sv;
1005 SV *type;
1006 PREINIT:
1007 struct ufuncs uf;
1008 PPCODE:
1009 if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
1010 sv = SvRV(sv);
1011 if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
1012 uf.uf_val = rmagical_a_dummy;
1013 uf.uf_set = NULL;
1014 uf.uf_index = 0;
1015 if (SvTRUE(type)) { /* b */
1016 sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
1017 } else { /* a */
1018 sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
1019 }
1020 XSRETURN_YES;
1021
1022void
1023rmagical_flags(sv)
1024 SV *sv;
1025 PPCODE:
1026 if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
1027 sv = SvRV(sv);
1028 EXTEND(SP, 3);
1029 mXPUSHu(SvFLAGS(sv) & SVs_GMG);
1030 mXPUSHu(SvFLAGS(sv) & SVs_SMG);
1031 mXPUSHu(SvFLAGS(sv) & SVs_RMG);
1032 XSRETURN(3);
1033
1034void
90d1f214
BM
1035my_caller(level)
1036 I32 level
1037 PREINIT:
1038 const PERL_CONTEXT *cx, *dbcx;
1039 const char *pv;
1040 const GV *gv;
1041 HV *hv;
1042 PPCODE:
1043 cx = caller_cx(level, &dbcx);
1044 EXTEND(SP, 8);
1045
1046 pv = CopSTASHPV(cx->blk_oldcop);
1047 ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1048 gv = CvGV(cx->blk_sub.cv);
1049 ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1050
1051 pv = CopSTASHPV(dbcx->blk_oldcop);
1052 ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1053 gv = CvGV(dbcx->blk_sub.cv);
1054 ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1055
1056 ST(4) = cop_hints_fetchpvs(cx->blk_oldcop, "foo");
1057 ST(5) = cop_hints_fetchpvn(cx->blk_oldcop, "foo", 3, 0, 0);
1058 ST(6) = cop_hints_fetchsv(cx->blk_oldcop,
1059 sv_2mortal(newSVpvn("foo", 3)), 0);
1060
1061 hv = cop_hints_2hv(cx->blk_oldcop);
1062 ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
1063
1064 XSRETURN(8);
1065
1066void
f9c17636
MB
1067DPeek (sv)
1068 SV *sv
1069
1070 PPCODE:
5b1f7359 1071 ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
f9c17636
MB
1072 XSRETURN (1);
1073
1074void
84ac5fd7
NC
1075BEGIN()
1076 CODE:
1077 sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
1078
1079void
1080CHECK()
1081 CODE:
1082 sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
1083
1084void
1085UNITCHECK()
1086 CODE:
0932863f 1087 sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
84ac5fd7
NC
1088
1089void
1090INIT()
1091 CODE:
1092 sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
1093
1094void
1095END()
1096 CODE:
1097 sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
30685b56
NC
1098
1099void
1100utf16_to_utf8 (sv, ...)
1101 SV* sv
1102 ALIAS:
1103 utf16_to_utf8_reversed = 1
1104 PREINIT:
1105 STRLEN len;
1106 U8 *source;
1107 SV *dest;
1108 I32 got; /* Gah, badly thought out APIs */
1109 CODE:
1110 source = (U8 *)SvPVbyte(sv, len);
1111 /* Optionally only convert part of the buffer. */
1112 if (items > 1) {
1113 len = SvUV(ST(1));
1114 }
1115 /* Mortalise this right now, as we'll be testing croak()s */
1116 dest = sv_2mortal(newSV(len * 3 / 2 + 1));
1117 if (ix) {
25f2e844 1118 utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
30685b56 1119 } else {
25f2e844 1120 utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
30685b56
NC
1121 }
1122 SvCUR_set(dest, got);
1123 SvPVX(dest)[got] = '\0';
1124 SvPOK_on(dest);
1125 ST(0) = dest;
1126 XSRETURN(1);
879d0c72 1127
6bd7445c
GG
1128void
1129my_exit(int exitcode)
1130 PPCODE:
1131 my_exit(exitcode);
d97c33b5
DM
1132
1133I32
1134sv_count()
1135 CODE:
1136 RETVAL = PL_sv_count;
1137 OUTPUT:
1138 RETVAL
13b6b3bc
BM
1139
1140void
1141bhk_record(bool on)
1142 CODE:
1143 dMY_CXT;
1144 MY_CXT.bhk_record = on;
1145 if (on)
1146 av_clear(MY_CXT.bhkav);
65bfe90c 1147
defdfed5
Z
1148void
1149test_savehints()
1150 PREINIT:
1151 SV **svp, *sv;
1152 CODE:
1153#define store_hint(KEY, VALUE) \
1154 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
1155#define hint_ok(KEY, EXPECT) \
1156 ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
1157 (sv = *svp) && SvIV(sv) == (EXPECT) && \
1158 (sv = cop_hints_fetchpvs(&PL_compiling, KEY)) && \
1159 SvIV(sv) == (EXPECT))
1160#define check_hint(KEY, EXPECT) \
1161 do { if (!hint_ok(KEY, EXPECT)) croak("fail"); } while(0)
1162 PL_hints |= HINT_LOCALIZE_HH;
1163 ENTER;
1164 SAVEHINTS();
1165 PL_hints &= HINT_INTEGER;
1166 store_hint("t0", 123);
1167 store_hint("t1", 456);
1168 if (PL_hints & HINT_INTEGER) croak("fail");
1169 check_hint("t0", 123); check_hint("t1", 456);
1170 ENTER;
1171 SAVEHINTS();
1172 if (PL_hints & HINT_INTEGER) croak("fail");
1173 check_hint("t0", 123); check_hint("t1", 456);
1174 PL_hints |= HINT_INTEGER;
1175 store_hint("t0", 321);
1176 if (!(PL_hints & HINT_INTEGER)) croak("fail");
1177 check_hint("t0", 321); check_hint("t1", 456);
1178 LEAVE;
1179 if (PL_hints & HINT_INTEGER) croak("fail");
1180 check_hint("t0", 123); check_hint("t1", 456);
1181 ENTER;
1182 SAVEHINTS();
1183 if (PL_hints & HINT_INTEGER) croak("fail");
1184 check_hint("t0", 123); check_hint("t1", 456);
1185 store_hint("t1", 654);
1186 if (PL_hints & HINT_INTEGER) croak("fail");
1187 check_hint("t0", 123); check_hint("t1", 654);
1188 LEAVE;
1189 if (PL_hints & HINT_INTEGER) croak("fail");
1190 check_hint("t0", 123); check_hint("t1", 456);
1191 LEAVE;
1192#undef store_hint
1193#undef hint_ok
1194#undef check_hint
1195
1196void
1197test_copyhints()
1198 PREINIT:
1199 HV *a, *b;
1200 CODE:
1201 PL_hints |= HINT_LOCALIZE_HH;
1202 ENTER;
1203 SAVEHINTS();
1204 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
1205 if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak("fail");
1206 a = newHVhv(GvHV(PL_hintgv));
1207 sv_2mortal((SV*)a);
1208 sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
1209 if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak("fail");
1210 b = hv_copy_hints_hv(a);
1211 sv_2mortal((SV*)b);
1212 sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
1213 if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 789) croak("fail");
1214 LEAVE;
1215
e2fe06dd
EB
1216BOOT:
1217 {
1218 HV* stash;
1219 SV** meth = NULL;
1220 CV* cv;
1221 stash = gv_stashpv("XS::APItest::TempLv", 0);
1222 if (stash)
1223 meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
1224 if (!meth)
1225 croak("lost method 'make_temp_mg_lv'");
1226 cv = GvCV(*meth);
1227 CvLVALUE_on(cv);
1228 }