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
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*
33my_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
85ce96a1
DM
44void
45my_cxt_setsv_p(SV* sv _pMY_CXT)
46{
47 MY_CXT.sv = sv;
48}
49
50
9b5c3821
MHM
51/* from exception.c */
52int exception(int);
0314122a 53
2dc92170
NC
54/* A routine to test hv_delayfree_ent
55 (which itself is tested by testing on hv_free_ent */
56
57typedef void (freeent_function)(pTHX_ HV *, register HE *);
58
59void
60test_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
8afd2d2e
NC
69#ifdef PURIFY
70 victim = (HE*)safemalloc(sizeof(HE));
71#else
2dc92170
NC
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 */
6a93a7e5 79 if (!PL_body_roots[HE_SVSLOT])
2dc92170 80 croak("PL_he_root is 0");
6a93a7e5
NC
81 victim = PL_body_roots[HE_SVSLOT];
82 PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
8afd2d2e 83#endif
2dc92170
NC
84
85 victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
86
87 test_scalar = newSV(0);
88 SvREFCNT_inc(test_scalar);
de616631 89 HeVAL(victim) = test_scalar;
2dc92170
NC
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
0314122a
NC
109MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
110
028f8eaa
MHM
111#define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
112
0314122a
NC
113bool
114exists(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);
028f8eaa 123 RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
0314122a
NC
124 OUTPUT:
125 RETVAL
126
b60cf05a
NC
127SV *
128delete(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. */
028f8eaa 138 RETVAL = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), 0));
b60cf05a
NC
139 OUTPUT:
140 RETVAL
141
142SV *
858117f8
NC
143store_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
166SV *
b60cf05a
NC
167store(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);
028f8eaa 180 result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
858117f8 181 SvSetMagicSV(copy, value);
b60cf05a
NC
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
193SV *
194fetch(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);
028f8eaa 204 result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
b60cf05a
NC
205 if (!result) {
206 XSRETURN_EMPTY;
207 }
208 /* Force mg_get */
209 RETVAL = newSVsv(*result);
210 OUTPUT:
211 RETVAL
2dc92170 212
439efdfe 213void
2dc92170
NC
214test_hv_free_ent()
215 PPCODE:
216 test_freeent(&Perl_hv_free_ent);
217 XSRETURN(4);
218
439efdfe 219void
2dc92170
NC
220test_hv_delayfree_ent()
221 PPCODE:
222 test_freeent(&Perl_hv_delayfree_ent);
223 XSRETURN(4);
35ab5632
NC
224
225SV *
226test_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
0314122a
NC
244=pod
245
246sub TIEHASH { bless {}, $_[0] }
247sub STORE { $_[0]->{$_[1]} = $_[2] }
248sub FETCH { $_[0]->{$_[1]} }
249sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
250sub NEXTKEY { each %{$_[0]} }
251sub EXISTS { exists $_[0]->{$_[1]} }
252sub DELETE { delete $_[0]->{$_[1]} }
253sub CLEAR { %{$_[0]} = () }
254
255=cut
256
3e61d65a
JH
257MODULE = XS::APItest PACKAGE = XS::APItest
258
259PROTOTYPES: DISABLE
260
85ce96a1
DM
261BOOT:
262{
263 MY_CXT_INIT;
264 MY_CXT.i = 99;
265 MY_CXT.sv = newSVpv("initial",0);
266}
267
268void
269CLONE(...)
270 CODE:
271 MY_CXT_CLONE;
272 MY_CXT.sv = newSVpv("initial_clone",0);
273
3e61d65a
JH
274void
275print_double(val)
276 double val
277 CODE:
278 printf("%5.3f\n",val);
279
280int
281have_long_double()
282 CODE:
283#ifdef HAS_LONG_DOUBLE
284 RETVAL = 1;
285#else
286 RETVAL = 0;
287#endif
cabb36f0
CN
288 OUTPUT:
289 RETVAL
3e61d65a
JH
290
291void
292print_long_double()
293 CODE:
294#ifdef HAS_LONG_DOUBLE
fc0bf671 295# if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
3e61d65a
JH
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
304void
3e61d65a
JH
305print_int(val)
306 int val
307 CODE:
308 printf("%d\n",val);
309
310void
311print_long(val)
312 long val
313 CODE:
314 printf("%ld\n",val);
315
316void
317print_float(val)
318 float val
319 CODE:
320 printf("%5.3f\n",val);
9d911683
NIS
321
322void
323print_flush()
324 CODE:
325 fflush(stdout);
d4b90eee
SH
326
327void
328mpushp()
329 PPCODE:
330 EXTEND(SP, 3);
331 mPUSHp("one", 3);
332 mPUSHp("two", 3);
333 mPUSHp("three", 5);
334 XSRETURN(3);
335
336void
337mpushn()
338 PPCODE:
339 EXTEND(SP, 3);
340 mPUSHn(0.5);
341 mPUSHn(-0.25);
342 mPUSHn(0.125);
343 XSRETURN(3);
344
345void
346mpushi()
347 PPCODE:
348 EXTEND(SP, 3);
d75b63cf
MHM
349 mPUSHi(-1);
350 mPUSHi(2);
351 mPUSHi(-3);
d4b90eee
SH
352 XSRETURN(3);
353
354void
355mpushu()
356 PPCODE:
357 EXTEND(SP, 3);
d75b63cf
MHM
358 mPUSHu(1);
359 mPUSHu(2);
360 mPUSHu(3);
d4b90eee
SH
361 XSRETURN(3);
362
363void
364mxpushp()
365 PPCODE:
366 mXPUSHp("one", 3);
367 mXPUSHp("two", 3);
368 mXPUSHp("three", 5);
369 XSRETURN(3);
370
371void
372mxpushn()
373 PPCODE:
374 mXPUSHn(0.5);
375 mXPUSHn(-0.25);
376 mXPUSHn(0.125);
377 XSRETURN(3);
378
379void
380mxpushi()
381 PPCODE:
d75b63cf
MHM
382 mXPUSHi(-1);
383 mXPUSHi(2);
384 mXPUSHi(-3);
d4b90eee
SH
385 XSRETURN(3);
386
387void
388mxpushu()
389 PPCODE:
d75b63cf
MHM
390 mXPUSHu(1);
391 mXPUSHu(2);
392 mXPUSHu(3);
d4b90eee 393 XSRETURN(3);
d1f347d7
DM
394
395
396void
397call_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
413void
414call_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
430void
431call_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
447void
448eval_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
b8e65a9b 460void
d1f347d7
DM
461eval_pv(p, croak_on_error)
462 const char* p
463 I32 croak_on_error
d1f347d7
DM
464 PPCODE:
465 PUTBACK;
466 EXTEND(SP, 1);
467 PUSHs(eval_pv(p, croak_on_error));
468
469void
470require_pv(pv)
471 const char* pv
d1f347d7
DM
472 PPCODE:
473 PUTBACK;
474 require_pv(pv);
475
0ca3a874
MHM
476int
477exception(throw_e)
478 int throw_e
479 OUTPUT:
480 RETVAL
d1f347d7 481
ef469b03 482void
7e7a3dfc
GA
483mycroak(sv)
484 SV* sv
ef469b03 485 CODE:
7e7a3dfc
GA
486 if (SvOK(sv)) {
487 Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
488 }
489 else {
490 Perl_croak(aTHX_ NULL);
491 }
5d2b1485
NC
492
493SV*
494strtab()
495 CODE:
496 RETVAL = newRV_inc((SV*)PL_strtab);
497 OUTPUT:
498 RETVAL
85ce96a1
DM
499
500int
501my_cxt_getint()
502 CODE:
503 dMY_CXT;
504 RETVAL = my_cxt_getint_p(aMY_CXT);
505 OUTPUT:
506 RETVAL
507
508void
509my_cxt_setint(i)
510 int i;
511 CODE:
512 dMY_CXT;
513 my_cxt_setint_p(aMY_CXT_ i);
514
515void
516my_cxt_getsv()
517 PPCODE:
85ce96a1 518 EXTEND(SP, 1);
f16dd614 519 ST(0) = my_cxt_getsv_interp();
85ce96a1
DM
520 XSRETURN(1);
521
522void
523my_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);