This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add new test file to MANIFEST. Fix tests for threaded builds.
[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 = *svp;
452         if ((svp = hv_fetchs(params, "hash", 0)))
453             action = SvUV(*svp);
454
455         result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
456         if (!result) {
457             XSRETURN_EMPTY;
458         }
459         /* Force mg_get  */
460         RETVAL = newSVsv(HeVAL(result));
461         OUTPUT:
462         RETVAL
463
464 #endif
465
466 void
467 test_hv_free_ent()
468         PPCODE:
469         test_freeent(&Perl_hv_free_ent);
470         XSRETURN(4);
471
472 void
473 test_hv_delayfree_ent()
474         PPCODE:
475         test_freeent(&Perl_hv_delayfree_ent);
476         XSRETURN(4);
477
478 SV *
479 test_share_unshare_pvn(input)
480         PREINIT:
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
495
496 #if PERL_VERSION >= 9
497
498 bool
499 refcounted_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
512 SV *
513 refcounted_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         
526 #endif
527         
528 =pod
529
530 sub TIEHASH  { bless {}, $_[0] }
531 sub STORE    { $_[0]->{$_[1]} = $_[2] }
532 sub FETCH    { $_[0]->{$_[1]} }
533 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
534 sub NEXTKEY  { each %{$_[0]} }
535 sub EXISTS   { exists $_[0]->{$_[1]} }
536 sub DELETE   { delete $_[0]->{$_[1]} }
537 sub CLEAR    { %{$_[0]} = () }
538
539 =cut
540
541 MODULE = XS::APItest            PACKAGE = XS::APItest
542
543 PROTOTYPES: DISABLE
544
545 BOOT:
546 {
547     MY_CXT_INIT;
548     MY_CXT.i  = 99;
549     MY_CXT.sv = newSVpv("initial",0);
550 }                              
551
552 void
553 CLONE(...)
554     CODE:
555     MY_CXT_CLONE;
556     MY_CXT.sv = newSVpv("initial_clone",0);
557
558 void
559 print_double(val)
560         double val
561         CODE:
562         printf("%5.3f\n",val);
563
564 int
565 have_long_double()
566         CODE:
567 #ifdef HAS_LONG_DOUBLE
568         RETVAL = 1;
569 #else
570         RETVAL = 0;
571 #endif
572         OUTPUT:
573         RETVAL
574
575 void
576 print_long_double()
577         CODE:
578 #ifdef HAS_LONG_DOUBLE
579 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
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
588 void
589 print_int(val)
590         int val
591         CODE:
592         printf("%d\n",val);
593
594 void
595 print_long(val)
596         long val
597         CODE:
598         printf("%ld\n",val);
599
600 void
601 print_float(val)
602         float val
603         CODE:
604         printf("%5.3f\n",val);
605         
606 void
607 print_flush()
608         CODE:
609         fflush(stdout);
610
611 void
612 mpushp()
613         PPCODE:
614         EXTEND(SP, 3);
615         mPUSHp("one", 3);
616         mPUSHp("two", 3);
617         mPUSHp("three", 5);
618         XSRETURN(3);
619
620 void
621 mpushn()
622         PPCODE:
623         EXTEND(SP, 3);
624         mPUSHn(0.5);
625         mPUSHn(-0.25);
626         mPUSHn(0.125);
627         XSRETURN(3);
628
629 void
630 mpushi()
631         PPCODE:
632         EXTEND(SP, 3);
633         mPUSHi(-1);
634         mPUSHi(2);
635         mPUSHi(-3);
636         XSRETURN(3);
637
638 void
639 mpushu()
640         PPCODE:
641         EXTEND(SP, 3);
642         mPUSHu(1);
643         mPUSHu(2);
644         mPUSHu(3);
645         XSRETURN(3);
646
647 void
648 mxpushp()
649         PPCODE:
650         mXPUSHp("one", 3);
651         mXPUSHp("two", 3);
652         mXPUSHp("three", 5);
653         XSRETURN(3);
654
655 void
656 mxpushn()
657         PPCODE:
658         mXPUSHn(0.5);
659         mXPUSHn(-0.25);
660         mXPUSHn(0.125);
661         XSRETURN(3);
662
663 void
664 mxpushi()
665         PPCODE:
666         mXPUSHi(-1);
667         mXPUSHi(2);
668         mXPUSHi(-3);
669         XSRETURN(3);
670
671 void
672 mxpushu()
673         PPCODE:
674         mXPUSHu(1);
675         mXPUSHu(2);
676         mXPUSHu(3);
677         XSRETURN(3);
678
679
680 void
681 call_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
697 void
698 call_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
714 void
715 call_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
731 void
732 eval_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
744 void
745 eval_pv(p, croak_on_error)
746     const char* p
747     I32 croak_on_error
748     PPCODE:
749         PUTBACK;
750         EXTEND(SP, 1);
751         PUSHs(eval_pv(p, croak_on_error));
752
753 void
754 require_pv(pv)
755     const char* pv
756     PPCODE:
757         PUTBACK;
758         require_pv(pv);
759
760 int
761 apitest_exception(throw_e)
762     int throw_e
763     OUTPUT:
764         RETVAL
765
766 void
767 mycroak(sv)
768     SV* sv
769     CODE:
770     if (SvOK(sv)) {
771         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
772     }
773     else {
774         Perl_croak(aTHX_ NULL);
775     }
776
777 SV*
778 strtab()
779    CODE:
780    RETVAL = newRV_inc((SV*)PL_strtab);
781    OUTPUT:
782    RETVAL
783
784 int
785 my_cxt_getint()
786     CODE:
787         dMY_CXT;
788         RETVAL = my_cxt_getint_p(aMY_CXT);
789     OUTPUT:
790         RETVAL
791
792 void
793 my_cxt_setint(i)
794     int i;
795     CODE:
796         dMY_CXT;
797         my_cxt_setint_p(aMY_CXT_ i);
798
799 void
800 my_cxt_getsv(how)
801     bool how;
802     PPCODE:
803         EXTEND(SP, 1);
804         ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
805         XSRETURN(1);
806
807 void
808 my_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);
815
816 bool
817 sv_setsv_cow_hashkey_core()
818
819 bool
820 sv_setsv_cow_hashkey_notcore()
821
822 void
823 rmagical_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
842 void
843 rmagical_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
854 void
855 DPeek (sv)
856     SV   *sv
857
858   PPCODE:
859     ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
860     XSRETURN (1);
861
862 void
863 BEGIN()
864     CODE:
865         sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
866
867 void
868 CHECK()
869     CODE:
870         sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
871
872 void
873 UNITCHECK()
874     CODE:
875         sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
876
877 void
878 INIT()
879     CODE:
880         sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
881
882 void
883 END()
884     CODE:
885         sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));