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