This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[DOC PATCH] $^X isn't necessarily argv[0]
[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     victim->hent_val = 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 =pod
226
227 sub TIEHASH  { bless {}, $_[0] }
228 sub STORE    { $_[0]->{$_[1]} = $_[2] }
229 sub FETCH    { $_[0]->{$_[1]} }
230 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
231 sub NEXTKEY  { each %{$_[0]} }
232 sub EXISTS   { exists $_[0]->{$_[1]} }
233 sub DELETE   { delete $_[0]->{$_[1]} }
234 sub CLEAR    { %{$_[0]} = () }
235
236 =cut
237
238 MODULE = XS::APItest            PACKAGE = XS::APItest
239
240 PROTOTYPES: DISABLE
241
242 BOOT:
243 {
244     MY_CXT_INIT;
245     MY_CXT.i  = 99;
246     MY_CXT.sv = newSVpv("initial",0);
247 }                              
248
249 void
250 CLONE(...)
251     CODE:
252     MY_CXT_CLONE;
253     MY_CXT.sv = newSVpv("initial_clone",0);
254
255 void
256 print_double(val)
257         double val
258         CODE:
259         printf("%5.3f\n",val);
260
261 int
262 have_long_double()
263         CODE:
264 #ifdef HAS_LONG_DOUBLE
265         RETVAL = 1;
266 #else
267         RETVAL = 0;
268 #endif
269         OUTPUT:
270         RETVAL
271
272 void
273 print_long_double()
274         CODE:
275 #ifdef HAS_LONG_DOUBLE
276 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
277         long double val = 7.0;
278         printf("%5.3" PERL_PRIfldbl "\n",val);
279 #   else
280         double val = 7.0;
281         printf("%5.3f\n",val);
282 #   endif
283 #endif
284
285 void
286 print_int(val)
287         int val
288         CODE:
289         printf("%d\n",val);
290
291 void
292 print_long(val)
293         long val
294         CODE:
295         printf("%ld\n",val);
296
297 void
298 print_float(val)
299         float val
300         CODE:
301         printf("%5.3f\n",val);
302         
303 void
304 print_flush()
305         CODE:
306         fflush(stdout);
307
308 void
309 mpushp()
310         PPCODE:
311         EXTEND(SP, 3);
312         mPUSHp("one", 3);
313         mPUSHp("two", 3);
314         mPUSHp("three", 5);
315         XSRETURN(3);
316
317 void
318 mpushn()
319         PPCODE:
320         EXTEND(SP, 3);
321         mPUSHn(0.5);
322         mPUSHn(-0.25);
323         mPUSHn(0.125);
324         XSRETURN(3);
325
326 void
327 mpushi()
328         PPCODE:
329         EXTEND(SP, 3);
330         mPUSHi(-1);
331         mPUSHi(2);
332         mPUSHi(-3);
333         XSRETURN(3);
334
335 void
336 mpushu()
337         PPCODE:
338         EXTEND(SP, 3);
339         mPUSHu(1);
340         mPUSHu(2);
341         mPUSHu(3);
342         XSRETURN(3);
343
344 void
345 mxpushp()
346         PPCODE:
347         mXPUSHp("one", 3);
348         mXPUSHp("two", 3);
349         mXPUSHp("three", 5);
350         XSRETURN(3);
351
352 void
353 mxpushn()
354         PPCODE:
355         mXPUSHn(0.5);
356         mXPUSHn(-0.25);
357         mXPUSHn(0.125);
358         XSRETURN(3);
359
360 void
361 mxpushi()
362         PPCODE:
363         mXPUSHi(-1);
364         mXPUSHi(2);
365         mXPUSHi(-3);
366         XSRETURN(3);
367
368 void
369 mxpushu()
370         PPCODE:
371         mXPUSHu(1);
372         mXPUSHu(2);
373         mXPUSHu(3);
374         XSRETURN(3);
375
376
377 void
378 call_sv(sv, flags, ...)
379     SV* sv
380     I32 flags
381     PREINIT:
382         I32 i;
383     PPCODE:
384         for (i=0; i<items-2; i++)
385             ST(i) = ST(i+2); /* pop first two args */
386         PUSHMARK(SP);
387         SP += items - 2;
388         PUTBACK;
389         i = call_sv(sv, flags);
390         SPAGAIN;
391         EXTEND(SP, 1);
392         PUSHs(sv_2mortal(newSViv(i)));
393
394 void
395 call_pv(subname, flags, ...)
396     char* subname
397     I32 flags
398     PREINIT:
399         I32 i;
400     PPCODE:
401         for (i=0; i<items-2; i++)
402             ST(i) = ST(i+2); /* pop first two args */
403         PUSHMARK(SP);
404         SP += items - 2;
405         PUTBACK;
406         i = call_pv(subname, flags);
407         SPAGAIN;
408         EXTEND(SP, 1);
409         PUSHs(sv_2mortal(newSViv(i)));
410
411 void
412 call_method(methname, flags, ...)
413     char* methname
414     I32 flags
415     PREINIT:
416         I32 i;
417     PPCODE:
418         for (i=0; i<items-2; i++)
419             ST(i) = ST(i+2); /* pop first two args */
420         PUSHMARK(SP);
421         SP += items - 2;
422         PUTBACK;
423         i = call_method(methname, flags);
424         SPAGAIN;
425         EXTEND(SP, 1);
426         PUSHs(sv_2mortal(newSViv(i)));
427
428 void
429 eval_sv(sv, flags)
430     SV* sv
431     I32 flags
432     PREINIT:
433         I32 i;
434     PPCODE:
435         PUTBACK;
436         i = eval_sv(sv, flags);
437         SPAGAIN;
438         EXTEND(SP, 1);
439         PUSHs(sv_2mortal(newSViv(i)));
440
441 void
442 eval_pv(p, croak_on_error)
443     const char* p
444     I32 croak_on_error
445     PPCODE:
446         PUTBACK;
447         EXTEND(SP, 1);
448         PUSHs(eval_pv(p, croak_on_error));
449
450 void
451 require_pv(pv)
452     const char* pv
453     PPCODE:
454         PUTBACK;
455         require_pv(pv);
456
457 int
458 exception(throw_e)
459     int throw_e
460     OUTPUT:
461         RETVAL
462
463 void
464 mycroak(pv)
465     const char* pv
466     CODE:
467     Perl_croak(aTHX_ "%s", pv);
468
469 SV*
470 strtab()
471    CODE:
472    RETVAL = newRV_inc((SV*)PL_strtab);
473    OUTPUT:
474    RETVAL
475
476 int
477 my_cxt_getint()
478     CODE:
479         dMY_CXT;
480         RETVAL = my_cxt_getint_p(aMY_CXT);
481     OUTPUT:
482         RETVAL
483
484 void
485 my_cxt_setint(i)
486     int i;
487     CODE:
488         dMY_CXT;
489         my_cxt_setint_p(aMY_CXT_ i);
490
491 void
492 my_cxt_getsv()
493     PPCODE:
494         EXTEND(SP, 1);
495         ST(0) = my_cxt_getsv_interp();
496         XSRETURN(1);
497
498 void
499 my_cxt_setsv(sv)
500     SV *sv;
501     CODE:
502         dMY_CXT;
503         SvREFCNT_dec(MY_CXT.sv);
504         my_cxt_setsv_p(sv _aMY_CXT);
505         SvREFCNT_inc(sv);