This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Wrap PL_blockhooks in an API function.
[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 */
52db365a 274 if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) {
03569ecf 275 av_clear(MY_CXT.cscav);
52db365a 276 }
03569ecf
BM
277
278}
279
55289a74
NC
280#include "const-c.inc"
281
0314122a
NC
282MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
283
55289a74
NC
284INCLUDE: const-xs.inc
285
b54b4831
NC
286void
287rot13_hash(hash)
288 HV *hash
289 CODE:
290 {
291 struct ufuncs uf;
292 uf.uf_val = rot13_key;
293 uf.uf_set = 0;
294 uf.uf_index = 0;
295
296 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
297 }
298
53c40a8f
NC
299void
300bitflip_hash(hash)
301 HV *hash
302 CODE:
303 {
304 struct ufuncs uf;
305 uf.uf_val = bitflip_key;
306 uf.uf_set = 0;
307 uf.uf_index = 0;
308
309 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
310 }
311
028f8eaa
MHM
312#define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
313
0314122a
NC
314bool
315exists(hash, key_sv)
316 PREINIT:
317 STRLEN len;
318 const char *key;
319 INPUT:
320 HV *hash
321 SV *key_sv
322 CODE:
323 key = SvPV(key_sv, len);
028f8eaa 324 RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
0314122a
NC
325 OUTPUT:
326 RETVAL
327
bdee33e4
NC
328bool
329exists_ent(hash, key_sv)
330 PREINIT:
331 INPUT:
332 HV *hash
333 SV *key_sv
334 CODE:
335 RETVAL = hv_exists_ent(hash, key_sv, 0);
336 OUTPUT:
337 RETVAL
338
b60cf05a 339SV *
55289a74 340delete(hash, key_sv, flags = 0)
b60cf05a
NC
341 PREINIT:
342 STRLEN len;
343 const char *key;
344 INPUT:
345 HV *hash
346 SV *key_sv
55289a74 347 I32 flags;
b60cf05a
NC
348 CODE:
349 key = SvPV(key_sv, len);
350 /* It's already mortal, so need to increase reference count. */
55289a74
NC
351 RETVAL
352 = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
353 OUTPUT:
354 RETVAL
355
356SV *
357delete_ent(hash, key_sv, flags = 0)
358 INPUT:
359 HV *hash
360 SV *key_sv
361 I32 flags;
362 CODE:
363 /* It's already mortal, so need to increase reference count. */
364 RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
b60cf05a
NC
365 OUTPUT:
366 RETVAL
367
368SV *
858117f8
NC
369store_ent(hash, key, value)
370 PREINIT:
371 SV *copy;
372 HE *result;
373 INPUT:
374 HV *hash
375 SV *key
376 SV *value
377 CODE:
378 copy = newSV(0);
379 result = hv_store_ent(hash, key, copy, 0);
380 SvSetMagicSV(copy, value);
381 if (!result) {
382 SvREFCNT_dec(copy);
383 XSRETURN_EMPTY;
384 }
385 /* It's about to become mortal, so need to increase reference count.
386 */
387 RETVAL = SvREFCNT_inc(HeVAL(result));
388 OUTPUT:
389 RETVAL
390
858117f8 391SV *
b60cf05a
NC
392store(hash, key_sv, value)
393 PREINIT:
394 STRLEN len;
395 const char *key;
396 SV *copy;
397 SV **result;
398 INPUT:
399 HV *hash
400 SV *key_sv
401 SV *value
402 CODE:
403 key = SvPV(key_sv, len);
404 copy = newSV(0);
028f8eaa 405 result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
858117f8 406 SvSetMagicSV(copy, value);
b60cf05a
NC
407 if (!result) {
408 SvREFCNT_dec(copy);
409 XSRETURN_EMPTY;
410 }
411 /* It's about to become mortal, so need to increase reference count.
412 */
413 RETVAL = SvREFCNT_inc(*result);
414 OUTPUT:
415 RETVAL
416
bdee33e4
NC
417SV *
418fetch_ent(hash, key_sv)
419 PREINIT:
420 HE *result;
421 INPUT:
422 HV *hash
423 SV *key_sv
424 CODE:
425 result = hv_fetch_ent(hash, key_sv, 0, 0);
426 if (!result) {
427 XSRETURN_EMPTY;
428 }
429 /* Force mg_get */
430 RETVAL = newSVsv(HeVAL(result));
431 OUTPUT:
432 RETVAL
b60cf05a
NC
433
434SV *
435fetch(hash, key_sv)
436 PREINIT:
437 STRLEN len;
438 const char *key;
439 SV **result;
440 INPUT:
441 HV *hash
442 SV *key_sv
443 CODE:
444 key = SvPV(key_sv, len);
028f8eaa 445 result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
b60cf05a
NC
446 if (!result) {
447 XSRETURN_EMPTY;
448 }
449 /* Force mg_get */
450 RETVAL = newSVsv(*result);
451 OUTPUT:
452 RETVAL
2dc92170 453
9568a123
NC
454#if defined (hv_common)
455
6b4de907
NC
456SV *
457common(params)
458 INPUT:
459 HV *params
460 PREINIT:
461 HE *result;
462 HV *hv = NULL;
463 SV *keysv = NULL;
464 const char *key = NULL;
465 STRLEN klen = 0;
466 int flags = 0;
467 int action = 0;
468 SV *val = NULL;
469 U32 hash = 0;
470 SV **svp;
471 CODE:
472 if ((svp = hv_fetchs(params, "hv", 0))) {
473 SV *const rv = *svp;
474 if (!SvROK(rv))
475 croak("common passed a non-reference for parameter hv");
476 hv = (HV *)SvRV(rv);
477 }
478 if ((svp = hv_fetchs(params, "keysv", 0)))
479 keysv = *svp;
480 if ((svp = hv_fetchs(params, "keypv", 0))) {
481 key = SvPV_const(*svp, klen);
482 if (SvUTF8(*svp))
483 flags = HVhek_UTF8;
484 }
485 if ((svp = hv_fetchs(params, "action", 0)))
486 action = SvIV(*svp);
487 if ((svp = hv_fetchs(params, "val", 0)))
527df579 488 val = newSVsv(*svp);
6b4de907 489 if ((svp = hv_fetchs(params, "hash", 0)))
a44093a9 490 hash = SvUV(*svp);
6b4de907 491
527df579
NC
492 if ((svp = hv_fetchs(params, "hash_pv", 0))) {
493 PERL_HASH(hash, key, klen);
494 }
58ca560a
NC
495 if ((svp = hv_fetchs(params, "hash_sv", 0))) {
496 STRLEN len;
497 const char *const p = SvPV(keysv, len);
498 PERL_HASH(hash, p, len);
499 }
527df579 500
a75fcbca 501 result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
6b4de907
NC
502 if (!result) {
503 XSRETURN_EMPTY;
504 }
505 /* Force mg_get */
506 RETVAL = newSVsv(HeVAL(result));
507 OUTPUT:
508 RETVAL
509
9568a123
NC
510#endif
511
439efdfe 512void
2dc92170
NC
513test_hv_free_ent()
514 PPCODE:
515 test_freeent(&Perl_hv_free_ent);
516 XSRETURN(4);
517
439efdfe 518void
2dc92170
NC
519test_hv_delayfree_ent()
520 PPCODE:
521 test_freeent(&Perl_hv_delayfree_ent);
522 XSRETURN(4);
35ab5632
NC
523
524SV *
525test_share_unshare_pvn(input)
526 PREINIT:
35ab5632
NC
527 STRLEN len;
528 U32 hash;
529 char *pvx;
530 char *p;
531 INPUT:
532 SV *input
533 CODE:
534 pvx = SvPV(input, len);
535 PERL_HASH(hash, pvx, len);
536 p = sharepvn(pvx, len, hash);
537 RETVAL = newSVpvn(p, len);
538 unsharepvn(p, len, hash);
539 OUTPUT:
540 RETVAL
d8c5b3c5 541
9568a123
NC
542#if PERL_VERSION >= 9
543
d8c5b3c5
NC
544bool
545refcounted_he_exists(key, level=0)
546 SV *key
547 IV level
548 CODE:
549 if (level) {
550 croak("level must be zero, not %"IVdf, level);
551 }
552 RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
553 key, NULL, 0, 0, 0)
554 != &PL_sv_placeholder);
555 OUTPUT:
556 RETVAL
557
d8c5b3c5
NC
558SV *
559refcounted_he_fetch(key, level=0)
560 SV *key
561 IV level
562 CODE:
563 if (level) {
564 croak("level must be zero, not %"IVdf, level);
565 }
566 RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
567 NULL, 0, 0, 0);
568 SvREFCNT_inc(RETVAL);
569 OUTPUT:
570 RETVAL
571
9568a123 572#endif
35ab5632 573
0314122a
NC
574=pod
575
576sub TIEHASH { bless {}, $_[0] }
577sub STORE { $_[0]->{$_[1]} = $_[2] }
578sub FETCH { $_[0]->{$_[1]} }
579sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
580sub NEXTKEY { each %{$_[0]} }
581sub EXISTS { exists $_[0]->{$_[1]} }
582sub DELETE { delete $_[0]->{$_[1]} }
583sub CLEAR { %{$_[0]} = () }
584
585=cut
586
36c2b1d0
NC
587MODULE = XS::APItest::PtrTable PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
588
589void
590ptr_table_new(classname)
591const char * classname
592 PPCODE:
593 PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
594
595void
596DESTROY(table)
597XS::APItest::PtrTable table
598 CODE:
599 ptr_table_free(table);
600
601void
992b2363 602ptr_table_store(table, from, to)
36c2b1d0 603XS::APItest::PtrTable table
992b2363
NC
604SVREF from
605SVREF to
36c2b1d0 606 CODE:
992b2363 607 ptr_table_store(table, from, to);
36c2b1d0
NC
608
609UV
992b2363 610ptr_table_fetch(table, from)
36c2b1d0 611XS::APItest::PtrTable table
992b2363 612SVREF from
36c2b1d0 613 CODE:
992b2363 614 RETVAL = PTR2UV(ptr_table_fetch(table, from));
36c2b1d0
NC
615 OUTPUT:
616 RETVAL
617
618void
619ptr_table_split(table)
620XS::APItest::PtrTable table
621
622void
623ptr_table_clear(table)
624XS::APItest::PtrTable table
625
3e61d65a
JH
626MODULE = XS::APItest PACKAGE = XS::APItest
627
628PROTOTYPES: DISABLE
629
85ce96a1
DM
630BOOT:
631{
52db365a 632 BHK *bhk;
85ce96a1 633 MY_CXT_INIT;
03569ecf 634
85ce96a1
DM
635 MY_CXT.i = 99;
636 MY_CXT.sv = newSVpv("initial",0);
03569ecf
BM
637 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
638 GV_ADD, SVt_PVAV);
639 MY_CXT.cscav = GvAV(MY_CXT.cscgv);
640
52db365a
BM
641 Newxz(bhk, 1, BHK);
642 BhkENTRY_set(bhk, start, blockhook_start);
643 BhkENTRY_set(bhk, pre_end, blockhook_pre_end);
bb6c22e7 644 Perl_blockhook_register(aTHX_ bhk);
85ce96a1
DM
645}
646
647void
648CLONE(...)
649 CODE:
650 MY_CXT_CLONE;
651 MY_CXT.sv = newSVpv("initial_clone",0);
03569ecf
BM
652 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
653 GV_ADD, SVt_PVAV);
654 MY_CXT.cscav = NULL;
85ce96a1 655
3e61d65a
JH
656void
657print_double(val)
658 double val
659 CODE:
660 printf("%5.3f\n",val);
661
662int
663have_long_double()
664 CODE:
665#ifdef HAS_LONG_DOUBLE
666 RETVAL = 1;
667#else
668 RETVAL = 0;
669#endif
cabb36f0
CN
670 OUTPUT:
671 RETVAL
3e61d65a
JH
672
673void
674print_long_double()
675 CODE:
676#ifdef HAS_LONG_DOUBLE
fc0bf671 677# if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
3e61d65a
JH
678 long double val = 7.0;
679 printf("%5.3" PERL_PRIfldbl "\n",val);
680# else
681 double val = 7.0;
682 printf("%5.3f\n",val);
683# endif
684#endif
685
686void
3e61d65a
JH
687print_int(val)
688 int val
689 CODE:
690 printf("%d\n",val);
691
692void
693print_long(val)
694 long val
695 CODE:
696 printf("%ld\n",val);
697
698void
699print_float(val)
700 float val
701 CODE:
702 printf("%5.3f\n",val);
9d911683
NIS
703
704void
705print_flush()
706 CODE:
707 fflush(stdout);
d4b90eee
SH
708
709void
710mpushp()
711 PPCODE:
712 EXTEND(SP, 3);
713 mPUSHp("one", 3);
714 mPUSHp("two", 3);
715 mPUSHp("three", 5);
716 XSRETURN(3);
717
718void
719mpushn()
720 PPCODE:
721 EXTEND(SP, 3);
722 mPUSHn(0.5);
723 mPUSHn(-0.25);
724 mPUSHn(0.125);
725 XSRETURN(3);
726
727void
728mpushi()
729 PPCODE:
730 EXTEND(SP, 3);
d75b63cf
MHM
731 mPUSHi(-1);
732 mPUSHi(2);
733 mPUSHi(-3);
d4b90eee
SH
734 XSRETURN(3);
735
736void
737mpushu()
738 PPCODE:
739 EXTEND(SP, 3);
d75b63cf
MHM
740 mPUSHu(1);
741 mPUSHu(2);
742 mPUSHu(3);
d4b90eee
SH
743 XSRETURN(3);
744
745void
746mxpushp()
747 PPCODE:
748 mXPUSHp("one", 3);
749 mXPUSHp("two", 3);
750 mXPUSHp("three", 5);
751 XSRETURN(3);
752
753void
754mxpushn()
755 PPCODE:
756 mXPUSHn(0.5);
757 mXPUSHn(-0.25);
758 mXPUSHn(0.125);
759 XSRETURN(3);
760
761void
762mxpushi()
763 PPCODE:
d75b63cf
MHM
764 mXPUSHi(-1);
765 mXPUSHi(2);
766 mXPUSHi(-3);
d4b90eee
SH
767 XSRETURN(3);
768
769void
770mxpushu()
771 PPCODE:
d75b63cf
MHM
772 mXPUSHu(1);
773 mXPUSHu(2);
774 mXPUSHu(3);
d4b90eee 775 XSRETURN(3);
d1f347d7
DM
776
777
778void
779call_sv(sv, flags, ...)
780 SV* sv
781 I32 flags
782 PREINIT:
783 I32 i;
784 PPCODE:
785 for (i=0; i<items-2; i++)
786 ST(i) = ST(i+2); /* pop first two args */
787 PUSHMARK(SP);
788 SP += items - 2;
789 PUTBACK;
790 i = call_sv(sv, flags);
791 SPAGAIN;
792 EXTEND(SP, 1);
793 PUSHs(sv_2mortal(newSViv(i)));
794
795void
796call_pv(subname, flags, ...)
797 char* subname
798 I32 flags
799 PREINIT:
800 I32 i;
801 PPCODE:
802 for (i=0; i<items-2; i++)
803 ST(i) = ST(i+2); /* pop first two args */
804 PUSHMARK(SP);
805 SP += items - 2;
806 PUTBACK;
807 i = call_pv(subname, flags);
808 SPAGAIN;
809 EXTEND(SP, 1);
810 PUSHs(sv_2mortal(newSViv(i)));
811
812void
813call_method(methname, flags, ...)
814 char* methname
815 I32 flags
816 PREINIT:
817 I32 i;
818 PPCODE:
819 for (i=0; i<items-2; i++)
820 ST(i) = ST(i+2); /* pop first two args */
821 PUSHMARK(SP);
822 SP += items - 2;
823 PUTBACK;
824 i = call_method(methname, flags);
825 SPAGAIN;
826 EXTEND(SP, 1);
827 PUSHs(sv_2mortal(newSViv(i)));
828
829void
830eval_sv(sv, flags)
831 SV* sv
832 I32 flags
833 PREINIT:
834 I32 i;
835 PPCODE:
836 PUTBACK;
837 i = eval_sv(sv, flags);
838 SPAGAIN;
839 EXTEND(SP, 1);
840 PUSHs(sv_2mortal(newSViv(i)));
841
b8e65a9b 842void
d1f347d7
DM
843eval_pv(p, croak_on_error)
844 const char* p
845 I32 croak_on_error
d1f347d7
DM
846 PPCODE:
847 PUTBACK;
848 EXTEND(SP, 1);
849 PUSHs(eval_pv(p, croak_on_error));
850
851void
852require_pv(pv)
853 const char* pv
d1f347d7
DM
854 PPCODE:
855 PUTBACK;
856 require_pv(pv);
857
0ca3a874 858int
7a646707 859apitest_exception(throw_e)
0ca3a874
MHM
860 int throw_e
861 OUTPUT:
862 RETVAL
d1f347d7 863
ef469b03 864void
7e7a3dfc
GA
865mycroak(sv)
866 SV* sv
ef469b03 867 CODE:
7e7a3dfc
GA
868 if (SvOK(sv)) {
869 Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
870 }
871 else {
872 Perl_croak(aTHX_ NULL);
873 }
5d2b1485
NC
874
875SV*
876strtab()
877 CODE:
878 RETVAL = newRV_inc((SV*)PL_strtab);
879 OUTPUT:
880 RETVAL
85ce96a1
DM
881
882int
883my_cxt_getint()
884 CODE:
885 dMY_CXT;
886 RETVAL = my_cxt_getint_p(aMY_CXT);
887 OUTPUT:
888 RETVAL
889
890void
891my_cxt_setint(i)
892 int i;
893 CODE:
894 dMY_CXT;
895 my_cxt_setint_p(aMY_CXT_ i);
896
897void
9568a123
NC
898my_cxt_getsv(how)
899 bool how;
85ce96a1 900 PPCODE:
85ce96a1 901 EXTEND(SP, 1);
9568a123 902 ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
85ce96a1
DM
903 XSRETURN(1);
904
905void
906my_cxt_setsv(sv)
907 SV *sv;
908 CODE:
909 dMY_CXT;
910 SvREFCNT_dec(MY_CXT.sv);
911 my_cxt_setsv_p(sv _aMY_CXT);
912 SvREFCNT_inc(sv);
34482cd6
NC
913
914bool
915sv_setsv_cow_hashkey_core()
916
917bool
918sv_setsv_cow_hashkey_notcore()
84ac5fd7
NC
919
920void
218787bd
VP
921rmagical_cast(sv, type)
922 SV *sv;
923 SV *type;
924 PREINIT:
925 struct ufuncs uf;
926 PPCODE:
927 if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
928 sv = SvRV(sv);
929 if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
930 uf.uf_val = rmagical_a_dummy;
931 uf.uf_set = NULL;
932 uf.uf_index = 0;
933 if (SvTRUE(type)) { /* b */
934 sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
935 } else { /* a */
936 sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
937 }
938 XSRETURN_YES;
939
940void
941rmagical_flags(sv)
942 SV *sv;
943 PPCODE:
944 if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
945 sv = SvRV(sv);
946 EXTEND(SP, 3);
947 mXPUSHu(SvFLAGS(sv) & SVs_GMG);
948 mXPUSHu(SvFLAGS(sv) & SVs_SMG);
949 mXPUSHu(SvFLAGS(sv) & SVs_RMG);
950 XSRETURN(3);
951
952void
f9c17636
MB
953DPeek (sv)
954 SV *sv
955
956 PPCODE:
5b1f7359 957 ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
f9c17636
MB
958 XSRETURN (1);
959
960void
84ac5fd7
NC
961BEGIN()
962 CODE:
963 sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
964
965void
966CHECK()
967 CODE:
968 sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
969
970void
971UNITCHECK()
972 CODE:
0932863f 973 sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
84ac5fd7
NC
974
975void
976INIT()
977 CODE:
978 sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
979
980void
981END()
982 CODE:
983 sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
30685b56
NC
984
985void
986utf16_to_utf8 (sv, ...)
987 SV* sv
988 ALIAS:
989 utf16_to_utf8_reversed = 1
990 PREINIT:
991 STRLEN len;
992 U8 *source;
993 SV *dest;
994 I32 got; /* Gah, badly thought out APIs */
995 CODE:
996 source = (U8 *)SvPVbyte(sv, len);
997 /* Optionally only convert part of the buffer. */
998 if (items > 1) {
999 len = SvUV(ST(1));
1000 }
1001 /* Mortalise this right now, as we'll be testing croak()s */
1002 dest = sv_2mortal(newSV(len * 3 / 2 + 1));
1003 if (ix) {
25f2e844 1004 utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
30685b56 1005 } else {
25f2e844 1006 utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
30685b56
NC
1007 }
1008 SvCUR_set(dest, got);
1009 SvPVX(dest)[got] = '\0';
1010 SvPOK_on(dest);
1011 ST(0) = dest;
1012 XSRETURN(1);
879d0c72 1013
6bd7445c
GG
1014void
1015my_exit(int exitcode)
1016 PPCODE:
1017 my_exit(exitcode);
d97c33b5
DM
1018
1019I32
1020sv_count()
1021 CODE:
1022 RETVAL = PL_sv_count;
1023 OUTPUT:
1024 RETVAL