This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Perl_unsharepvn() was no longer being used in core, and changes to
[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()
34 {
35 #ifdef PERL_IMPLICIT_CONTEXT
36     dTHX;
37     dMY_CXT_INTERP(my_perl);
38 #else
39     dMY_CXT;
40 #endif
41     return MY_CXT.sv;
42 }
43
44 void
45 my_cxt_setsv_p(SV* sv _pMY_CXT)
46 {
47     MY_CXT.sv = sv;
48 }
49
50
51 /* from exception.c */
52 int exception(int);
53
54 /* A routine to test hv_delayfree_ent
55    (which itself is tested by testing on hv_free_ent  */
56
57 typedef void (freeent_function)(pTHX_ HV *, register HE *);
58
59 void
60 test_freeent(freeent_function *f) {
61     dTHX;
62     dSP;
63     HV *test_hash = newHV();
64     HE *victim;
65     SV *test_scalar;
66     U32 results[4];
67     int i;
68
69 #ifdef PURIFY
70     victim = (HE*)safemalloc(sizeof(HE));
71 #else
72     /* Storing then deleting something should ensure that a hash entry is
73        available.  */
74     hv_store(test_hash, "", 0, &PL_sv_yes, 0);
75     hv_delete(test_hash, "", 0, 0);
76
77     /* We need to "inline" new_he here as it's static, and the functions we
78        test expect to be able to call del_HE on the HE  */
79     if (!PL_body_roots[HE_SVSLOT])
80         croak("PL_he_root is 0");
81     victim = PL_body_roots[HE_SVSLOT];
82     PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
83 #endif
84
85     victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
86
87     test_scalar = newSV(0);
88     SvREFCNT_inc(test_scalar);
89     HeVAL(victim) = test_scalar;
90
91     /* Need this little game else we free the temps on the return stack.  */
92     results[0] = SvREFCNT(test_scalar);
93     SAVETMPS;
94     results[1] = SvREFCNT(test_scalar);
95     f(aTHX_ test_hash, victim);
96     results[2] = SvREFCNT(test_scalar);
97     FREETMPS;
98     results[3] = SvREFCNT(test_scalar);
99
100     i = 0;
101     do {
102         mPUSHu(results[i]);
103     } while (++i < sizeof(results)/sizeof(results[0]));
104
105     /* Goodbye to our extra reference.  */
106     SvREFCNT_dec(test_scalar);
107 }
108
109 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
110
111 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
112
113 bool
114 exists(hash, key_sv)
115         PREINIT:
116         STRLEN len;
117         const char *key;
118         INPUT:
119         HV *hash
120         SV *key_sv
121         CODE:
122         key = SvPV(key_sv, len);
123         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
124         OUTPUT:
125         RETVAL
126
127 SV *
128 delete(hash, key_sv)
129         PREINIT:
130         STRLEN len;
131         const char *key;
132         INPUT:
133         HV *hash
134         SV *key_sv
135         CODE:
136         key = SvPV(key_sv, len);
137         /* It's already mortal, so need to increase reference count.  */
138         RETVAL = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), 0));
139         OUTPUT:
140         RETVAL
141
142 SV *
143 store_ent(hash, key, value)
144         PREINIT:
145         SV *copy;
146         HE *result;
147         INPUT:
148         HV *hash
149         SV *key
150         SV *value
151         CODE:
152         copy = newSV(0);
153         result = hv_store_ent(hash, key, copy, 0);
154         SvSetMagicSV(copy, value);
155         if (!result) {
156             SvREFCNT_dec(copy);
157             XSRETURN_EMPTY;
158         }
159         /* It's about to become mortal, so need to increase reference count.
160          */
161         RETVAL = SvREFCNT_inc(HeVAL(result));
162         OUTPUT:
163         RETVAL
164
165
166 SV *
167 store(hash, key_sv, value)
168         PREINIT:
169         STRLEN len;
170         const char *key;
171         SV *copy;
172         SV **result;
173         INPUT:
174         HV *hash
175         SV *key_sv
176         SV *value
177         CODE:
178         key = SvPV(key_sv, len);
179         copy = newSV(0);
180         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
181         SvSetMagicSV(copy, value);
182         if (!result) {
183             SvREFCNT_dec(copy);
184             XSRETURN_EMPTY;
185         }
186         /* It's about to become mortal, so need to increase reference count.
187          */
188         RETVAL = SvREFCNT_inc(*result);
189         OUTPUT:
190         RETVAL
191
192
193 SV *
194 fetch(hash, key_sv)
195         PREINIT:
196         STRLEN len;
197         const char *key;
198         SV **result;
199         INPUT:
200         HV *hash
201         SV *key_sv
202         CODE:
203         key = SvPV(key_sv, len);
204         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
205         if (!result) {
206             XSRETURN_EMPTY;
207         }
208         /* Force mg_get  */
209         RETVAL = newSVsv(*result);
210         OUTPUT:
211         RETVAL
212
213 void
214 test_hv_free_ent()
215         PPCODE:
216         test_freeent(&Perl_hv_free_ent);
217         XSRETURN(4);
218
219 void
220 test_hv_delayfree_ent()
221         PPCODE:
222         test_freeent(&Perl_hv_delayfree_ent);
223         XSRETURN(4);
224
225 SV *
226 test_share_unshare_pvn(input)
227         PREINIT:
228         SV *output;
229         STRLEN len;
230         U32 hash;
231         char *pvx;
232         char *p;
233         INPUT:
234         SV *input
235         CODE:
236         pvx = SvPV(input, len);
237         PERL_HASH(hash, pvx, len);
238         p = sharepvn(pvx, len, hash);
239         RETVAL = newSVpvn(p, len);
240         unsharepvn(p, len, hash);
241         OUTPUT:
242         RETVAL
243         
244 =pod
245
246 sub TIEHASH  { bless {}, $_[0] }
247 sub STORE    { $_[0]->{$_[1]} = $_[2] }
248 sub FETCH    { $_[0]->{$_[1]} }
249 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
250 sub NEXTKEY  { each %{$_[0]} }
251 sub EXISTS   { exists $_[0]->{$_[1]} }
252 sub DELETE   { delete $_[0]->{$_[1]} }
253 sub CLEAR    { %{$_[0]} = () }
254
255 =cut
256
257 MODULE = XS::APItest            PACKAGE = XS::APItest
258
259 PROTOTYPES: DISABLE
260
261 BOOT:
262 {
263     MY_CXT_INIT;
264     MY_CXT.i  = 99;
265     MY_CXT.sv = newSVpv("initial",0);
266 }                              
267
268 void
269 CLONE(...)
270     CODE:
271     MY_CXT_CLONE;
272     MY_CXT.sv = newSVpv("initial_clone",0);
273
274 void
275 print_double(val)
276         double val
277         CODE:
278         printf("%5.3f\n",val);
279
280 int
281 have_long_double()
282         CODE:
283 #ifdef HAS_LONG_DOUBLE
284         RETVAL = 1;
285 #else
286         RETVAL = 0;
287 #endif
288         OUTPUT:
289         RETVAL
290
291 void
292 print_long_double()
293         CODE:
294 #ifdef HAS_LONG_DOUBLE
295 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
296         long double val = 7.0;
297         printf("%5.3" PERL_PRIfldbl "\n",val);
298 #   else
299         double val = 7.0;
300         printf("%5.3f\n",val);
301 #   endif
302 #endif
303
304 void
305 print_int(val)
306         int val
307         CODE:
308         printf("%d\n",val);
309
310 void
311 print_long(val)
312         long val
313         CODE:
314         printf("%ld\n",val);
315
316 void
317 print_float(val)
318         float val
319         CODE:
320         printf("%5.3f\n",val);
321         
322 void
323 print_flush()
324         CODE:
325         fflush(stdout);
326
327 void
328 mpushp()
329         PPCODE:
330         EXTEND(SP, 3);
331         mPUSHp("one", 3);
332         mPUSHp("two", 3);
333         mPUSHp("three", 5);
334         XSRETURN(3);
335
336 void
337 mpushn()
338         PPCODE:
339         EXTEND(SP, 3);
340         mPUSHn(0.5);
341         mPUSHn(-0.25);
342         mPUSHn(0.125);
343         XSRETURN(3);
344
345 void
346 mpushi()
347         PPCODE:
348         EXTEND(SP, 3);
349         mPUSHi(-1);
350         mPUSHi(2);
351         mPUSHi(-3);
352         XSRETURN(3);
353
354 void
355 mpushu()
356         PPCODE:
357         EXTEND(SP, 3);
358         mPUSHu(1);
359         mPUSHu(2);
360         mPUSHu(3);
361         XSRETURN(3);
362
363 void
364 mxpushp()
365         PPCODE:
366         mXPUSHp("one", 3);
367         mXPUSHp("two", 3);
368         mXPUSHp("three", 5);
369         XSRETURN(3);
370
371 void
372 mxpushn()
373         PPCODE:
374         mXPUSHn(0.5);
375         mXPUSHn(-0.25);
376         mXPUSHn(0.125);
377         XSRETURN(3);
378
379 void
380 mxpushi()
381         PPCODE:
382         mXPUSHi(-1);
383         mXPUSHi(2);
384         mXPUSHi(-3);
385         XSRETURN(3);
386
387 void
388 mxpushu()
389         PPCODE:
390         mXPUSHu(1);
391         mXPUSHu(2);
392         mXPUSHu(3);
393         XSRETURN(3);
394
395
396 void
397 call_sv(sv, flags, ...)
398     SV* sv
399     I32 flags
400     PREINIT:
401         I32 i;
402     PPCODE:
403         for (i=0; i<items-2; i++)
404             ST(i) = ST(i+2); /* pop first two args */
405         PUSHMARK(SP);
406         SP += items - 2;
407         PUTBACK;
408         i = call_sv(sv, flags);
409         SPAGAIN;
410         EXTEND(SP, 1);
411         PUSHs(sv_2mortal(newSViv(i)));
412
413 void
414 call_pv(subname, flags, ...)
415     char* subname
416     I32 flags
417     PREINIT:
418         I32 i;
419     PPCODE:
420         for (i=0; i<items-2; i++)
421             ST(i) = ST(i+2); /* pop first two args */
422         PUSHMARK(SP);
423         SP += items - 2;
424         PUTBACK;
425         i = call_pv(subname, flags);
426         SPAGAIN;
427         EXTEND(SP, 1);
428         PUSHs(sv_2mortal(newSViv(i)));
429
430 void
431 call_method(methname, flags, ...)
432     char* methname
433     I32 flags
434     PREINIT:
435         I32 i;
436     PPCODE:
437         for (i=0; i<items-2; i++)
438             ST(i) = ST(i+2); /* pop first two args */
439         PUSHMARK(SP);
440         SP += items - 2;
441         PUTBACK;
442         i = call_method(methname, flags);
443         SPAGAIN;
444         EXTEND(SP, 1);
445         PUSHs(sv_2mortal(newSViv(i)));
446
447 void
448 eval_sv(sv, flags)
449     SV* sv
450     I32 flags
451     PREINIT:
452         I32 i;
453     PPCODE:
454         PUTBACK;
455         i = eval_sv(sv, flags);
456         SPAGAIN;
457         EXTEND(SP, 1);
458         PUSHs(sv_2mortal(newSViv(i)));
459
460 void
461 eval_pv(p, croak_on_error)
462     const char* p
463     I32 croak_on_error
464     PPCODE:
465         PUTBACK;
466         EXTEND(SP, 1);
467         PUSHs(eval_pv(p, croak_on_error));
468
469 void
470 require_pv(pv)
471     const char* pv
472     PPCODE:
473         PUTBACK;
474         require_pv(pv);
475
476 int
477 exception(throw_e)
478     int throw_e
479     OUTPUT:
480         RETVAL
481
482 void
483 mycroak(sv)
484     SV* sv
485     CODE:
486     if (SvOK(sv)) {
487         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
488     }
489     else {
490         Perl_croak(aTHX_ NULL);
491     }
492
493 SV*
494 strtab()
495    CODE:
496    RETVAL = newRV_inc((SV*)PL_strtab);
497    OUTPUT:
498    RETVAL
499
500 int
501 my_cxt_getint()
502     CODE:
503         dMY_CXT;
504         RETVAL = my_cxt_getint_p(aMY_CXT);
505     OUTPUT:
506         RETVAL
507
508 void
509 my_cxt_setint(i)
510     int i;
511     CODE:
512         dMY_CXT;
513         my_cxt_setint_p(aMY_CXT_ i);
514
515 void
516 my_cxt_getsv()
517     PPCODE:
518         EXTEND(SP, 1);
519         ST(0) = my_cxt_getsv_interp();
520         XSRETURN(1);
521
522 void
523 my_cxt_setsv(sv)
524     SV *sv;
525     CODE:
526         dMY_CXT;
527         SvREFCNT_dec(MY_CXT.sv);
528         my_cxt_setsv_p(sv _aMY_CXT);
529         SvREFCNT_inc(sv);