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