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