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