This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pv_uni_display () omitted backslash in output string
[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)))
451 val = *svp;
452 if ((svp = hv_fetchs(params, "hash", 0)))
453 action = SvUV(*svp);
454
a75fcbca 455 result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
6b4de907
NC
456 if (!result) {
457 XSRETURN_EMPTY;
458 }
459 /* Force mg_get */
460 RETVAL = newSVsv(HeVAL(result));
461 OUTPUT:
462 RETVAL
463
9568a123
NC
464#endif
465
439efdfe 466void
2dc92170
NC
467test_hv_free_ent()
468 PPCODE:
469 test_freeent(&Perl_hv_free_ent);
470 XSRETURN(4);
471
439efdfe 472void
2dc92170
NC
473test_hv_delayfree_ent()
474 PPCODE:
475 test_freeent(&Perl_hv_delayfree_ent);
476 XSRETURN(4);
35ab5632
NC
477
478SV *
479test_share_unshare_pvn(input)
480 PREINIT:
35ab5632
NC
481 STRLEN len;
482 U32 hash;
483 char *pvx;
484 char *p;
485 INPUT:
486 SV *input
487 CODE:
488 pvx = SvPV(input, len);
489 PERL_HASH(hash, pvx, len);
490 p = sharepvn(pvx, len, hash);
491 RETVAL = newSVpvn(p, len);
492 unsharepvn(p, len, hash);
493 OUTPUT:
494 RETVAL
d8c5b3c5 495
9568a123
NC
496#if PERL_VERSION >= 9
497
d8c5b3c5
NC
498bool
499refcounted_he_exists(key, level=0)
500 SV *key
501 IV level
502 CODE:
503 if (level) {
504 croak("level must be zero, not %"IVdf, level);
505 }
506 RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
507 key, NULL, 0, 0, 0)
508 != &PL_sv_placeholder);
509 OUTPUT:
510 RETVAL
511
d8c5b3c5
NC
512SV *
513refcounted_he_fetch(key, level=0)
514 SV *key
515 IV level
516 CODE:
517 if (level) {
518 croak("level must be zero, not %"IVdf, level);
519 }
520 RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
521 NULL, 0, 0, 0);
522 SvREFCNT_inc(RETVAL);
523 OUTPUT:
524 RETVAL
525
9568a123 526#endif
35ab5632 527
0314122a
NC
528=pod
529
530sub TIEHASH { bless {}, $_[0] }
531sub STORE { $_[0]->{$_[1]} = $_[2] }
532sub FETCH { $_[0]->{$_[1]} }
533sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
534sub NEXTKEY { each %{$_[0]} }
535sub EXISTS { exists $_[0]->{$_[1]} }
536sub DELETE { delete $_[0]->{$_[1]} }
537sub CLEAR { %{$_[0]} = () }
538
539=cut
540
3e61d65a
JH
541MODULE = XS::APItest PACKAGE = XS::APItest
542
543PROTOTYPES: DISABLE
544
85ce96a1
DM
545BOOT:
546{
547 MY_CXT_INIT;
548 MY_CXT.i = 99;
549 MY_CXT.sv = newSVpv("initial",0);
550}
551
552void
553CLONE(...)
554 CODE:
555 MY_CXT_CLONE;
556 MY_CXT.sv = newSVpv("initial_clone",0);
557
3e61d65a
JH
558void
559print_double(val)
560 double val
561 CODE:
562 printf("%5.3f\n",val);
563
564int
565have_long_double()
566 CODE:
567#ifdef HAS_LONG_DOUBLE
568 RETVAL = 1;
569#else
570 RETVAL = 0;
571#endif
cabb36f0
CN
572 OUTPUT:
573 RETVAL
3e61d65a
JH
574
575void
576print_long_double()
577 CODE:
578#ifdef HAS_LONG_DOUBLE
fc0bf671 579# if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
3e61d65a
JH
580 long double val = 7.0;
581 printf("%5.3" PERL_PRIfldbl "\n",val);
582# else
583 double val = 7.0;
584 printf("%5.3f\n",val);
585# endif
586#endif
587
588void
3e61d65a
JH
589print_int(val)
590 int val
591 CODE:
592 printf("%d\n",val);
593
594void
595print_long(val)
596 long val
597 CODE:
598 printf("%ld\n",val);
599
600void
601print_float(val)
602 float val
603 CODE:
604 printf("%5.3f\n",val);
9d911683
NIS
605
606void
607print_flush()
608 CODE:
609 fflush(stdout);
d4b90eee
SH
610
611void
612mpushp()
613 PPCODE:
614 EXTEND(SP, 3);
615 mPUSHp("one", 3);
616 mPUSHp("two", 3);
617 mPUSHp("three", 5);
618 XSRETURN(3);
619
620void
621mpushn()
622 PPCODE:
623 EXTEND(SP, 3);
624 mPUSHn(0.5);
625 mPUSHn(-0.25);
626 mPUSHn(0.125);
627 XSRETURN(3);
628
629void
630mpushi()
631 PPCODE:
632 EXTEND(SP, 3);
d75b63cf
MHM
633 mPUSHi(-1);
634 mPUSHi(2);
635 mPUSHi(-3);
d4b90eee
SH
636 XSRETURN(3);
637
638void
639mpushu()
640 PPCODE:
641 EXTEND(SP, 3);
d75b63cf
MHM
642 mPUSHu(1);
643 mPUSHu(2);
644 mPUSHu(3);
d4b90eee
SH
645 XSRETURN(3);
646
647void
648mxpushp()
649 PPCODE:
650 mXPUSHp("one", 3);
651 mXPUSHp("two", 3);
652 mXPUSHp("three", 5);
653 XSRETURN(3);
654
655void
656mxpushn()
657 PPCODE:
658 mXPUSHn(0.5);
659 mXPUSHn(-0.25);
660 mXPUSHn(0.125);
661 XSRETURN(3);
662
663void
664mxpushi()
665 PPCODE:
d75b63cf
MHM
666 mXPUSHi(-1);
667 mXPUSHi(2);
668 mXPUSHi(-3);
d4b90eee
SH
669 XSRETURN(3);
670
671void
672mxpushu()
673 PPCODE:
d75b63cf
MHM
674 mXPUSHu(1);
675 mXPUSHu(2);
676 mXPUSHu(3);
d4b90eee 677 XSRETURN(3);
d1f347d7
DM
678
679
680void
681call_sv(sv, flags, ...)
682 SV* sv
683 I32 flags
684 PREINIT:
685 I32 i;
686 PPCODE:
687 for (i=0; i<items-2; i++)
688 ST(i) = ST(i+2); /* pop first two args */
689 PUSHMARK(SP);
690 SP += items - 2;
691 PUTBACK;
692 i = call_sv(sv, flags);
693 SPAGAIN;
694 EXTEND(SP, 1);
695 PUSHs(sv_2mortal(newSViv(i)));
696
697void
698call_pv(subname, flags, ...)
699 char* subname
700 I32 flags
701 PREINIT:
702 I32 i;
703 PPCODE:
704 for (i=0; i<items-2; i++)
705 ST(i) = ST(i+2); /* pop first two args */
706 PUSHMARK(SP);
707 SP += items - 2;
708 PUTBACK;
709 i = call_pv(subname, flags);
710 SPAGAIN;
711 EXTEND(SP, 1);
712 PUSHs(sv_2mortal(newSViv(i)));
713
714void
715call_method(methname, flags, ...)
716 char* methname
717 I32 flags
718 PREINIT:
719 I32 i;
720 PPCODE:
721 for (i=0; i<items-2; i++)
722 ST(i) = ST(i+2); /* pop first two args */
723 PUSHMARK(SP);
724 SP += items - 2;
725 PUTBACK;
726 i = call_method(methname, flags);
727 SPAGAIN;
728 EXTEND(SP, 1);
729 PUSHs(sv_2mortal(newSViv(i)));
730
731void
732eval_sv(sv, flags)
733 SV* sv
734 I32 flags
735 PREINIT:
736 I32 i;
737 PPCODE:
738 PUTBACK;
739 i = eval_sv(sv, flags);
740 SPAGAIN;
741 EXTEND(SP, 1);
742 PUSHs(sv_2mortal(newSViv(i)));
743
b8e65a9b 744void
d1f347d7
DM
745eval_pv(p, croak_on_error)
746 const char* p
747 I32 croak_on_error
d1f347d7
DM
748 PPCODE:
749 PUTBACK;
750 EXTEND(SP, 1);
751 PUSHs(eval_pv(p, croak_on_error));
752
753void
754require_pv(pv)
755 const char* pv
d1f347d7
DM
756 PPCODE:
757 PUTBACK;
758 require_pv(pv);
759
0ca3a874 760int
7a646707 761apitest_exception(throw_e)
0ca3a874
MHM
762 int throw_e
763 OUTPUT:
764 RETVAL
d1f347d7 765
ef469b03 766void
7e7a3dfc
GA
767mycroak(sv)
768 SV* sv
ef469b03 769 CODE:
7e7a3dfc
GA
770 if (SvOK(sv)) {
771 Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
772 }
773 else {
774 Perl_croak(aTHX_ NULL);
775 }
5d2b1485
NC
776
777SV*
778strtab()
779 CODE:
780 RETVAL = newRV_inc((SV*)PL_strtab);
781 OUTPUT:
782 RETVAL
85ce96a1
DM
783
784int
785my_cxt_getint()
786 CODE:
787 dMY_CXT;
788 RETVAL = my_cxt_getint_p(aMY_CXT);
789 OUTPUT:
790 RETVAL
791
792void
793my_cxt_setint(i)
794 int i;
795 CODE:
796 dMY_CXT;
797 my_cxt_setint_p(aMY_CXT_ i);
798
799void
9568a123
NC
800my_cxt_getsv(how)
801 bool how;
85ce96a1 802 PPCODE:
85ce96a1 803 EXTEND(SP, 1);
9568a123 804 ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
85ce96a1
DM
805 XSRETURN(1);
806
807void
808my_cxt_setsv(sv)
809 SV *sv;
810 CODE:
811 dMY_CXT;
812 SvREFCNT_dec(MY_CXT.sv);
813 my_cxt_setsv_p(sv _aMY_CXT);
814 SvREFCNT_inc(sv);
34482cd6
NC
815
816bool
817sv_setsv_cow_hashkey_core()
818
819bool
820sv_setsv_cow_hashkey_notcore()
84ac5fd7
NC
821
822void
218787bd
VP
823rmagical_cast(sv, type)
824 SV *sv;
825 SV *type;
826 PREINIT:
827 struct ufuncs uf;
828 PPCODE:
829 if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
830 sv = SvRV(sv);
831 if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
832 uf.uf_val = rmagical_a_dummy;
833 uf.uf_set = NULL;
834 uf.uf_index = 0;
835 if (SvTRUE(type)) { /* b */
836 sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
837 } else { /* a */
838 sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
839 }
840 XSRETURN_YES;
841
842void
843rmagical_flags(sv)
844 SV *sv;
845 PPCODE:
846 if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
847 sv = SvRV(sv);
848 EXTEND(SP, 3);
849 mXPUSHu(SvFLAGS(sv) & SVs_GMG);
850 mXPUSHu(SvFLAGS(sv) & SVs_SMG);
851 mXPUSHu(SvFLAGS(sv) & SVs_RMG);
852 XSRETURN(3);
853
854void
84ac5fd7
NC
855BEGIN()
856 CODE:
857 sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
858
859void
860CHECK()
861 CODE:
862 sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
863
864void
865UNITCHECK()
866 CODE:
0932863f 867 sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
84ac5fd7
NC
868
869void
870INIT()
871 CODE:
872 sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
873
874void
875END()
876 CODE:
877 sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));