This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
create SV leak test infrastructure
[perl5.git] / ext / XS-APItest / APItest.xs
1 #define PERL_IN_XS_APITEST
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "XSUB.h"
5
6
7 /* for my_cxt tests */
8
9 #define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
10
11 typedef struct {
12     int i;
13     SV *sv;
14 } my_cxt_t;
15
16 START_MY_CXT
17
18 /* indirect functions to test the [pa]MY_CXT macros */
19
20 int
21 my_cxt_getint_p(pMY_CXT)
22 {
23     return MY_CXT.i;
24 }
25
26 void
27 my_cxt_setint_p(pMY_CXT_ int i)
28 {
29     MY_CXT.i = i;
30 }
31
32 SV*
33 my_cxt_getsv_interp_context(void)
34 {
35     dTHX;
36     dMY_CXT_INTERP(my_perl);
37     return MY_CXT.sv;
38 }
39
40 SV*
41 my_cxt_getsv_interp(void)
42 {
43     dMY_CXT;
44     return MY_CXT.sv;
45 }
46
47 void
48 my_cxt_setsv_p(SV* sv _pMY_CXT)
49 {
50     MY_CXT.sv = sv;
51 }
52
53
54 /* from exception.c */
55 int apitest_exception(int);
56
57 /* from core_or_not.inc */
58 bool sv_setsv_cow_hashkey_core(void);
59 bool sv_setsv_cow_hashkey_notcore(void);
60
61 /* A routine to test hv_delayfree_ent
62    (which itself is tested by testing on hv_free_ent  */
63
64 typedef void (freeent_function)(pTHX_ HV *, register HE *);
65
66 void
67 test_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
76 #ifdef PURIFY
77     victim = (HE*)safemalloc(sizeof(HE));
78 #else
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  */
86     if (!PL_body_roots[HE_SVSLOT])
87         croak("PL_he_root is 0");
88     victim = (HE*) PL_body_roots[HE_SVSLOT];
89     PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
90 #endif
91
92     victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
93
94     test_scalar = newSV(0);
95     SvREFCNT_inc(test_scalar);
96     HeVAL(victim) = test_scalar;
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
116
117 static I32
118 bitflip_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;
133                     UV chr = utf8_to_uvuni((U8 *)p, &len);
134                     new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32);
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
152 static I32
153 rot13_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
236 STATIC I32
237 rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
238     return 0;
239 }
240
241 STATIC MGVTBL rmagical_b = { 0 };
242
243 #include "const-c.inc"
244
245 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
246
247 INCLUDE: const-xs.inc
248
249 void
250 rot13_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
262 void
263 bitflip_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
275 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
276
277 bool
278 exists(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);
287         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
288         OUTPUT:
289         RETVAL
290
291 bool
292 exists_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
302 SV *
303 delete(hash, key_sv, flags = 0)
304         PREINIT:
305         STRLEN len;
306         const char *key;
307         INPUT:
308         HV *hash
309         SV *key_sv
310         I32 flags;
311         CODE:
312         key = SvPV(key_sv, len);
313         /* It's already mortal, so need to increase reference count.  */
314         RETVAL
315             = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
316         OUTPUT:
317         RETVAL
318
319 SV *
320 delete_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));
328         OUTPUT:
329         RETVAL
330
331 SV *
332 store_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
354 SV *
355 store(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);
368         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
369         SvSetMagicSV(copy, value);
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
380 SV *
381 fetch_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
396
397 SV *
398 fetch(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);
408         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
409         if (!result) {
410             XSRETURN_EMPTY;
411         }
412         /* Force mg_get  */
413         RETVAL = newSVsv(*result);
414         OUTPUT:
415         RETVAL
416
417 #if defined (hv_common)
418
419 SV *
420 common(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 = newSVsv(*svp);
452         if ((svp = hv_fetchs(params, "hash", 0)))
453             hash = SvUV(*svp);
454
455         if ((svp = hv_fetchs(params, "hash_pv", 0))) {
456             PERL_HASH(hash, key, klen);
457         }
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         }
463
464         result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
465         if (!result) {
466             XSRETURN_EMPTY;
467         }
468         /* Force mg_get  */
469         RETVAL = newSVsv(HeVAL(result));
470         OUTPUT:
471         RETVAL
472
473 #endif
474
475 void
476 test_hv_free_ent()
477         PPCODE:
478         test_freeent(&Perl_hv_free_ent);
479         XSRETURN(4);
480
481 void
482 test_hv_delayfree_ent()
483         PPCODE:
484         test_freeent(&Perl_hv_delayfree_ent);
485         XSRETURN(4);
486
487 SV *
488 test_share_unshare_pvn(input)
489         PREINIT:
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
504
505 #if PERL_VERSION >= 9
506
507 bool
508 refcounted_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
521 SV *
522 refcounted_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         
535 #endif
536         
537 =pod
538
539 sub TIEHASH  { bless {}, $_[0] }
540 sub STORE    { $_[0]->{$_[1]} = $_[2] }
541 sub FETCH    { $_[0]->{$_[1]} }
542 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
543 sub NEXTKEY  { each %{$_[0]} }
544 sub EXISTS   { exists $_[0]->{$_[1]} }
545 sub DELETE   { delete $_[0]->{$_[1]} }
546 sub CLEAR    { %{$_[0]} = () }
547
548 =cut
549
550 MODULE = XS::APItest            PACKAGE = XS::APItest
551
552 PROTOTYPES: DISABLE
553
554 BOOT:
555 {
556     MY_CXT_INIT;
557     MY_CXT.i  = 99;
558     MY_CXT.sv = newSVpv("initial",0);
559 }                              
560
561 void
562 CLONE(...)
563     CODE:
564     MY_CXT_CLONE;
565     MY_CXT.sv = newSVpv("initial_clone",0);
566
567 void
568 print_double(val)
569         double val
570         CODE:
571         printf("%5.3f\n",val);
572
573 int
574 have_long_double()
575         CODE:
576 #ifdef HAS_LONG_DOUBLE
577         RETVAL = 1;
578 #else
579         RETVAL = 0;
580 #endif
581         OUTPUT:
582         RETVAL
583
584 void
585 print_long_double()
586         CODE:
587 #ifdef HAS_LONG_DOUBLE
588 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
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
597 void
598 print_int(val)
599         int val
600         CODE:
601         printf("%d\n",val);
602
603 void
604 print_long(val)
605         long val
606         CODE:
607         printf("%ld\n",val);
608
609 void
610 print_float(val)
611         float val
612         CODE:
613         printf("%5.3f\n",val);
614         
615 void
616 print_flush()
617         CODE:
618         fflush(stdout);
619
620 void
621 mpushp()
622         PPCODE:
623         EXTEND(SP, 3);
624         mPUSHp("one", 3);
625         mPUSHp("two", 3);
626         mPUSHp("three", 5);
627         XSRETURN(3);
628
629 void
630 mpushn()
631         PPCODE:
632         EXTEND(SP, 3);
633         mPUSHn(0.5);
634         mPUSHn(-0.25);
635         mPUSHn(0.125);
636         XSRETURN(3);
637
638 void
639 mpushi()
640         PPCODE:
641         EXTEND(SP, 3);
642         mPUSHi(-1);
643         mPUSHi(2);
644         mPUSHi(-3);
645         XSRETURN(3);
646
647 void
648 mpushu()
649         PPCODE:
650         EXTEND(SP, 3);
651         mPUSHu(1);
652         mPUSHu(2);
653         mPUSHu(3);
654         XSRETURN(3);
655
656 void
657 mxpushp()
658         PPCODE:
659         mXPUSHp("one", 3);
660         mXPUSHp("two", 3);
661         mXPUSHp("three", 5);
662         XSRETURN(3);
663
664 void
665 mxpushn()
666         PPCODE:
667         mXPUSHn(0.5);
668         mXPUSHn(-0.25);
669         mXPUSHn(0.125);
670         XSRETURN(3);
671
672 void
673 mxpushi()
674         PPCODE:
675         mXPUSHi(-1);
676         mXPUSHi(2);
677         mXPUSHi(-3);
678         XSRETURN(3);
679
680 void
681 mxpushu()
682         PPCODE:
683         mXPUSHu(1);
684         mXPUSHu(2);
685         mXPUSHu(3);
686         XSRETURN(3);
687
688
689 void
690 call_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
706 void
707 call_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
723 void
724 call_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
740 void
741 eval_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
753 void
754 eval_pv(p, croak_on_error)
755     const char* p
756     I32 croak_on_error
757     PPCODE:
758         PUTBACK;
759         EXTEND(SP, 1);
760         PUSHs(eval_pv(p, croak_on_error));
761
762 void
763 require_pv(pv)
764     const char* pv
765     PPCODE:
766         PUTBACK;
767         require_pv(pv);
768
769 int
770 apitest_exception(throw_e)
771     int throw_e
772     OUTPUT:
773         RETVAL
774
775 void
776 mycroak(sv)
777     SV* sv
778     CODE:
779     if (SvOK(sv)) {
780         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
781     }
782     else {
783         Perl_croak(aTHX_ NULL);
784     }
785
786 SV*
787 strtab()
788    CODE:
789    RETVAL = newRV_inc((SV*)PL_strtab);
790    OUTPUT:
791    RETVAL
792
793 int
794 my_cxt_getint()
795     CODE:
796         dMY_CXT;
797         RETVAL = my_cxt_getint_p(aMY_CXT);
798     OUTPUT:
799         RETVAL
800
801 void
802 my_cxt_setint(i)
803     int i;
804     CODE:
805         dMY_CXT;
806         my_cxt_setint_p(aMY_CXT_ i);
807
808 void
809 my_cxt_getsv(how)
810     bool how;
811     PPCODE:
812         EXTEND(SP, 1);
813         ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
814         XSRETURN(1);
815
816 void
817 my_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);
824
825 bool
826 sv_setsv_cow_hashkey_core()
827
828 bool
829 sv_setsv_cow_hashkey_notcore()
830
831 void
832 rmagical_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
851 void
852 rmagical_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
863 void
864 DPeek (sv)
865     SV   *sv
866
867   PPCODE:
868     ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
869     XSRETURN (1);
870
871 void
872 BEGIN()
873     CODE:
874         sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
875
876 void
877 CHECK()
878     CODE:
879         sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
880
881 void
882 UNITCHECK()
883     CODE:
884         sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
885
886 void
887 INIT()
888     CODE:
889         sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
890
891 void
892 END()
893     CODE:
894         sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
895
896 void
897 utf16_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) {
915             utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
916         } else {
917             utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
918         }
919         SvCUR_set(dest, got);
920         SvPVX(dest)[got] = '\0';
921         SvPOK_on(dest);
922         ST(0) = dest;
923         XSRETURN(1);
924
925 U32
926 pmflag (flag, before = 0)
927         int flag
928         U32 before
929    CODE:
930         pmflag(&before, flag);
931         RETVAL = before;
932     OUTPUT:
933         RETVAL
934
935 void
936 my_exit(int exitcode)
937         PPCODE:
938         my_exit(exitcode);
939
940 I32
941 sv_count()
942         CODE:
943             RETVAL = PL_sv_count;
944         OUTPUT:
945             RETVAL