This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make sv_clear() non-recursive on RVs
[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
36c2b1d0
NC
6typedef SV *SVREF;
7typedef PTR_TBL_t *XS__APItest__PtrTable;
85ce96a1
DM
8
9/* for my_cxt tests */
10
11#define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
12
13typedef struct {
14 int i;
15 SV *sv;
03569ecf
BM
16 GV *cscgv;
17 AV *cscav;
13b6b3bc
BM
18 AV *bhkav;
19 bool bhk_record;
201c7e1f
FR
20 peep_t orig_peep;
21 peep_t orig_rpeep;
22 int peep_recording;
23 AV *peep_recorder;
24 AV *rpeep_recorder;
85ce96a1
DM
25} my_cxt_t;
26
27START_MY_CXT
28
29/* indirect functions to test the [pa]MY_CXT macros */
f16dd614 30
85ce96a1
DM
31int
32my_cxt_getint_p(pMY_CXT)
33{
34 return MY_CXT.i;
35}
f16dd614 36
85ce96a1
DM
37void
38my_cxt_setint_p(pMY_CXT_ int i)
39{
40 MY_CXT.i = i;
41}
f16dd614
DM
42
43SV*
9568a123 44my_cxt_getsv_interp_context(void)
f16dd614 45{
f16dd614
DM
46 dTHX;
47 dMY_CXT_INTERP(my_perl);
9568a123
NC
48 return MY_CXT.sv;
49}
50
51SV*
52my_cxt_getsv_interp(void)
53{
f16dd614 54 dMY_CXT;
f16dd614
DM
55 return MY_CXT.sv;
56}
57
85ce96a1
DM
58void
59my_cxt_setsv_p(SV* sv _pMY_CXT)
60{
61 MY_CXT.sv = sv;
62}
63
64
9b5c3821 65/* from exception.c */
7a646707 66int apitest_exception(int);
0314122a 67
ff66e713
SH
68/* from core_or_not.inc */
69bool sv_setsv_cow_hashkey_core(void);
70bool sv_setsv_cow_hashkey_notcore(void);
71
2dc92170
NC
72/* A routine to test hv_delayfree_ent
73 (which itself is tested by testing on hv_free_ent */
74
75typedef void (freeent_function)(pTHX_ HV *, register HE *);
76
77void
78test_freeent(freeent_function *f) {
79 dTHX;
80 dSP;
81 HV *test_hash = newHV();
82 HE *victim;
83 SV *test_scalar;
84 U32 results[4];
85 int i;
86
8afd2d2e
NC
87#ifdef PURIFY
88 victim = (HE*)safemalloc(sizeof(HE));
89#else
2dc92170
NC
90 /* Storing then deleting something should ensure that a hash entry is
91 available. */
92 hv_store(test_hash, "", 0, &PL_sv_yes, 0);
93 hv_delete(test_hash, "", 0, 0);
94
95 /* We need to "inline" new_he here as it's static, and the functions we
96 test expect to be able to call del_HE on the HE */
6a93a7e5 97 if (!PL_body_roots[HE_SVSLOT])
2dc92170 98 croak("PL_he_root is 0");
8a722a80 99 victim = (HE*) PL_body_roots[HE_SVSLOT];
6a93a7e5 100 PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
8afd2d2e 101#endif
2dc92170
NC
102
103 victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
104
105 test_scalar = newSV(0);
106 SvREFCNT_inc(test_scalar);
de616631 107 HeVAL(victim) = test_scalar;
2dc92170
NC
108
109 /* Need this little game else we free the temps on the return stack. */
110 results[0] = SvREFCNT(test_scalar);
111 SAVETMPS;
112 results[1] = SvREFCNT(test_scalar);
113 f(aTHX_ test_hash, victim);
114 results[2] = SvREFCNT(test_scalar);
115 FREETMPS;
116 results[3] = SvREFCNT(test_scalar);
117
118 i = 0;
119 do {
120 mPUSHu(results[i]);
121 } while (++i < sizeof(results)/sizeof(results[0]));
122
123 /* Goodbye to our extra reference. */
124 SvREFCNT_dec(test_scalar);
125}
126
b54b4831
NC
127
128static I32
53c40a8f
NC
129bitflip_key(pTHX_ IV action, SV *field) {
130 MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
131 SV *keysv;
132 if (mg && (keysv = mg->mg_obj)) {
133 STRLEN len;
134 const char *p = SvPV(keysv, len);
135
136 if (len) {
137 SV *newkey = newSV(len);
138 char *new_p = SvPVX(newkey);
139
140 if (SvUTF8(keysv)) {
141 const char *const end = p + len;
142 while (p < end) {
143 STRLEN len;
a75fcbca
SP
144 UV chr = utf8_to_uvuni((U8 *)p, &len);
145 new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32);
53c40a8f
NC
146 p += len;
147 }
148 SvUTF8_on(newkey);
149 } else {
150 while (len--)
151 *new_p++ = *p++ ^ 32;
152 }
153 *new_p = '\0';
154 SvCUR_set(newkey, SvCUR(keysv));
155 SvPOK_on(newkey);
156
157 mg->mg_obj = newkey;
158 }
159 }
160 return 0;
161}
162
163static I32
b54b4831
NC
164rot13_key(pTHX_ IV action, SV *field) {
165 MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
166 SV *keysv;
167 if (mg && (keysv = mg->mg_obj)) {
168 STRLEN len;
169 const char *p = SvPV(keysv, len);
170
171 if (len) {
172 SV *newkey = newSV(len);
173 char *new_p = SvPVX(newkey);
174
175 /* There's a deliberate fencepost error here to loop len + 1 times
176 to copy the trailing \0 */
177 do {
178 char new_c = *p++;
179 /* Try doing this cleanly and clearly in EBCDIC another way: */
180 switch (new_c) {
181 case 'A': new_c = 'N'; break;
182 case 'B': new_c = 'O'; break;
183 case 'C': new_c = 'P'; break;
184 case 'D': new_c = 'Q'; break;
185 case 'E': new_c = 'R'; break;
186 case 'F': new_c = 'S'; break;
187 case 'G': new_c = 'T'; break;
188 case 'H': new_c = 'U'; break;
189 case 'I': new_c = 'V'; break;
190 case 'J': new_c = 'W'; break;
191 case 'K': new_c = 'X'; break;
192 case 'L': new_c = 'Y'; break;
193 case 'M': new_c = 'Z'; break;
194 case 'N': new_c = 'A'; break;
195 case 'O': new_c = 'B'; break;
196 case 'P': new_c = 'C'; break;
197 case 'Q': new_c = 'D'; break;
198 case 'R': new_c = 'E'; break;
199 case 'S': new_c = 'F'; break;
200 case 'T': new_c = 'G'; break;
201 case 'U': new_c = 'H'; break;
202 case 'V': new_c = 'I'; break;
203 case 'W': new_c = 'J'; break;
204 case 'X': new_c = 'K'; break;
205 case 'Y': new_c = 'L'; break;
206 case 'Z': new_c = 'M'; break;
207 case 'a': new_c = 'n'; break;
208 case 'b': new_c = 'o'; break;
209 case 'c': new_c = 'p'; break;
210 case 'd': new_c = 'q'; break;
211 case 'e': new_c = 'r'; break;
212 case 'f': new_c = 's'; break;
213 case 'g': new_c = 't'; break;
214 case 'h': new_c = 'u'; break;
215 case 'i': new_c = 'v'; break;
216 case 'j': new_c = 'w'; break;
217 case 'k': new_c = 'x'; break;
218 case 'l': new_c = 'y'; break;
219 case 'm': new_c = 'z'; break;
220 case 'n': new_c = 'a'; break;
221 case 'o': new_c = 'b'; break;
222 case 'p': new_c = 'c'; break;
223 case 'q': new_c = 'd'; break;
224 case 'r': new_c = 'e'; break;
225 case 's': new_c = 'f'; break;
226 case 't': new_c = 'g'; break;
227 case 'u': new_c = 'h'; break;
228 case 'v': new_c = 'i'; break;
229 case 'w': new_c = 'j'; break;
230 case 'x': new_c = 'k'; break;
231 case 'y': new_c = 'l'; break;
232 case 'z': new_c = 'm'; break;
233 }
234 *new_p++ = new_c;
235 } while (len--);
236 SvCUR_set(newkey, SvCUR(keysv));
237 SvPOK_on(newkey);
238 if (SvUTF8(keysv))
239 SvUTF8_on(newkey);
240
241 mg->mg_obj = newkey;
242 }
243 }
244 return 0;
245}
246
218787bd
VP
247STATIC I32
248rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
249 return 0;
250}
251
252STATIC MGVTBL rmagical_b = { 0 };
253
03569ecf 254STATIC void
13b6b3bc 255blockhook_csc_start(pTHX_ int full)
03569ecf
BM
256{
257 dMY_CXT;
258 AV *const cur = GvAV(MY_CXT.cscgv);
259
260 SAVEGENERICSV(GvAV(MY_CXT.cscgv));
261
262 if (cur) {
263 I32 i;
d024465f 264 AV *const new_av = newAV();
03569ecf
BM
265
266 for (i = 0; i <= av_len(cur); i++) {
d024465f 267 av_store(new_av, i, newSVsv(*av_fetch(cur, i, 0)));
03569ecf
BM
268 }
269
d024465f 270 GvAV(MY_CXT.cscgv) = new_av;
03569ecf
BM
271 }
272}
273
274STATIC void
13b6b3bc 275blockhook_csc_pre_end(pTHX_ OP **o)
03569ecf
BM
276{
277 dMY_CXT;
278
279 /* if we hit the end of a scope we missed the start of, we need to
280 * unconditionally clear @CSC */
52db365a 281 if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) {
03569ecf 282 av_clear(MY_CXT.cscav);
52db365a 283 }
03569ecf
BM
284
285}
286
13b6b3bc
BM
287STATIC void
288blockhook_test_start(pTHX_ int full)
289{
290 dMY_CXT;
291 AV *av;
292
293 if (MY_CXT.bhk_record) {
294 av = newAV();
295 av_push(av, newSVpvs("start"));
296 av_push(av, newSViv(full));
297 av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
298 }
299}
300
301STATIC void
302blockhook_test_pre_end(pTHX_ OP **o)
303{
304 dMY_CXT;
305
306 if (MY_CXT.bhk_record)
307 av_push(MY_CXT.bhkav, newSVpvs("pre_end"));
308}
309
310STATIC void
311blockhook_test_post_end(pTHX_ OP **o)
312{
313 dMY_CXT;
314
315 if (MY_CXT.bhk_record)
316 av_push(MY_CXT.bhkav, newSVpvs("post_end"));
317}
318
319STATIC void
320blockhook_test_eval(pTHX_ OP *const o)
321{
322 dMY_CXT;
323 AV *av;
324
325 if (MY_CXT.bhk_record) {
326 av = newAV();
327 av_push(av, newSVpvs("eval"));
328 av_push(av, newSVpv(OP_NAME(o), 0));
329 av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
330 }
331}
332
333STATIC BHK bhk_csc, bhk_test;
334
201c7e1f
FR
335STATIC void
336my_peep (pTHX_ OP *o)
337{
338 dMY_CXT;
339
340 if (!o)
341 return;
342
343 MY_CXT.orig_peep(aTHX_ o);
344
345 if (!MY_CXT.peep_recording)
346 return;
347
348 for (; o; o = o->op_next) {
349 if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
350 av_push(MY_CXT.peep_recorder, newSVsv(cSVOPx_sv(o)));
351 }
352 }
353}
354
355STATIC void
356my_rpeep (pTHX_ OP *o)
357{
358 dMY_CXT;
359
360 if (!o)
361 return;
362
363 MY_CXT.orig_rpeep(aTHX_ o);
364
365 if (!MY_CXT.peep_recording)
366 return;
367
368 for (; o; o = o->op_next) {
369 if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
370 av_push(MY_CXT.rpeep_recorder, newSVsv(cSVOPx_sv(o)));
371 }
372 }
373}
374
83f8bb56
Z
375/** RPN keyword parser **/
376
377#define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
378#define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
379#define sv_is_string(sv) \
380 (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
381 (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
382
383static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv, *hintkey_stufftest_sv;
07ffcb73 384static SV *hintkey_swaptwostmts_sv, *hintkey_looprest_sv;
83f8bb56
Z
385static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
386
387/* low-level parser helpers */
388
389#define PL_bufptr (PL_parser->bufptr)
390#define PL_bufend (PL_parser->bufend)
391
392/* RPN parser */
393
394#define parse_var() THX_parse_var(aTHX)
395static OP *THX_parse_var(pTHX)
396{
397 char *s = PL_bufptr;
398 char *start = s;
399 PADOFFSET varpos;
400 OP *padop;
401 if(*s != '$') croak("RPN syntax error");
402 while(1) {
403 char c = *++s;
404 if(!isALNUM(c)) break;
405 }
406 if(s-start < 2) croak("RPN syntax error");
407 lex_read_to(s);
408 {
409 /* because pad_findmy() doesn't really use length yet */
410 SV *namesv = sv_2mortal(newSVpvn(start, s-start));
411 varpos = pad_findmy(SvPVX(namesv), s-start, 0);
412 }
413 if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
414 croak("RPN only supports \"my\" variables");
415 padop = newOP(OP_PADSV, 0);
416 padop->op_targ = varpos;
417 return padop;
418}
419
420#define push_rpn_item(o) \
421 (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop)
422#define pop_rpn_item() \
423 (!stack ? (croak("RPN stack underflow"), (OP*)NULL) : \
424 (tmpop = stack, stack = stack->op_sibling, \
425 tmpop->op_sibling = NULL, tmpop))
426
427#define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
428static OP *THX_parse_rpn_expr(pTHX)
429{
430 OP *stack = NULL, *tmpop;
431 while(1) {
432 I32 c;
433 lex_read_space(0);
434 c = lex_peek_unichar(0);
435 switch(c) {
436 case /*(*/')': case /*{*/'}': {
437 OP *result = pop_rpn_item();
438 if(stack) croak("RPN expression must return a single value");
439 return result;
440 } break;
441 case '0': case '1': case '2': case '3': case '4':
442 case '5': case '6': case '7': case '8': case '9': {
443 UV val = 0;
444 do {
445 lex_read_unichar(0);
446 val = 10*val + (c - '0');
447 c = lex_peek_unichar(0);
448 } while(c >= '0' && c <= '9');
449 push_rpn_item(newSVOP(OP_CONST, 0, newSVuv(val)));
450 } break;
451 case '$': {
452 push_rpn_item(parse_var());
453 } break;
454 case '+': {
455 OP *b = pop_rpn_item();
456 OP *a = pop_rpn_item();
457 lex_read_unichar(0);
458 push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
459 } break;
460 case '-': {
461 OP *b = pop_rpn_item();
462 OP *a = pop_rpn_item();
463 lex_read_unichar(0);
464 push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
465 } break;
466 case '*': {
467 OP *b = pop_rpn_item();
468 OP *a = pop_rpn_item();
469 lex_read_unichar(0);
470 push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
471 } break;
472 case '/': {
473 OP *b = pop_rpn_item();
474 OP *a = pop_rpn_item();
475 lex_read_unichar(0);
476 push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
477 } break;
478 case '%': {
479 OP *b = pop_rpn_item();
480 OP *a = pop_rpn_item();
481 lex_read_unichar(0);
482 push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
483 } break;
484 default: {
485 croak("RPN syntax error");
486 } break;
487 }
488 }
489}
490
491#define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
492static OP *THX_parse_keyword_rpn(pTHX)
493{
494 OP *op;
495 lex_read_space(0);
496 if(lex_peek_unichar(0) != '('/*)*/)
497 croak("RPN expression must be parenthesised");
498 lex_read_unichar(0);
499 op = parse_rpn_expr();
500 if(lex_peek_unichar(0) != /*(*/')')
501 croak("RPN expression must be parenthesised");
502 lex_read_unichar(0);
503 return op;
504}
505
506#define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
507static OP *THX_parse_keyword_calcrpn(pTHX)
508{
509 OP *varop, *exprop;
510 lex_read_space(0);
511 varop = parse_var();
512 lex_read_space(0);
513 if(lex_peek_unichar(0) != '{'/*}*/)
514 croak("RPN expression must be braced");
515 lex_read_unichar(0);
516 exprop = parse_rpn_expr();
517 if(lex_peek_unichar(0) != /*{*/'}')
518 croak("RPN expression must be braced");
519 lex_read_unichar(0);
520 return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
521}
522
523#define parse_keyword_stufftest() THX_parse_keyword_stufftest(aTHX)
524static OP *THX_parse_keyword_stufftest(pTHX)
525{
526 I32 c;
527 bool do_stuff;
528 lex_read_space(0);
529 do_stuff = lex_peek_unichar(0) == '+';
530 if(do_stuff) {
531 lex_read_unichar(0);
532 lex_read_space(0);
533 }
534 c = lex_peek_unichar(0);
535 if(c == ';') {
536 lex_read_unichar(0);
537 } else if(c != /*{*/'}') {
538 croak("syntax error");
539 }
540 if(do_stuff) lex_stuff_pvs(" ", 0);
541 return newOP(OP_NULL, 0);
542}
543
544#define parse_keyword_swaptwostmts() THX_parse_keyword_swaptwostmts(aTHX)
545static OP *THX_parse_keyword_swaptwostmts(pTHX)
546{
547 OP *a, *b;
548 a = parse_fullstmt(0);
549 b = parse_fullstmt(0);
550 if(a && b)
551 PL_hints |= HINT_BLOCK_SCOPE;
552 /* should use append_list(), but that's not part of the public API */
553 return !a ? b : !b ? a : newLISTOP(OP_LINESEQ, 0, b, a);
554}
555
07ffcb73
Z
556#define parse_keyword_looprest() THX_parse_keyword_looprest(aTHX)
557static OP *THX_parse_keyword_looprest(pTHX)
558{
559 I32 condline;
560 OP *body;
561 condline = CopLINE(PL_curcop);
562 body = parse_stmtseq(0);
563 return newWHILEOP(0, 1, NULL, condline, newSVOP(OP_CONST, 0, &PL_sv_yes),
564 body, NULL, 1);
565}
566
83f8bb56
Z
567/* plugin glue */
568
569#define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
570static int THX_keyword_active(pTHX_ SV *hintkey_sv)
571{
572 HE *he;
573 if(!GvHV(PL_hintgv)) return 0;
574 he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0,
575 SvSHARED_HASH(hintkey_sv));
576 return he && SvTRUE(HeVAL(he));
577}
578
579static int my_keyword_plugin(pTHX_
580 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
581{
582 if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) &&
583 keyword_active(hintkey_rpn_sv)) {
584 *op_ptr = parse_keyword_rpn();
585 return KEYWORD_PLUGIN_EXPR;
586 } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) &&
587 keyword_active(hintkey_calcrpn_sv)) {
588 *op_ptr = parse_keyword_calcrpn();
589 return KEYWORD_PLUGIN_STMT;
590 } else if(keyword_len == 9 && strnEQ(keyword_ptr, "stufftest", 9) &&
591 keyword_active(hintkey_stufftest_sv)) {
592 *op_ptr = parse_keyword_stufftest();
593 return KEYWORD_PLUGIN_STMT;
594 } else if(keyword_len == 12 &&
595 strnEQ(keyword_ptr, "swaptwostmts", 12) &&
596 keyword_active(hintkey_swaptwostmts_sv)) {
597 *op_ptr = parse_keyword_swaptwostmts();
598 return KEYWORD_PLUGIN_STMT;
07ffcb73
Z
599 } else if(keyword_len == 8 && strnEQ(keyword_ptr, "looprest", 8) &&
600 keyword_active(hintkey_looprest_sv)) {
601 *op_ptr = parse_keyword_looprest();
602 return KEYWORD_PLUGIN_STMT;
83f8bb56
Z
603 } else {
604 return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
605 }
606}
607
7b20c7cd 608XS(XS_XS__APItest__XSUB_XS_VERSION_undef);
f9cc56fa 609XS(XS_XS__APItest__XSUB_XS_VERSION_empty);
88c4b02d 610XS(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
7b20c7cd 611
55289a74
NC
612#include "const-c.inc"
613
ffe53d21 614MODULE = XS::APItest PACKAGE = XS::APItest
0314122a 615
55289a74
NC
616INCLUDE: const-xs.inc
617
ffe53d21
NC
618INCLUDE: numeric.xs
619
7b20c7cd
NC
620MODULE = XS::APItest PACKAGE = XS::APItest::XSUB
621
622BOOT:
623 newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
f9cc56fa 624 newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__);
88c4b02d 625 newXS("XS::APItest::XSUB::XS_APIVERSION_invalid", XS_XS__APItest__XSUB_XS_APIVERSION_invalid, __FILE__);
7b20c7cd
NC
626
627void
628XS_VERSION_defined(...)
629 PPCODE:
630 XS_VERSION_BOOTCHECK;
631 XSRETURN_EMPTY;
632
88c4b02d
NC
633void
634XS_APIVERSION_valid(...)
635 PPCODE:
636 XS_APIVERSION_BOOTCHECK;
637 XSRETURN_EMPTY;
638
ffe53d21
NC
639MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
640
b54b4831
NC
641void
642rot13_hash(hash)
643 HV *hash
644 CODE:
645 {
646 struct ufuncs uf;
647 uf.uf_val = rot13_key;
648 uf.uf_set = 0;
649 uf.uf_index = 0;
650
651 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
652 }
653
53c40a8f
NC
654void
655bitflip_hash(hash)
656 HV *hash
657 CODE:
658 {
659 struct ufuncs uf;
660 uf.uf_val = bitflip_key;
661 uf.uf_set = 0;
662 uf.uf_index = 0;
663
664 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
665 }
666
028f8eaa
MHM
667#define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
668
0314122a
NC
669bool
670exists(hash, key_sv)
671 PREINIT:
672 STRLEN len;
673 const char *key;
674 INPUT:
675 HV *hash
676 SV *key_sv
677 CODE:
678 key = SvPV(key_sv, len);
028f8eaa 679 RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
0314122a
NC
680 OUTPUT:
681 RETVAL
682
bdee33e4
NC
683bool
684exists_ent(hash, key_sv)
685 PREINIT:
686 INPUT:
687 HV *hash
688 SV *key_sv
689 CODE:
690 RETVAL = hv_exists_ent(hash, key_sv, 0);
691 OUTPUT:
692 RETVAL
693
b60cf05a 694SV *
55289a74 695delete(hash, key_sv, flags = 0)
b60cf05a
NC
696 PREINIT:
697 STRLEN len;
698 const char *key;
699 INPUT:
700 HV *hash
701 SV *key_sv
55289a74 702 I32 flags;
b60cf05a
NC
703 CODE:
704 key = SvPV(key_sv, len);
705 /* It's already mortal, so need to increase reference count. */
55289a74
NC
706 RETVAL
707 = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
708 OUTPUT:
709 RETVAL
710
711SV *
712delete_ent(hash, key_sv, flags = 0)
713 INPUT:
714 HV *hash
715 SV *key_sv
716 I32 flags;
717 CODE:
718 /* It's already mortal, so need to increase reference count. */
719 RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
b60cf05a
NC
720 OUTPUT:
721 RETVAL
722
723SV *
858117f8
NC
724store_ent(hash, key, value)
725 PREINIT:
726 SV *copy;
727 HE *result;
728 INPUT:
729 HV *hash
730 SV *key
731 SV *value
732 CODE:
733 copy = newSV(0);
734 result = hv_store_ent(hash, key, copy, 0);
735 SvSetMagicSV(copy, value);
736 if (!result) {
737 SvREFCNT_dec(copy);
738 XSRETURN_EMPTY;
739 }
740 /* It's about to become mortal, so need to increase reference count.
741 */
742 RETVAL = SvREFCNT_inc(HeVAL(result));
743 OUTPUT:
744 RETVAL
745
858117f8 746SV *
b60cf05a
NC
747store(hash, key_sv, value)
748 PREINIT:
749 STRLEN len;
750 const char *key;
751 SV *copy;
752 SV **result;
753 INPUT:
754 HV *hash
755 SV *key_sv
756 SV *value
757 CODE:
758 key = SvPV(key_sv, len);
759 copy = newSV(0);
028f8eaa 760 result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
858117f8 761 SvSetMagicSV(copy, value);
b60cf05a
NC
762 if (!result) {
763 SvREFCNT_dec(copy);
764 XSRETURN_EMPTY;
765 }
766 /* It's about to become mortal, so need to increase reference count.
767 */
768 RETVAL = SvREFCNT_inc(*result);
769 OUTPUT:
770 RETVAL
771
bdee33e4
NC
772SV *
773fetch_ent(hash, key_sv)
774 PREINIT:
775 HE *result;
776 INPUT:
777 HV *hash
778 SV *key_sv
779 CODE:
780 result = hv_fetch_ent(hash, key_sv, 0, 0);
781 if (!result) {
782 XSRETURN_EMPTY;
783 }
784 /* Force mg_get */
785 RETVAL = newSVsv(HeVAL(result));
786 OUTPUT:
787 RETVAL
b60cf05a
NC
788
789SV *
790fetch(hash, key_sv)
791 PREINIT:
792 STRLEN len;
793 const char *key;
794 SV **result;
795 INPUT:
796 HV *hash
797 SV *key_sv
798 CODE:
799 key = SvPV(key_sv, len);
028f8eaa 800 result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
b60cf05a
NC
801 if (!result) {
802 XSRETURN_EMPTY;
803 }
804 /* Force mg_get */
805 RETVAL = newSVsv(*result);
806 OUTPUT:
807 RETVAL
2dc92170 808
9568a123
NC
809#if defined (hv_common)
810
6b4de907
NC
811SV *
812common(params)
813 INPUT:
814 HV *params
815 PREINIT:
816 HE *result;
817 HV *hv = NULL;
818 SV *keysv = NULL;
819 const char *key = NULL;
820 STRLEN klen = 0;
821 int flags = 0;
822 int action = 0;
823 SV *val = NULL;
824 U32 hash = 0;
825 SV **svp;
826 CODE:
827 if ((svp = hv_fetchs(params, "hv", 0))) {
828 SV *const rv = *svp;
829 if (!SvROK(rv))
830 croak("common passed a non-reference for parameter hv");
831 hv = (HV *)SvRV(rv);
832 }
833 if ((svp = hv_fetchs(params, "keysv", 0)))
834 keysv = *svp;
835 if ((svp = hv_fetchs(params, "keypv", 0))) {
836 key = SvPV_const(*svp, klen);
837 if (SvUTF8(*svp))
838 flags = HVhek_UTF8;
839 }
840 if ((svp = hv_fetchs(params, "action", 0)))
841 action = SvIV(*svp);
842 if ((svp = hv_fetchs(params, "val", 0)))
527df579 843 val = newSVsv(*svp);
6b4de907 844 if ((svp = hv_fetchs(params, "hash", 0)))
a44093a9 845 hash = SvUV(*svp);
6b4de907 846
527df579
NC
847 if ((svp = hv_fetchs(params, "hash_pv", 0))) {
848 PERL_HASH(hash, key, klen);
849 }
58ca560a
NC
850 if ((svp = hv_fetchs(params, "hash_sv", 0))) {
851 STRLEN len;
852 const char *const p = SvPV(keysv, len);
853 PERL_HASH(hash, p, len);
854 }
527df579 855
a75fcbca 856 result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
6b4de907
NC
857 if (!result) {
858 XSRETURN_EMPTY;
859 }
860 /* Force mg_get */
861 RETVAL = newSVsv(HeVAL(result));
862 OUTPUT:
863 RETVAL
864
9568a123
NC
865#endif
866
439efdfe 867void
2dc92170
NC
868test_hv_free_ent()
869 PPCODE:
870 test_freeent(&Perl_hv_free_ent);
871 XSRETURN(4);
872
439efdfe 873void
2dc92170
NC
874test_hv_delayfree_ent()
875 PPCODE:
876 test_freeent(&Perl_hv_delayfree_ent);
877 XSRETURN(4);
35ab5632
NC
878
879SV *
880test_share_unshare_pvn(input)
881 PREINIT:
35ab5632
NC
882 STRLEN len;
883 U32 hash;
884 char *pvx;
885 char *p;
886 INPUT:
887 SV *input
888 CODE:
889 pvx = SvPV(input, len);
890 PERL_HASH(hash, pvx, len);
891 p = sharepvn(pvx, len, hash);
892 RETVAL = newSVpvn(p, len);
893 unsharepvn(p, len, hash);
894 OUTPUT:
895 RETVAL
d8c5b3c5 896
9568a123
NC
897#if PERL_VERSION >= 9
898
d8c5b3c5
NC
899bool
900refcounted_he_exists(key, level=0)
901 SV *key
902 IV level
903 CODE:
904 if (level) {
905 croak("level must be zero, not %"IVdf, level);
906 }
907 RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
908 key, NULL, 0, 0, 0)
909 != &PL_sv_placeholder);
910 OUTPUT:
911 RETVAL
912
d8c5b3c5
NC
913SV *
914refcounted_he_fetch(key, level=0)
915 SV *key
916 IV level
917 CODE:
918 if (level) {
919 croak("level must be zero, not %"IVdf, level);
920 }
921 RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
922 NULL, 0, 0, 0);
923 SvREFCNT_inc(RETVAL);
924 OUTPUT:
925 RETVAL
65bfe90c 926
9568a123 927#endif
65bfe90c 928
0314122a
NC
929=pod
930
931sub TIEHASH { bless {}, $_[0] }
932sub STORE { $_[0]->{$_[1]} = $_[2] }
933sub FETCH { $_[0]->{$_[1]} }
934sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
935sub NEXTKEY { each %{$_[0]} }
936sub EXISTS { exists $_[0]->{$_[1]} }
937sub DELETE { delete $_[0]->{$_[1]} }
938sub CLEAR { %{$_[0]} = () }
939
940=cut
941
e2fe06dd
EB
942MODULE = XS::APItest:TempLv PACKAGE = XS::APItest::TempLv
943
944void
945make_temp_mg_lv(sv)
946SV* sv
947 PREINIT:
948 SV * const lv = newSV_type(SVt_PVLV);
949 STRLEN len;
950 PPCODE:
951 SvPV(sv, len);
952
953 sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
954 LvTYPE(lv) = 'x';
955 LvTARG(lv) = SvREFCNT_inc_simple(sv);
956 LvTARGOFF(lv) = len == 0 ? 0 : 1;
957 LvTARGLEN(lv) = len < 2 ? 0 : len-2;
958
959 EXTEND(SP, 1);
960 ST(0) = sv_2mortal(lv);
961 XSRETURN(1);
962
963
36c2b1d0
NC
964MODULE = XS::APItest::PtrTable PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
965
966void
967ptr_table_new(classname)
968const char * classname
969 PPCODE:
970 PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
971
972void
973DESTROY(table)
974XS::APItest::PtrTable table
975 CODE:
976 ptr_table_free(table);
977
978void
992b2363 979ptr_table_store(table, from, to)
36c2b1d0 980XS::APItest::PtrTable table
992b2363
NC
981SVREF from
982SVREF to
36c2b1d0 983 CODE:
992b2363 984 ptr_table_store(table, from, to);
36c2b1d0
NC
985
986UV
992b2363 987ptr_table_fetch(table, from)
36c2b1d0 988XS::APItest::PtrTable table
992b2363 989SVREF from
36c2b1d0 990 CODE:
992b2363 991 RETVAL = PTR2UV(ptr_table_fetch(table, from));
36c2b1d0
NC
992 OUTPUT:
993 RETVAL
994
995void
996ptr_table_split(table)
997XS::APItest::PtrTable table
998
999void
1000ptr_table_clear(table)
1001XS::APItest::PtrTable table
1002
3e61d65a
JH
1003MODULE = XS::APItest PACKAGE = XS::APItest
1004
1005PROTOTYPES: DISABLE
1006
85ce96a1
DM
1007BOOT:
1008{
1009 MY_CXT_INIT;
03569ecf 1010
85ce96a1
DM
1011 MY_CXT.i = 99;
1012 MY_CXT.sv = newSVpv("initial",0);
13b6b3bc
BM
1013
1014 MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1015 MY_CXT.bhk_record = 0;
1016
1017 BhkENTRY_set(&bhk_test, start, blockhook_test_start);
1018 BhkENTRY_set(&bhk_test, pre_end, blockhook_test_pre_end);
1019 BhkENTRY_set(&bhk_test, post_end, blockhook_test_post_end);
1020 BhkENTRY_set(&bhk_test, eval, blockhook_test_eval);
1021 Perl_blockhook_register(aTHX_ &bhk_test);
1022
65bfe90c 1023 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
13b6b3bc 1024 GV_ADDMULTI, SVt_PVAV);
03569ecf
BM
1025 MY_CXT.cscav = GvAV(MY_CXT.cscgv);
1026
13b6b3bc
BM
1027 BhkENTRY_set(&bhk_csc, start, blockhook_csc_start);
1028 BhkENTRY_set(&bhk_csc, pre_end, blockhook_csc_pre_end);
1029 Perl_blockhook_register(aTHX_ &bhk_csc);
201c7e1f
FR
1030
1031 MY_CXT.peep_recorder = newAV();
1032 MY_CXT.rpeep_recorder = newAV();
1033
1034 MY_CXT.orig_peep = PL_peepp;
1035 MY_CXT.orig_rpeep = PL_rpeepp;
1036 PL_peepp = my_peep;
1037 PL_rpeepp = my_rpeep;
65bfe90c 1038}
85ce96a1
DM
1039
1040void
1041CLONE(...)
1042 CODE:
1043 MY_CXT_CLONE;
1044 MY_CXT.sv = newSVpv("initial_clone",0);
65bfe90c 1045 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
13b6b3bc 1046 GV_ADDMULTI, SVt_PVAV);
03569ecf 1047 MY_CXT.cscav = NULL;
13b6b3bc
BM
1048 MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1049 MY_CXT.bhk_record = 0;
201c7e1f
FR
1050 MY_CXT.peep_recorder = newAV();
1051 MY_CXT.rpeep_recorder = newAV();
85ce96a1 1052
3e61d65a
JH
1053void
1054print_double(val)
1055 double val
1056 CODE:
1057 printf("%5.3f\n",val);
1058
1059int
1060have_long_double()
1061 CODE:
1062#ifdef HAS_LONG_DOUBLE
1063 RETVAL = 1;
1064#else
1065 RETVAL = 0;
1066#endif
cabb36f0
CN
1067 OUTPUT:
1068 RETVAL
3e61d65a
JH
1069
1070void
1071print_long_double()
1072 CODE:
1073#ifdef HAS_LONG_DOUBLE
fc0bf671 1074# if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
3e61d65a
JH
1075 long double val = 7.0;
1076 printf("%5.3" PERL_PRIfldbl "\n",val);
1077# else
1078 double val = 7.0;
1079 printf("%5.3f\n",val);
1080# endif
1081#endif
1082
1083void
3e61d65a
JH
1084print_int(val)
1085 int val
1086 CODE:
1087 printf("%d\n",val);
1088
1089void
1090print_long(val)
1091 long val
1092 CODE:
1093 printf("%ld\n",val);
1094
1095void
1096print_float(val)
1097 float val
1098 CODE:
1099 printf("%5.3f\n",val);
9d911683
NIS
1100
1101void
1102print_flush()
1103 CODE:
1104 fflush(stdout);
d4b90eee
SH
1105
1106void
1107mpushp()
1108 PPCODE:
1109 EXTEND(SP, 3);
1110 mPUSHp("one", 3);
1111 mPUSHp("two", 3);
1112 mPUSHp("three", 5);
1113 XSRETURN(3);
1114
1115void
1116mpushn()
1117 PPCODE:
1118 EXTEND(SP, 3);
1119 mPUSHn(0.5);
1120 mPUSHn(-0.25);
1121 mPUSHn(0.125);
1122 XSRETURN(3);
1123
1124void
1125mpushi()
1126 PPCODE:
1127 EXTEND(SP, 3);
d75b63cf
MHM
1128 mPUSHi(-1);
1129 mPUSHi(2);
1130 mPUSHi(-3);
d4b90eee
SH
1131 XSRETURN(3);
1132
1133void
1134mpushu()
1135 PPCODE:
1136 EXTEND(SP, 3);
d75b63cf
MHM
1137 mPUSHu(1);
1138 mPUSHu(2);
1139 mPUSHu(3);
d4b90eee
SH
1140 XSRETURN(3);
1141
1142void
1143mxpushp()
1144 PPCODE:
1145 mXPUSHp("one", 3);
1146 mXPUSHp("two", 3);
1147 mXPUSHp("three", 5);
1148 XSRETURN(3);
1149
1150void
1151mxpushn()
1152 PPCODE:
1153 mXPUSHn(0.5);
1154 mXPUSHn(-0.25);
1155 mXPUSHn(0.125);
1156 XSRETURN(3);
1157
1158void
1159mxpushi()
1160 PPCODE:
d75b63cf
MHM
1161 mXPUSHi(-1);
1162 mXPUSHi(2);
1163 mXPUSHi(-3);
d4b90eee
SH
1164 XSRETURN(3);
1165
1166void
1167mxpushu()
1168 PPCODE:
d75b63cf
MHM
1169 mXPUSHu(1);
1170 mXPUSHu(2);
1171 mXPUSHu(3);
d4b90eee 1172 XSRETURN(3);
d1f347d7
DM
1173
1174
1175void
1176call_sv(sv, flags, ...)
1177 SV* sv
1178 I32 flags
1179 PREINIT:
1180 I32 i;
1181 PPCODE:
1182 for (i=0; i<items-2; i++)
1183 ST(i) = ST(i+2); /* pop first two args */
1184 PUSHMARK(SP);
1185 SP += items - 2;
1186 PUTBACK;
1187 i = call_sv(sv, flags);
1188 SPAGAIN;
1189 EXTEND(SP, 1);
1190 PUSHs(sv_2mortal(newSViv(i)));
1191
1192void
1193call_pv(subname, flags, ...)
1194 char* subname
1195 I32 flags
1196 PREINIT:
1197 I32 i;
1198 PPCODE:
1199 for (i=0; i<items-2; i++)
1200 ST(i) = ST(i+2); /* pop first two args */
1201 PUSHMARK(SP);
1202 SP += items - 2;
1203 PUTBACK;
1204 i = call_pv(subname, flags);
1205 SPAGAIN;
1206 EXTEND(SP, 1);
1207 PUSHs(sv_2mortal(newSViv(i)));
1208
1209void
1210call_method(methname, flags, ...)
1211 char* methname
1212 I32 flags
1213 PREINIT:
1214 I32 i;
1215 PPCODE:
1216 for (i=0; i<items-2; i++)
1217 ST(i) = ST(i+2); /* pop first two args */
1218 PUSHMARK(SP);
1219 SP += items - 2;
1220 PUTBACK;
1221 i = call_method(methname, flags);
1222 SPAGAIN;
1223 EXTEND(SP, 1);
1224 PUSHs(sv_2mortal(newSViv(i)));
1225
1226void
1227eval_sv(sv, flags)
1228 SV* sv
1229 I32 flags
1230 PREINIT:
1231 I32 i;
1232 PPCODE:
1233 PUTBACK;
1234 i = eval_sv(sv, flags);
1235 SPAGAIN;
1236 EXTEND(SP, 1);
1237 PUSHs(sv_2mortal(newSViv(i)));
1238
b8e65a9b 1239void
d1f347d7
DM
1240eval_pv(p, croak_on_error)
1241 const char* p
1242 I32 croak_on_error
d1f347d7
DM
1243 PPCODE:
1244 PUTBACK;
1245 EXTEND(SP, 1);
1246 PUSHs(eval_pv(p, croak_on_error));
1247
1248void
1249require_pv(pv)
1250 const char* pv
d1f347d7
DM
1251 PPCODE:
1252 PUTBACK;
1253 require_pv(pv);
1254
0ca3a874 1255int
7a646707 1256apitest_exception(throw_e)
0ca3a874
MHM
1257 int throw_e
1258 OUTPUT:
1259 RETVAL
d1f347d7 1260
ef469b03 1261void
7e7a3dfc
GA
1262mycroak(sv)
1263 SV* sv
ef469b03 1264 CODE:
7e7a3dfc
GA
1265 if (SvOK(sv)) {
1266 Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
1267 }
1268 else {
1269 Perl_croak(aTHX_ NULL);
1270 }
5d2b1485
NC
1271
1272SV*
1273strtab()
1274 CODE:
1275 RETVAL = newRV_inc((SV*)PL_strtab);
1276 OUTPUT:
1277 RETVAL
85ce96a1
DM
1278
1279int
1280my_cxt_getint()
1281 CODE:
1282 dMY_CXT;
1283 RETVAL = my_cxt_getint_p(aMY_CXT);
1284 OUTPUT:
1285 RETVAL
1286
1287void
1288my_cxt_setint(i)
1289 int i;
1290 CODE:
1291 dMY_CXT;
1292 my_cxt_setint_p(aMY_CXT_ i);
1293
1294void
9568a123
NC
1295my_cxt_getsv(how)
1296 bool how;
85ce96a1 1297 PPCODE:
85ce96a1 1298 EXTEND(SP, 1);
9568a123 1299 ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
85ce96a1
DM
1300 XSRETURN(1);
1301
1302void
1303my_cxt_setsv(sv)
1304 SV *sv;
1305 CODE:
1306 dMY_CXT;
1307 SvREFCNT_dec(MY_CXT.sv);
1308 my_cxt_setsv_p(sv _aMY_CXT);
1309 SvREFCNT_inc(sv);
34482cd6
NC
1310
1311bool
1312sv_setsv_cow_hashkey_core()
1313
1314bool
1315sv_setsv_cow_hashkey_notcore()
84ac5fd7
NC
1316
1317void
218787bd
VP
1318rmagical_cast(sv, type)
1319 SV *sv;
1320 SV *type;
1321 PREINIT:
1322 struct ufuncs uf;
1323 PPCODE:
1324 if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
1325 sv = SvRV(sv);
1326 if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
1327 uf.uf_val = rmagical_a_dummy;
1328 uf.uf_set = NULL;
1329 uf.uf_index = 0;
1330 if (SvTRUE(type)) { /* b */
1331 sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
1332 } else { /* a */
1333 sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
1334 }
1335 XSRETURN_YES;
1336
1337void
1338rmagical_flags(sv)
1339 SV *sv;
1340 PPCODE:
1341 if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
1342 sv = SvRV(sv);
1343 EXTEND(SP, 3);
1344 mXPUSHu(SvFLAGS(sv) & SVs_GMG);
1345 mXPUSHu(SvFLAGS(sv) & SVs_SMG);
1346 mXPUSHu(SvFLAGS(sv) & SVs_RMG);
1347 XSRETURN(3);
1348
1349void
90d1f214
BM
1350my_caller(level)
1351 I32 level
1352 PREINIT:
1353 const PERL_CONTEXT *cx, *dbcx;
1354 const char *pv;
1355 const GV *gv;
1356 HV *hv;
1357 PPCODE:
1358 cx = caller_cx(level, &dbcx);
1359 EXTEND(SP, 8);
1360
1361 pv = CopSTASHPV(cx->blk_oldcop);
1362 ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1363 gv = CvGV(cx->blk_sub.cv);
1364 ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1365
1366 pv = CopSTASHPV(dbcx->blk_oldcop);
1367 ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1368 gv = CvGV(dbcx->blk_sub.cv);
1369 ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1370
1371 ST(4) = cop_hints_fetchpvs(cx->blk_oldcop, "foo");
1372 ST(5) = cop_hints_fetchpvn(cx->blk_oldcop, "foo", 3, 0, 0);
1373 ST(6) = cop_hints_fetchsv(cx->blk_oldcop,
1374 sv_2mortal(newSVpvn("foo", 3)), 0);
1375
1376 hv = cop_hints_2hv(cx->blk_oldcop);
1377 ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
1378
1379 XSRETURN(8);
1380
1381void
f9c17636
MB
1382DPeek (sv)
1383 SV *sv
1384
1385 PPCODE:
5b1f7359 1386 ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
f9c17636
MB
1387 XSRETURN (1);
1388
1389void
84ac5fd7
NC
1390BEGIN()
1391 CODE:
1392 sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
1393
1394void
1395CHECK()
1396 CODE:
1397 sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
1398
1399void
1400UNITCHECK()
1401 CODE:
0932863f 1402 sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
84ac5fd7
NC
1403
1404void
1405INIT()
1406 CODE:
1407 sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
1408
1409void
1410END()
1411 CODE:
1412 sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
30685b56
NC
1413
1414void
1415utf16_to_utf8 (sv, ...)
1416 SV* sv
1417 ALIAS:
1418 utf16_to_utf8_reversed = 1
1419 PREINIT:
1420 STRLEN len;
1421 U8 *source;
1422 SV *dest;
1423 I32 got; /* Gah, badly thought out APIs */
1424 CODE:
1425 source = (U8 *)SvPVbyte(sv, len);
1426 /* Optionally only convert part of the buffer. */
1427 if (items > 1) {
1428 len = SvUV(ST(1));
1429 }
1430 /* Mortalise this right now, as we'll be testing croak()s */
1431 dest = sv_2mortal(newSV(len * 3 / 2 + 1));
1432 if (ix) {
25f2e844 1433 utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
30685b56 1434 } else {
25f2e844 1435 utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
30685b56
NC
1436 }
1437 SvCUR_set(dest, got);
1438 SvPVX(dest)[got] = '\0';
1439 SvPOK_on(dest);
1440 ST(0) = dest;
1441 XSRETURN(1);
879d0c72 1442
6bd7445c
GG
1443void
1444my_exit(int exitcode)
1445 PPCODE:
1446 my_exit(exitcode);
d97c33b5
DM
1447
1448I32
1449sv_count()
1450 CODE:
1451 RETVAL = PL_sv_count;
1452 OUTPUT:
1453 RETVAL
13b6b3bc
BM
1454
1455void
1456bhk_record(bool on)
1457 CODE:
1458 dMY_CXT;
1459 MY_CXT.bhk_record = on;
1460 if (on)
1461 av_clear(MY_CXT.bhkav);
65bfe90c 1462
defdfed5
Z
1463void
1464test_savehints()
1465 PREINIT:
1466 SV **svp, *sv;
1467 CODE:
1468#define store_hint(KEY, VALUE) \
1469 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
1470#define hint_ok(KEY, EXPECT) \
1471 ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
1472 (sv = *svp) && SvIV(sv) == (EXPECT) && \
1473 (sv = cop_hints_fetchpvs(&PL_compiling, KEY)) && \
1474 SvIV(sv) == (EXPECT))
1475#define check_hint(KEY, EXPECT) \
1476 do { if (!hint_ok(KEY, EXPECT)) croak("fail"); } while(0)
1477 PL_hints |= HINT_LOCALIZE_HH;
1478 ENTER;
1479 SAVEHINTS();
1480 PL_hints &= HINT_INTEGER;
1481 store_hint("t0", 123);
1482 store_hint("t1", 456);
1483 if (PL_hints & HINT_INTEGER) croak("fail");
1484 check_hint("t0", 123); check_hint("t1", 456);
1485 ENTER;
1486 SAVEHINTS();
1487 if (PL_hints & HINT_INTEGER) croak("fail");
1488 check_hint("t0", 123); check_hint("t1", 456);
1489 PL_hints |= HINT_INTEGER;
1490 store_hint("t0", 321);
1491 if (!(PL_hints & HINT_INTEGER)) croak("fail");
1492 check_hint("t0", 321); check_hint("t1", 456);
1493 LEAVE;
1494 if (PL_hints & HINT_INTEGER) croak("fail");
1495 check_hint("t0", 123); check_hint("t1", 456);
1496 ENTER;
1497 SAVEHINTS();
1498 if (PL_hints & HINT_INTEGER) croak("fail");
1499 check_hint("t0", 123); check_hint("t1", 456);
1500 store_hint("t1", 654);
1501 if (PL_hints & HINT_INTEGER) croak("fail");
1502 check_hint("t0", 123); check_hint("t1", 654);
1503 LEAVE;
1504 if (PL_hints & HINT_INTEGER) croak("fail");
1505 check_hint("t0", 123); check_hint("t1", 456);
1506 LEAVE;
1507#undef store_hint
1508#undef hint_ok
1509#undef check_hint
1510
1511void
1512test_copyhints()
1513 PREINIT:
1514 HV *a, *b;
1515 CODE:
1516 PL_hints |= HINT_LOCALIZE_HH;
1517 ENTER;
1518 SAVEHINTS();
1519 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
1520 if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak("fail");
1521 a = newHVhv(GvHV(PL_hintgv));
1522 sv_2mortal((SV*)a);
1523 sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
1524 if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak("fail");
1525 b = hv_copy_hints_hv(a);
1526 sv_2mortal((SV*)b);
1527 sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
1528 if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 789) croak("fail");
1529 LEAVE;
1530
201c7e1f
FR
1531void
1532peep_enable ()
1533 PREINIT:
1534 dMY_CXT;
1535 CODE:
1536 av_clear(MY_CXT.peep_recorder);
1537 av_clear(MY_CXT.rpeep_recorder);
1538 MY_CXT.peep_recording = 1;
1539
1540void
1541peep_disable ()
1542 PREINIT:
1543 dMY_CXT;
1544 CODE:
1545 MY_CXT.peep_recording = 0;
1546
1547SV *
1548peep_record ()
1549 PREINIT:
1550 dMY_CXT;
1551 CODE:
95d2461a 1552 RETVAL = newRV_inc((SV *)MY_CXT.peep_recorder);
201c7e1f
FR
1553 OUTPUT:
1554 RETVAL
1555
1556SV *
1557rpeep_record ()
1558 PREINIT:
1559 dMY_CXT;
1560 CODE:
95d2461a 1561 RETVAL = newRV_inc((SV *)MY_CXT.rpeep_recorder);
201c7e1f
FR
1562 OUTPUT:
1563 RETVAL
1564
e2fe06dd
EB
1565BOOT:
1566 {
1567 HV* stash;
1568 SV** meth = NULL;
1569 CV* cv;
1570 stash = gv_stashpv("XS::APItest::TempLv", 0);
1571 if (stash)
1572 meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
1573 if (!meth)
1574 croak("lost method 'make_temp_mg_lv'");
1575 cv = GvCV(*meth);
1576 CvLVALUE_on(cv);
1577 }
83f8bb56
Z
1578
1579BOOT:
1580{
1581 hintkey_rpn_sv = newSVpvs_share("XS::APItest/rpn");
1582 hintkey_calcrpn_sv = newSVpvs_share("XS::APItest/calcrpn");
1583 hintkey_stufftest_sv = newSVpvs_share("XS::APItest/stufftest");
1584 hintkey_swaptwostmts_sv = newSVpvs_share("XS::APItest/swaptwostmts");
07ffcb73 1585 hintkey_looprest_sv = newSVpvs_share("XS::APItest/looprest");
83f8bb56
Z
1586 next_keyword_plugin = PL_keyword_plugin;
1587 PL_keyword_plugin = my_keyword_plugin;
1588}