1 #define PERL_IN_XS_APITEST
7 typedef PTR_TBL_t *XS__APItest__PtrTable;
11 #define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
26 /* indirect functions to test the [pa]MY_CXT macros */
29 my_cxt_getint_p(pMY_CXT)
35 my_cxt_setint_p(pMY_CXT_ int i)
41 my_cxt_getsv_interp_context(void)
44 dMY_CXT_INTERP(my_perl);
49 my_cxt_getsv_interp(void)
56 my_cxt_setsv_p(SV* sv _pMY_CXT)
62 /* from exception.c */
63 int apitest_exception(int);
65 /* from core_or_not.inc */
66 bool sv_setsv_cow_hashkey_core(void);
67 bool sv_setsv_cow_hashkey_notcore(void);
69 /* A routine to test hv_delayfree_ent
70 (which itself is tested by testing on hv_free_ent */
72 typedef void (freeent_function)(pTHX_ HV *, register HE *);
75 test_freeent(freeent_function *f) {
78 HV *test_hash = newHV();
85 victim = (HE*)safemalloc(sizeof(HE));
87 /* Storing then deleting something should ensure that a hash entry is
89 hv_store(test_hash, "", 0, &PL_sv_yes, 0);
90 hv_delete(test_hash, "", 0, 0);
92 /* We need to "inline" new_he here as it's static, and the functions we
93 test expect to be able to call del_HE on the HE */
94 if (!PL_body_roots[HE_SVSLOT])
95 croak("PL_he_root is 0");
96 victim = (HE*) PL_body_roots[HE_SVSLOT];
97 PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
100 victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
102 test_scalar = newSV(0);
103 SvREFCNT_inc(test_scalar);
104 HeVAL(victim) = test_scalar;
106 /* Need this little game else we free the temps on the return stack. */
107 results[0] = SvREFCNT(test_scalar);
109 results[1] = SvREFCNT(test_scalar);
110 f(aTHX_ test_hash, victim);
111 results[2] = SvREFCNT(test_scalar);
113 results[3] = SvREFCNT(test_scalar);
118 } while (++i < sizeof(results)/sizeof(results[0]));
120 /* Goodbye to our extra reference. */
121 SvREFCNT_dec(test_scalar);
126 bitflip_key(pTHX_ IV action, SV *field) {
127 MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
129 if (mg && (keysv = mg->mg_obj)) {
131 const char *p = SvPV(keysv, len);
134 SV *newkey = newSV(len);
135 char *new_p = SvPVX(newkey);
138 const char *const end = p + len;
141 UV chr = utf8_to_uvuni((U8 *)p, &len);
142 new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32);
148 *new_p++ = *p++ ^ 32;
151 SvCUR_set(newkey, SvCUR(keysv));
161 rot13_key(pTHX_ IV action, SV *field) {
162 MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
164 if (mg && (keysv = mg->mg_obj)) {
166 const char *p = SvPV(keysv, len);
169 SV *newkey = newSV(len);
170 char *new_p = SvPVX(newkey);
172 /* There's a deliberate fencepost error here to loop len + 1 times
173 to copy the trailing \0 */
176 /* Try doing this cleanly and clearly in EBCDIC another way: */
178 case 'A': new_c = 'N'; break;
179 case 'B': new_c = 'O'; break;
180 case 'C': new_c = 'P'; break;
181 case 'D': new_c = 'Q'; break;
182 case 'E': new_c = 'R'; break;
183 case 'F': new_c = 'S'; break;
184 case 'G': new_c = 'T'; break;
185 case 'H': new_c = 'U'; break;
186 case 'I': new_c = 'V'; break;
187 case 'J': new_c = 'W'; break;
188 case 'K': new_c = 'X'; break;
189 case 'L': new_c = 'Y'; break;
190 case 'M': new_c = 'Z'; break;
191 case 'N': new_c = 'A'; break;
192 case 'O': new_c = 'B'; break;
193 case 'P': new_c = 'C'; break;
194 case 'Q': new_c = 'D'; break;
195 case 'R': new_c = 'E'; break;
196 case 'S': new_c = 'F'; break;
197 case 'T': new_c = 'G'; break;
198 case 'U': new_c = 'H'; break;
199 case 'V': new_c = 'I'; break;
200 case 'W': new_c = 'J'; break;
201 case 'X': new_c = 'K'; break;
202 case 'Y': new_c = 'L'; break;
203 case 'Z': new_c = 'M'; break;
204 case 'a': new_c = 'n'; break;
205 case 'b': new_c = 'o'; break;
206 case 'c': new_c = 'p'; break;
207 case 'd': new_c = 'q'; break;
208 case 'e': new_c = 'r'; break;
209 case 'f': new_c = 's'; break;
210 case 'g': new_c = 't'; break;
211 case 'h': new_c = 'u'; break;
212 case 'i': new_c = 'v'; break;
213 case 'j': new_c = 'w'; break;
214 case 'k': new_c = 'x'; break;
215 case 'l': new_c = 'y'; break;
216 case 'm': new_c = 'z'; break;
217 case 'n': new_c = 'a'; break;
218 case 'o': new_c = 'b'; break;
219 case 'p': new_c = 'c'; break;
220 case 'q': new_c = 'd'; break;
221 case 'r': new_c = 'e'; break;
222 case 's': new_c = 'f'; break;
223 case 't': new_c = 'g'; break;
224 case 'u': new_c = 'h'; break;
225 case 'v': new_c = 'i'; break;
226 case 'w': new_c = 'j'; break;
227 case 'x': new_c = 'k'; break;
228 case 'y': new_c = 'l'; break;
229 case 'z': new_c = 'm'; break;
233 SvCUR_set(newkey, SvCUR(keysv));
245 rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
249 STATIC MGVTBL rmagical_b = { 0 };
252 blockhook_csc_start(pTHX_ int full)
255 AV *const cur = GvAV(MY_CXT.cscgv);
257 SAVEGENERICSV(GvAV(MY_CXT.cscgv));
261 AV *const new_av = newAV();
263 for (i = 0; i <= av_len(cur); i++) {
264 av_store(new_av, i, newSVsv(*av_fetch(cur, i, 0)));
267 GvAV(MY_CXT.cscgv) = new_av;
272 blockhook_csc_pre_end(pTHX_ OP **o)
276 /* if we hit the end of a scope we missed the start of, we need to
277 * unconditionally clear @CSC */
278 if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) {
279 av_clear(MY_CXT.cscav);
285 blockhook_test_start(pTHX_ int full)
290 if (MY_CXT.bhk_record) {
292 av_push(av, newSVpvs("start"));
293 av_push(av, newSViv(full));
294 av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
299 blockhook_test_pre_end(pTHX_ OP **o)
303 if (MY_CXT.bhk_record)
304 av_push(MY_CXT.bhkav, newSVpvs("pre_end"));
308 blockhook_test_post_end(pTHX_ OP **o)
312 if (MY_CXT.bhk_record)
313 av_push(MY_CXT.bhkav, newSVpvs("post_end"));
317 blockhook_test_eval(pTHX_ OP *const o)
322 if (MY_CXT.bhk_record) {
324 av_push(av, newSVpvs("eval"));
325 av_push(av, newSVpv(OP_NAME(o), 0));
326 av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
330 STATIC BHK bhk_csc, bhk_test;
333 my_peep (pTHX_ OP *o, peep_next_t *next_peep)
340 CALL_FPTR(MY_CXT.orig_peep)(aTHX_ o, next_peep);
342 for (; o; o = o->op_next) {
343 if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
344 av_push(MY_CXT.peep_record, newSVsv(cSVOPx_sv(o)));
349 #include "const-c.inc"
351 MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
353 INCLUDE: const-xs.inc
361 uf.uf_val = rot13_key;
365 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
374 uf.uf_val = bitflip_key;
378 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
381 #define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
392 key = SvPV(key_sv, len);
393 RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
398 exists_ent(hash, key_sv)
404 RETVAL = hv_exists_ent(hash, key_sv, 0);
409 delete(hash, key_sv, flags = 0)
418 key = SvPV(key_sv, len);
419 /* It's already mortal, so need to increase reference count. */
421 = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
426 delete_ent(hash, key_sv, flags = 0)
432 /* It's already mortal, so need to increase reference count. */
433 RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
438 store_ent(hash, key, value)
448 result = hv_store_ent(hash, key, copy, 0);
449 SvSetMagicSV(copy, value);
454 /* It's about to become mortal, so need to increase reference count.
456 RETVAL = SvREFCNT_inc(HeVAL(result));
461 store(hash, key_sv, value)
472 key = SvPV(key_sv, len);
474 result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
475 SvSetMagicSV(copy, value);
480 /* It's about to become mortal, so need to increase reference count.
482 RETVAL = SvREFCNT_inc(*result);
487 fetch_ent(hash, key_sv)
494 result = hv_fetch_ent(hash, key_sv, 0, 0);
499 RETVAL = newSVsv(HeVAL(result));
513 key = SvPV(key_sv, len);
514 result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
519 RETVAL = newSVsv(*result);
523 #if defined (hv_common)
533 const char *key = NULL;
541 if ((svp = hv_fetchs(params, "hv", 0))) {
544 croak("common passed a non-reference for parameter hv");
547 if ((svp = hv_fetchs(params, "keysv", 0)))
549 if ((svp = hv_fetchs(params, "keypv", 0))) {
550 key = SvPV_const(*svp, klen);
554 if ((svp = hv_fetchs(params, "action", 0)))
556 if ((svp = hv_fetchs(params, "val", 0)))
558 if ((svp = hv_fetchs(params, "hash", 0)))
561 if ((svp = hv_fetchs(params, "hash_pv", 0))) {
562 PERL_HASH(hash, key, klen);
564 if ((svp = hv_fetchs(params, "hash_sv", 0))) {
566 const char *const p = SvPV(keysv, len);
567 PERL_HASH(hash, p, len);
570 result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
575 RETVAL = newSVsv(HeVAL(result));
584 test_freeent(&Perl_hv_free_ent);
588 test_hv_delayfree_ent()
590 test_freeent(&Perl_hv_delayfree_ent);
594 test_share_unshare_pvn(input)
603 pvx = SvPV(input, len);
604 PERL_HASH(hash, pvx, len);
605 p = sharepvn(pvx, len, hash);
606 RETVAL = newSVpvn(p, len);
607 unsharepvn(p, len, hash);
611 #if PERL_VERSION >= 9
614 refcounted_he_exists(key, level=0)
619 croak("level must be zero, not %"IVdf, level);
621 RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
623 != &PL_sv_placeholder);
628 refcounted_he_fetch(key, level=0)
633 croak("level must be zero, not %"IVdf, level);
635 RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
637 SvREFCNT_inc(RETVAL);
645 sub TIEHASH { bless {}, $_[0] }
646 sub STORE { $_[0]->{$_[1]} = $_[2] }
647 sub FETCH { $_[0]->{$_[1]} }
648 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
649 sub NEXTKEY { each %{$_[0]} }
650 sub EXISTS { exists $_[0]->{$_[1]} }
651 sub DELETE { delete $_[0]->{$_[1]} }
652 sub CLEAR { %{$_[0]} = () }
656 MODULE = XS::APItest::PtrTable PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
659 ptr_table_new(classname)
660 const char * classname
662 PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
666 XS::APItest::PtrTable table
668 ptr_table_free(table);
671 ptr_table_store(table, from, to)
672 XS::APItest::PtrTable table
676 ptr_table_store(table, from, to);
679 ptr_table_fetch(table, from)
680 XS::APItest::PtrTable table
683 RETVAL = PTR2UV(ptr_table_fetch(table, from));
688 ptr_table_split(table)
689 XS::APItest::PtrTable table
692 ptr_table_clear(table)
693 XS::APItest::PtrTable table
695 MODULE = XS::APItest PACKAGE = XS::APItest
704 MY_CXT.sv = newSVpv("initial",0);
706 MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
707 MY_CXT.bhk_record = 0;
709 BhkENTRY_set(&bhk_test, start, blockhook_test_start);
710 BhkENTRY_set(&bhk_test, pre_end, blockhook_test_pre_end);
711 BhkENTRY_set(&bhk_test, post_end, blockhook_test_post_end);
712 BhkENTRY_set(&bhk_test, eval, blockhook_test_eval);
713 Perl_blockhook_register(aTHX_ &bhk_test);
715 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
716 GV_ADDMULTI, SVt_PVAV);
717 MY_CXT.cscav = GvAV(MY_CXT.cscgv);
719 BhkENTRY_set(&bhk_csc, start, blockhook_csc_start);
720 BhkENTRY_set(&bhk_csc, pre_end, blockhook_csc_pre_end);
721 Perl_blockhook_register(aTHX_ &bhk_csc);
723 MY_CXT.peep_record = newAV();
730 MY_CXT.sv = newSVpv("initial_clone",0);
731 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
732 GV_ADDMULTI, SVt_PVAV);
734 MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
735 MY_CXT.bhk_record = 0;
736 MY_CXT.peep_record = newAV();
742 printf("%5.3f\n",val);
747 #ifdef HAS_LONG_DOUBLE
758 #ifdef HAS_LONG_DOUBLE
759 # if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
760 long double val = 7.0;
761 printf("%5.3" PERL_PRIfldbl "\n",val);
764 printf("%5.3f\n",val);
784 printf("%5.3f\n",val);
861 call_sv(sv, flags, ...)
867 for (i=0; i<items-2; i++)
868 ST(i) = ST(i+2); /* pop first two args */
872 i = call_sv(sv, flags);
875 PUSHs(sv_2mortal(newSViv(i)));
878 call_pv(subname, flags, ...)
884 for (i=0; i<items-2; i++)
885 ST(i) = ST(i+2); /* pop first two args */
889 i = call_pv(subname, flags);
892 PUSHs(sv_2mortal(newSViv(i)));
895 call_method(methname, flags, ...)
901 for (i=0; i<items-2; i++)
902 ST(i) = ST(i+2); /* pop first two args */
906 i = call_method(methname, flags);
909 PUSHs(sv_2mortal(newSViv(i)));
919 i = eval_sv(sv, flags);
922 PUSHs(sv_2mortal(newSViv(i)));
925 eval_pv(p, croak_on_error)
931 PUSHs(eval_pv(p, croak_on_error));
941 apitest_exception(throw_e)
951 Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
954 Perl_croak(aTHX_ NULL);
960 RETVAL = newRV_inc((SV*)PL_strtab);
968 RETVAL = my_cxt_getint_p(aMY_CXT);
977 my_cxt_setint_p(aMY_CXT_ i);
984 ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
992 SvREFCNT_dec(MY_CXT.sv);
993 my_cxt_setsv_p(sv _aMY_CXT);
997 sv_setsv_cow_hashkey_core()
1000 sv_setsv_cow_hashkey_notcore()
1003 rmagical_cast(sv, type)
1009 if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
1011 if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
1012 uf.uf_val = rmagical_a_dummy;
1015 if (SvTRUE(type)) { /* b */
1016 sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
1018 sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
1026 if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
1029 mXPUSHu(SvFLAGS(sv) & SVs_GMG);
1030 mXPUSHu(SvFLAGS(sv) & SVs_SMG);
1031 mXPUSHu(SvFLAGS(sv) & SVs_RMG);
1039 ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
1045 sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
1050 sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
1055 sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
1060 sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
1065 sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
1068 utf16_to_utf8 (sv, ...)
1071 utf16_to_utf8_reversed = 1
1076 I32 got; /* Gah, badly thought out APIs */
1078 source = (U8 *)SvPVbyte(sv, len);
1079 /* Optionally only convert part of the buffer. */
1083 /* Mortalise this right now, as we'll be testing croak()s */
1084 dest = sv_2mortal(newSV(len * 3 / 2 + 1));
1086 utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
1088 utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
1090 SvCUR_set(dest, got);
1091 SvPVX(dest)[got] = '\0';
1097 my_exit(int exitcode)
1104 RETVAL = PL_sv_count;
1112 MY_CXT.bhk_record = on;
1114 av_clear(MY_CXT.bhkav);
1121 av_clear(MY_CXT.peep_record);
1122 MY_CXT.orig_peep = PL_peepp;
1130 RETVAL = MY_CXT.peep_record;
1135 peep_record_clear ()
1139 av_clear(MY_CXT.peep_record);