This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
(perl #130108) generate a dummy dtrace_main.o if perlmain.o doesn't contain probes
[perl5.git] / ext / XS-APItest / APItest.xs
CommitLineData
6a93a7e5 1#define PERL_IN_XS_APITEST
73e43954
HS		 2
3/* We want to be able to test things that aren't API yet. */
4#define PERL_EXT
5
0d5fcae7
FC		 6/* Do *not* define PERL_NO_GET_CONTEXT. This is the one place where we get
7 to test implicit Perl_get_context(). */
8
3e61d65a
JH		 9#include "EXTERN.h"
10#include "perl.h"
11#include "XSUB.h"
62df7c7d 12#include "fakesdio.h" /* Causes us to use PerlIO below */
3e61d65a 13
36c2b1d0
NC		 14typedef SV *SVREF;
15typedef PTR_TBL_t *XS__APItest__PtrTable;
85ce96a1 16
11f9f0ed 17#define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__)
779bc08a 18#define croak_fail_ne(h, w) croak("fail %p!=%p at " __FILE__ " line %d", (h), (w), __LINE__)
11f9f0ed 19
72900640
KW		 20#ifdef EBCDIC
21
22void
23cat_utf8a2n(SV* sv, const char * const ascii_utf8, STRLEN len)
24{
25 /* Converts variant UTF-8 text pointed to by 'ascii_utf8' of length 'len',
26 * to UTF-EBCDIC, appending that text to the text already in 'sv'.
27 * Currently doesn't work on invariants, as that is unneeded here, and we
28 * could get double translations if we did.
29 *
30 * It has the algorithm for strict UTF-8 hard-coded in to find the code
31 * point it represents, then calls uvchr_to_utf8() to convert to
32 * UTF-EBCDIC).
33 *
34 * Note that this uses code points, not characters. Thus if the input is
35 * the UTF-8 for the code point 0xFF, the output will be the UTF-EBCDIC for
36 * 0xFF, even though that code point represents different characters on
37 * ASCII vs EBCDIC platforms. */
38
39 dTHX;
40 char * p = (char *) ascii_utf8;
41 const char * const e = p + len;
42
43 while (p < e) {
44 UV code_point;
45 U8 native_utf8[UTF8_MAXBYTES + 1];
46 U8 * char_end;
47 U8 start = (U8) *p;
48
49 /* Start bytes are the same in both UTF-8 and I8, therefore we can
50 * treat this ASCII UTF-8 byte as an I8 byte. But PL_utf8skip[] is
51 * indexed by NATIVE_UTF8 bytes, so transform to that */
52 STRLEN char_bytes_len = PL_utf8skip[I8_TO_NATIVE_UTF8(start)];
53
54 if (start < 0xc2) {
55 croak("fail: Expecting start byte, instead got 0x%X at %s line %d",
56 (U8) *p, __FILE__, __LINE__);
57 }
58 code_point = (start & (((char_bytes_len) >= 7)
59 ? 0x00
60 : (0x1F >> ((char_bytes_len)-2))));
61 p++;
62 while (p < e && ((( (U8) *p) & 0xC0) == 0x80)) {
63
64 code_point = (code_point << 6) | (( (U8) *p) & 0x3F);
65 p++;
66 }
67
68 char_end = uvchr_to_utf8(native_utf8, code_point);
69 sv_catpvn(sv, (char *) native_utf8, char_end - native_utf8);
70 }
71}
72
73#endif
74
85ce96a1
DM		 75/* for my_cxt tests */
76
77#define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
78
79typedef struct {
80 int i;
81 SV *sv;
03569ecf
BM		 82 GV *cscgv;
83 AV *cscav;
13b6b3bc
BM		 84 AV *bhkav;
85 bool bhk_record;
201c7e1f
FR		 86 peep_t orig_peep;
87 peep_t orig_rpeep;
88 int peep_recording;
89 AV *peep_recorder;
90 AV *rpeep_recorder;
f568d64d 91 AV *xop_record;
85ce96a1
DM		 92} my_cxt_t;
93
94START_MY_CXT
95
80c1439f
DM		 96int
97S_myset_set(pTHX_ SV* sv, MAGIC* mg)
98{
99 SV *isv = (SV*)mg->mg_ptr;
100
101 PERL_UNUSED_ARG(sv);
102 SvIVX(isv)++;
103 return 0;
104}
105
26ab20ee 106MGVTBL vtbl_foo, vtbl_bar;
80c1439f
DM		 107MGVTBL vtbl_myset = { 0, S_myset_set, 0, 0, 0, 0, 0, 0 };
108
26ab20ee 109
85ce96a1 110/* indirect functions to test the [pa]MY_CXT macros */
f16dd614 111
85ce96a1
DM		 112int
113my_cxt_getint_p(pMY_CXT)
114{
115 return MY_CXT.i;
116}
f16dd614 117
85ce96a1
DM		 118void
119my_cxt_setint_p(pMY_CXT_ int i)
120{
121 MY_CXT.i = i;
122}
f16dd614
DM		 123
124SV*
9568a123 125my_cxt_getsv_interp_context(void)
f16dd614 126{
f16dd614
DM		 127 dTHX;
128 dMY_CXT_INTERP(my_perl);
9568a123
NC		 129 return MY_CXT.sv;
130}
131
132SV*
133my_cxt_getsv_interp(void)
134{
f16dd614 135 dMY_CXT;
f16dd614
DM		 136 return MY_CXT.sv;
137}
138
85ce96a1
DM		 139void
140my_cxt_setsv_p(SV* sv _pMY_CXT)
141{
142 MY_CXT.sv = sv;
143}
144
145
9b5c3821 146/* from exception.c */
7a646707 147int apitest_exception(int);
0314122a 148
ff66e713
SH		 149/* from core_or_not.inc */
150bool sv_setsv_cow_hashkey_core(void);
151bool sv_setsv_cow_hashkey_notcore(void);
152
2dc92170
NC		 153/* A routine to test hv_delayfree_ent
154 (which itself is tested by testing on hv_free_ent */
155
5aaab254 156typedef void (freeent_function)(pTHX_ HV *, HE *);
2dc92170
NC		 157
158void
2e66fe90 159test_freeent(freeent_function *f) {
2dc92170
NC		 160 dSP;
161 HV *test_hash = newHV();
162 HE *victim;
163 SV *test_scalar;
164 U32 results[4];
165 int i;
166
8afd2d2e
NC		 167#ifdef PURIFY
168 victim = (HE*)safemalloc(sizeof(HE));
169#else
2dc92170
NC		 170 /* Storing then deleting something should ensure that a hash entry is
171 available. */
33e1c218
YO		 172 (void) hv_stores(test_hash, "", &PL_sv_yes);
173 (void) hv_deletes(test_hash, "", 0);
2dc92170
NC		 174
175 /* We need to "inline" new_he here as it's static, and the functions we
176 test expect to be able to call del_HE on the HE */
6a93a7e5 177 if (!PL_body_roots[HE_SVSLOT])
2dc92170 178 croak("PL_he_root is 0");
8a722a80 179 victim = (HE*) PL_body_roots[HE_SVSLOT];
6a93a7e5 180 PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
8afd2d2e 181#endif
2dc92170
NC		 182
183 victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
184
185 test_scalar = newSV(0);
186 SvREFCNT_inc(test_scalar);
de616631 187 HeVAL(victim) = test_scalar;
2dc92170
NC		 188
189 /* Need this little game else we free the temps on the return stack. */
190 results[0] = SvREFCNT(test_scalar);
191 SAVETMPS;
192 results[1] = SvREFCNT(test_scalar);
193 f(aTHX_ test_hash, victim);
194 results[2] = SvREFCNT(test_scalar);
195 FREETMPS;
196 results[3] = SvREFCNT(test_scalar);
197
198 i = 0;
199 do {
200 mPUSHu(results[i]);
c33e8be1 201 } while (++i < (int)(sizeof(results)/sizeof(results[0])));
2dc92170
NC		 202
203 /* Goodbye to our extra reference. */
204 SvREFCNT_dec(test_scalar);
205}
206
7425681b
KW		 207/* Not that it matters much, but it's handy for the flipped character to just
208 * be the opposite case (at least for ASCII-range and most Latin1 as well). */
209#define FLIP_BIT ('A' ^ 'a')
b54b4831
NC		 210
211static I32
53c40a8f
NC		 212bitflip_key(pTHX_ IV action, SV *field) {
213 MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
214 SV *keysv;
c33e8be1 215 PERL_UNUSED_ARG(action);
53c40a8f
NC		 216 if (mg && (keysv = mg->mg_obj)) {
217 STRLEN len;
218 const char *p = SvPV(keysv, len);
219
220 if (len) {
7425681b
KW		 221 /* Allow for the flipped val to be longer than the original. This
222 * is just for testing, so can afford to have some slop */
223 const STRLEN newlen = len * 2;
224
225 SV *newkey = newSV(newlen);
226 const char * const new_p_orig = SvPVX(newkey);
227 char *new_p = (char *) new_p_orig;
53c40a8f
NC		 228
229 if (SvUTF8(keysv)) {
230 const char *const end = p + len;
231 while (p < end) {
7425681b
KW		 232 STRLEN curlen;
233 UV chr = utf8_to_uvchr_buf((U8 *)p, (U8 *) end, &curlen);
234
235 /* Make sure don't exceed bounds */
236 assert(new_p - new_p_orig + curlen < newlen);
237
238 new_p = (char *)uvchr_to_utf8((U8 *)new_p, chr ^ FLIP_BIT);
239 p += curlen;
53c40a8f
NC		 240 }
241 SvUTF8_on(newkey);
242 } else {
243 while (len--)
7425681b 244 *new_p++ = *p++ ^ FLIP_BIT;
53c40a8f
NC		 245 }
246 *new_p = '\0';
7425681b 247 SvCUR_set(newkey, new_p - new_p_orig);
53c40a8f
NC		 248 SvPOK_on(newkey);
249
250 mg->mg_obj = newkey;
251 }
252 }
253 return 0;
254}
255
256static I32
b54b4831
NC		 257rot13_key(pTHX_ IV action, SV *field) {
258 MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
259 SV *keysv;
c33e8be1 260 PERL_UNUSED_ARG(action);
b54b4831
NC		 261 if (mg && (keysv = mg->mg_obj)) {
262 STRLEN len;
263 const char *p = SvPV(keysv, len);
264
265 if (len) {
266 SV *newkey = newSV(len);
267 char *new_p = SvPVX(newkey);
268
269 /* There's a deliberate fencepost error here to loop len + 1 times
270 to copy the trailing \0 */
271 do {
272 char new_c = *p++;
273 /* Try doing this cleanly and clearly in EBCDIC another way: */
274 switch (new_c) {
275 case 'A': new_c = 'N'; break;
276 case 'B': new_c = 'O'; break;
277 case 'C': new_c = 'P'; break;
278 case 'D': new_c = 'Q'; break;
279 case 'E': new_c = 'R'; break;
280 case 'F': new_c = 'S'; break;
281 case 'G': new_c = 'T'; break;
282 case 'H': new_c = 'U'; break;
283 case 'I': new_c = 'V'; break;
284 case 'J': new_c = 'W'; break;
285 case 'K': new_c = 'X'; break;
286 case 'L': new_c = 'Y'; break;
287 case 'M': new_c = 'Z'; break;
288 case 'N': new_c = 'A'; break;
289 case 'O': new_c = 'B'; break;
290 case 'P': new_c = 'C'; break;
291 case 'Q': new_c = 'D'; break;
292 case 'R': new_c = 'E'; break;
293 case 'S': new_c = 'F'; break;
294 case 'T': new_c = 'G'; break;
295 case 'U': new_c = 'H'; break;
296 case 'V': new_c = 'I'; break;
297 case 'W': new_c = 'J'; break;
298 case 'X': new_c = 'K'; break;
299 case 'Y': new_c = 'L'; break;
300 case 'Z': new_c = 'M'; break;
301 case 'a': new_c = 'n'; break;
302 case 'b': new_c = 'o'; break;
303 case 'c': new_c = 'p'; break;
304 case 'd': new_c = 'q'; break;
305 case 'e': new_c = 'r'; break;
306 case 'f': new_c = 's'; break;
307 case 'g': new_c = 't'; break;
308 case 'h': new_c = 'u'; break;
309 case 'i': new_c = 'v'; break;
310 case 'j': new_c = 'w'; break;
311 case 'k': new_c = 'x'; break;
312 case 'l': new_c = 'y'; break;
313 case 'm': new_c = 'z'; break;
314 case 'n': new_c = 'a'; break;
315 case 'o': new_c = 'b'; break;
316 case 'p': new_c = 'c'; break;
317 case 'q': new_c = 'd'; break;
318 case 'r': new_c = 'e'; break;
319 case 's': new_c = 'f'; break;
320 case 't': new_c = 'g'; break;
321 case 'u': new_c = 'h'; break;
322 case 'v': new_c = 'i'; break;
323 case 'w': new_c = 'j'; break;
324 case 'x': new_c = 'k'; break;
325 case 'y': new_c = 'l'; break;
326 case 'z': new_c = 'm'; break;
327 }
328 *new_p++ = new_c;
329 } while (len--);
330 SvCUR_set(newkey, SvCUR(keysv));
331 SvPOK_on(newkey);
332 if (SvUTF8(keysv))
333 SvUTF8_on(newkey);
334
335 mg->mg_obj = newkey;
336 }
337 }
338 return 0;
339}
340
218787bd
VP		 341STATIC I32
342rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
c33e8be1
Z		 343 PERL_UNUSED_ARG(idx);
344 PERL_UNUSED_ARG(sv);
218787bd
VP		 345 return 0;
346}
347
50495f39
JH		 348/* We could do "= { 0 };" but some versions of gcc do warn
349 * (with -Wextra) about missing initializer, this is probably gcc
350 * being a bit too paranoid. But since this is file-static, we can
351 * just have it without initializer, since it should get
352 * zero-initialized. */
353STATIC MGVTBL rmagical_b;
218787bd 354
03569ecf 355STATIC void
13b6b3bc 356blockhook_csc_start(pTHX_ int full)
03569ecf
BM		 357{
358 dMY_CXT;
359 AV *const cur = GvAV(MY_CXT.cscgv);
360
c33e8be1 361 PERL_UNUSED_ARG(full);
03569ecf
BM		 362 SAVEGENERICSV(GvAV(MY_CXT.cscgv));
363
364 if (cur) {
365 I32 i;
d024465f 366 AV *const new_av = newAV();
03569ecf 367
b9f2b683 368 for (i = 0; i <= av_tindex(cur); i++) {
d024465f 369 av_store(new_av, i, newSVsv(*av_fetch(cur, i, 0)));
03569ecf
BM		 370 }
371
d024465f 372 GvAV(MY_CXT.cscgv) = new_av;
03569ecf
BM		 373 }
374}
375
376STATIC void
13b6b3bc 377blockhook_csc_pre_end(pTHX_ OP **o)
03569ecf
BM		 378{
379 dMY_CXT;
380
c33e8be1 381 PERL_UNUSED_ARG(o);
03569ecf
BM		 382 /* if we hit the end of a scope we missed the start of, we need to
383 * unconditionally clear @CSC */
52db365a 384 if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) {
03569ecf 385 av_clear(MY_CXT.cscav);
52db365a 386 }
03569ecf
BM		 387
388}
389
13b6b3bc
BM		 390STATIC void
391blockhook_test_start(pTHX_ int full)
392{
393 dMY_CXT;
394 AV *av;
395
396 if (MY_CXT.bhk_record) {
397 av = newAV();
398 av_push(av, newSVpvs("start"));
399 av_push(av, newSViv(full));
400 av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
401 }
402}
403
404STATIC void
405blockhook_test_pre_end(pTHX_ OP **o)
406{
407 dMY_CXT;
408
c33e8be1 409 PERL_UNUSED_ARG(o);
13b6b3bc
BM		 410 if (MY_CXT.bhk_record)
411 av_push(MY_CXT.bhkav, newSVpvs("pre_end"));
412}
413
414STATIC void
415blockhook_test_post_end(pTHX_ OP **o)
416{
417 dMY_CXT;
418
c33e8be1 419 PERL_UNUSED_ARG(o);
13b6b3bc
BM		 420 if (MY_CXT.bhk_record)
421 av_push(MY_CXT.bhkav, newSVpvs("post_end"));
422}
423
424STATIC void
425blockhook_test_eval(pTHX_ OP *const o)
426{
427 dMY_CXT;
428 AV *av;
429
430 if (MY_CXT.bhk_record) {
431 av = newAV();
432 av_push(av, newSVpvs("eval"));
433 av_push(av, newSVpv(OP_NAME(o), 0));
434 av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
435 }
436}
437
438STATIC BHK bhk_csc, bhk_test;
439
201c7e1f
FR		 440STATIC void
441my_peep (pTHX_ OP *o)
442{
443 dMY_CXT;
444
445 if (!o)
446 return;
447
448 MY_CXT.orig_peep(aTHX_ o);
449
450 if (!MY_CXT.peep_recording)
451 return;
452
453 for (; o; o = o->op_next) {
454 if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
455 av_push(MY_CXT.peep_recorder, newSVsv(cSVOPx_sv(o)));
456 }
457 }
458}
459
460STATIC void
461my_rpeep (pTHX_ OP *o)
462{
463 dMY_CXT;
464
465 if (!o)
466 return;
467
468 MY_CXT.orig_rpeep(aTHX_ o);
469
470 if (!MY_CXT.peep_recording)
471 return;
472
473 for (; o; o = o->op_next) {
474 if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
475 av_push(MY_CXT.rpeep_recorder, newSVsv(cSVOPx_sv(o)));
476 }
477 }
478}
479
d9088386
Z		 480STATIC OP *
481THX_ck_entersub_args_lists(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
482{
c33e8be1
Z		 483 PERL_UNUSED_ARG(namegv);
484 PERL_UNUSED_ARG(ckobj);
d9088386
Z		 485 return ck_entersub_args_list(entersubop);
486}
487
488STATIC OP *
489THX_ck_entersub_args_scalars(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
490{
491 OP *aop = cUNOPx(entersubop)->op_first;
c33e8be1
Z		 492 PERL_UNUSED_ARG(namegv);
493 PERL_UNUSED_ARG(ckobj);
e6dae479 494 if (!OpHAS_SIBLING(aop))
d9088386 495 aop = cUNOPx(aop)->op_first;
e6dae479 496 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
d9088386
Z		 497 op_contextualize(aop, G_SCALAR);
498 }
499 return entersubop;
500}
501
502STATIC OP *
503THX_ck_entersub_multi_sum(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
504{
505 OP *sumop = NULL;
3253bf85 506 OP *parent = entersubop;
d9088386 507 OP *pushop = cUNOPx(entersubop)->op_first;
c33e8be1
Z		 508 PERL_UNUSED_ARG(namegv);
509 PERL_UNUSED_ARG(ckobj);
e6dae479 510 if (!OpHAS_SIBLING(pushop)) {
3253bf85 511 parent = pushop;
d9088386 512 pushop = cUNOPx(pushop)->op_first;
3253bf85 513 }
d9088386 514 while (1) {
e6dae479
FC		 515 OP *aop = OpSIBLING(pushop);
516 if (!OpHAS_SIBLING(aop))
d9088386 517 break;
3253bf85
DM		 518 /* cut out first arg */
519 op_sibling_splice(parent, pushop, 1, NULL);
d9088386
Z		 520 op_contextualize(aop, G_SCALAR);
521 if (sumop) {
522 sumop = newBINOP(OP_ADD, 0, sumop, aop);
523 } else {
524 sumop = aop;
525 }
526 }
527 if (!sumop)
528 sumop = newSVOP(OP_CONST, 0, newSViv(0));
529 op_free(entersubop);
530 return sumop;
531}
532
2e66fe90 533STATIC void test_op_list_describe_part(SV *res, OP *o);
2fcb4757 534STATIC void
2e66fe90 535test_op_list_describe_part(SV *res, OP *o)
2fcb4757
Z		 536{
537 sv_catpv(res, PL_op_name[o->op_type]);
538 switch (o->op_type) {
539 case OP_CONST: {
540 sv_catpvf(res, "(%d)", (int)SvIV(cSVOPx(o)->op_sv));
541 } break;
542 }
543 if (o->op_flags & OPf_KIDS) {
544 OP *k;
545 sv_catpvs(res, "[");
e6dae479 546 for (k = cUNOPx(o)->op_first; k; k = OpSIBLING(k))
2e66fe90 547 test_op_list_describe_part(res, k);
2fcb4757
Z		 548 sv_catpvs(res, "]");
549 } else {
550 sv_catpvs(res, ".");
551 }
552}
553
554STATIC char *
2e66fe90 555test_op_list_describe(OP *o)
2fcb4757
Z		 556{
557 SV *res = sv_2mortal(newSVpvs(""));
558 if (o)
2e66fe90 559 test_op_list_describe_part(res, o);
2fcb4757
Z		 560 return SvPVX(res);
561}
562
b7b1e41b 563/* the real new*OP functions have a tendency to call fold_constants, and
5983a79d
BM		 564 * other such unhelpful things, so we need our own versions for testing */
565
566#define mkUNOP(t, f) THX_mkUNOP(aTHX_ (t), (f))
567static OP *
568THX_mkUNOP(pTHX_ U32 type, OP *first)
569{
570 UNOP *unop;
571 NewOp(1103, unop, 1, UNOP);
572 unop->op_type = (OPCODE)type;
29e61fd9 573 op_sibling_splice((OP*)unop, NULL, 0, first);
5983a79d
BM		 574 return (OP *)unop;
575}
576
577#define mkBINOP(t, f, l) THX_mkBINOP(aTHX_ (t), (f), (l))
578static OP *
579THX_mkBINOP(pTHX_ U32 type, OP *first, OP *last)
580{
581 BINOP *binop;
582 NewOp(1103, binop, 1, BINOP);
583 binop->op_type = (OPCODE)type;
29e61fd9
DM		 584 op_sibling_splice((OP*)binop, NULL, 0, last);
585 op_sibling_splice((OP*)binop, NULL, 0, first);
5983a79d
BM		 586 return (OP *)binop;
587}
588
589#define mkLISTOP(t, f, s, l) THX_mkLISTOP(aTHX_ (t), (f), (s), (l))
590static OP *
591THX_mkLISTOP(pTHX_ U32 type, OP *first, OP *sib, OP *last)
592{
593 LISTOP *listop;
594 NewOp(1103, listop, 1, LISTOP);
595 listop->op_type = (OPCODE)type;
29e61fd9
DM		 596 op_sibling_splice((OP*)listop, NULL, 0, last);
597 op_sibling_splice((OP*)listop, NULL, 0, sib);
598 op_sibling_splice((OP*)listop, NULL, 0, first);
5983a79d
BM		 599 return (OP *)listop;
600}
601
602static char *
2e66fe90 603test_op_linklist_describe(OP *start)
5983a79d
BM		 604{
605 SV *rv = sv_2mortal(newSVpvs(""));
606 OP *o;
607 o = start = LINKLIST(start);
608 do {
609 sv_catpvs(rv, ".");
610 sv_catpv(rv, OP_NAME(o));
611 if (o->op_type == OP_CONST)
612 sv_catsv(rv, cSVOPo->op_sv);
613 o = o->op_next;
614 } while (o && o != start);
615 return SvPVX(rv);
616}
617
8f89e5a9
Z		 618/** establish_cleanup operator, ripped off from Scope::Cleanup **/
619
620STATIC void
621THX_run_cleanup(pTHX_ void *cleanup_code_ref)
622{
623 dSP;
a59fa18f 624 PUSHSTACK;
8f89e5a9
Z		 625 ENTER;
626 SAVETMPS;
627 PUSHMARK(SP);
628 call_sv((SV*)cleanup_code_ref, G_VOID|G_DISCARD);
629 FREETMPS;
630 LEAVE;
a59fa18f 631 POPSTACK;
8f89e5a9
Z		 632}
633
634STATIC OP *
635THX_pp_establish_cleanup(pTHX)
636{
637 dSP;
638 SV *cleanup_code_ref;
639 cleanup_code_ref = newSVsv(POPs);
640 SAVEFREESV(cleanup_code_ref);
641 SAVEDESTRUCTOR_X(THX_run_cleanup, cleanup_code_ref);
642 if(GIMME_V != G_VOID) PUSHs(&PL_sv_undef);
643 RETURN;
644}
645
646STATIC OP *
647THX_ck_entersub_establish_cleanup(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
648{
3253bf85 649 OP *parent, *pushop, *argop, *estop;
8f89e5a9 650 ck_entersub_args_proto(entersubop, namegv, ckobj);
3253bf85 651 parent = entersubop;
8f89e5a9 652 pushop = cUNOPx(entersubop)->op_first;
e6dae479 653 if(!OpHAS_SIBLING(pushop)) {
3253bf85 654 parent = pushop;
1ed44841 655 pushop = cUNOPx(pushop)->op_first;
3253bf85
DM		 656 }
657 /* extract out first arg, then delete the rest of the tree */
e6dae479 658 argop = OpSIBLING(pushop);
3253bf85 659 op_sibling_splice(parent, pushop, 1, NULL);
8f89e5a9 660 op_free(entersubop);
3253bf85
DM		 661
662 estop = mkUNOP(OP_RAND, argop);
8f89e5a9 663 estop->op_ppaddr = THX_pp_establish_cleanup;
8f89e5a9
Z		 664 PL_hints |= HINT_BLOCK_SCOPE;
665 return estop;
666}
667
3ad73efd
Z		 668STATIC OP *
669THX_ck_entersub_postinc(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
670{
3253bf85 671 OP *parent, *pushop, *argop;
3ad73efd 672 ck_entersub_args_proto(entersubop, namegv, ckobj);
3253bf85 673 parent = entersubop;
3ad73efd 674 pushop = cUNOPx(entersubop)->op_first;
e6dae479 675 if(!OpHAS_SIBLING(pushop)) {
3253bf85 676 parent = pushop;
1ed44841 677 pushop = cUNOPx(pushop)->op_first;
3253bf85 678 }
e6dae479 679 argop = OpSIBLING(pushop);
3253bf85 680 op_sibling_splice(parent, pushop, 1, NULL);
3ad73efd
Z		 681 op_free(entersubop);
682 return newUNOP(OP_POSTINC, 0,
683 op_lvalue(op_contextualize(argop, G_SCALAR), OP_POSTINC));
684}
685
15103811
Z		 686STATIC OP *
687THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
688{
689 OP *pushop, *argop;
690 PADOFFSET padoff = NOT_IN_PAD;
691 SV *a0, *a1;
692 ck_entersub_args_proto(entersubop, namegv, ckobj);
693 pushop = cUNOPx(entersubop)->op_first;
e6dae479 694 if(!OpHAS_SIBLING(pushop))
1ed44841 695 pushop = cUNOPx(pushop)->op_first;
e6dae479
FC		 696 argop = OpSIBLING(pushop);
697 if(argop->op_type != OP_CONST || OpSIBLING(argop)->op_type != OP_CONST)
15103811
Z		 698 croak("bad argument expression type for pad_scalar()");
699 a0 = cSVOPx_sv(argop);
e6dae479 700 a1 = cSVOPx_sv(OpSIBLING(argop));
15103811
Z		 701 switch(SvIV(a0)) {
702 case 1: {
703 SV *namesv = sv_2mortal(newSVpvs("$"));
704 sv_catsv(namesv, a1);
705 padoff = pad_findmy_sv(namesv, 0);
706 } break;
707 case 2: {
708 char *namepv;
709 STRLEN namelen;
710 SV *namesv = sv_2mortal(newSVpvs("$"));
711 sv_catsv(namesv, a1);
712 namepv = SvPV(namesv, namelen);
ab8f91e9 713 padoff = pad_findmy_pvn(namepv, namelen, SvUTF8(namesv));
15103811
Z		 714 } break;
715 case 3: {
716 char *namepv;
717 SV *namesv = sv_2mortal(newSVpvs("$"));
718 sv_catsv(namesv, a1);
719 namepv = SvPV_nolen(namesv);
ab8f91e9 720 padoff = pad_findmy_pv(namepv, SvUTF8(namesv));
15103811
Z		 721 } break;
722 case 4: {
723 padoff = pad_findmy_pvs("$foo", 0);
724 } break;
725 default: croak("bad type value for pad_scalar()");
726 }
727 op_free(entersubop);
728 if(padoff == NOT_IN_PAD) {
729 return newSVOP(OP_CONST, 0, newSVpvs("NOT_IN_PAD"));
730 } else if(PAD_COMPNAME_FLAGS_isOUR(padoff)) {
731 return newSVOP(OP_CONST, 0, newSVpvs("NOT_MY"));
732 } else {
733 OP *padop = newOP(OP_PADSV, 0);
734 padop->op_targ = padoff;
735 return padop;
736 }
737}
738
83f8bb56
Z		 739/** RPN keyword parser **/
740
741#define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
742#define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
743#define sv_is_string(sv) \
744 (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
745 (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
746
747static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv, *hintkey_stufftest_sv;
07ffcb73 748static SV *hintkey_swaptwostmts_sv, *hintkey_looprest_sv;
a7aaec61 749static SV *hintkey_scopelessblock_sv;
e53d8f76
Z		 750static SV *hintkey_stmtasexpr_sv, *hintkey_stmtsasexpr_sv;
751static SV *hintkey_loopblock_sv, *hintkey_blockasexpr_sv;
361d9b55 752static SV *hintkey_swaplabel_sv, *hintkey_labelconst_sv;
78cdf107
Z		 753static SV *hintkey_arrayfullexpr_sv, *hintkey_arraylistexpr_sv;
754static SV *hintkey_arraytermexpr_sv, *hintkey_arrayarithexpr_sv;
755static SV *hintkey_arrayexprflags_sv;
ce409cc8 756static SV *hintkey_DEFSV_sv;
25f5d540 757static SV *hintkey_with_vars_sv;
03d05f6e 758static SV *hintkey_join_with_space_sv;
83f8bb56
Z		 759static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
760
761/* low-level parser helpers */
762
763#define PL_bufptr (PL_parser->bufptr)
764#define PL_bufend (PL_parser->bufend)
765
766/* RPN parser */
767
768#define parse_var() THX_parse_var(aTHX)
769static OP *THX_parse_var(pTHX)
770{
771 char *s = PL_bufptr;
772 char *start = s;
773 PADOFFSET varpos;
774 OP *padop;
775 if(*s != '$') croak("RPN syntax error");
776 while(1) {
777 char c = *++s;
778 if(!isALNUM(c)) break;
779 }
780 if(s-start < 2) croak("RPN syntax error");
781 lex_read_to(s);
cc76b5cc 782 varpos = pad_findmy_pvn(start, s-start, 0);
83f8bb56
Z		 783 if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
784 croak("RPN only supports \"my\" variables");
785 padop = newOP(OP_PADSV, 0);
786 padop->op_targ = varpos;
787 return padop;
788}
789
790#define push_rpn_item(o) \
3253bf85
DM		 791 op_sibling_splice(parent, NULL, 0, o);
792#define pop_rpn_item() ( \
793 (tmpop = op_sibling_splice(parent, NULL, 1, NULL)) \
794 ? tmpop : (croak("RPN stack underflow"), (OP*)NULL))
83f8bb56
Z		 795
796#define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
797static OP *THX_parse_rpn_expr(pTHX)
798{
3253bf85
DM		 799 OP *tmpop;
800 /* fake parent for splice to mess with */
801 OP *parent = mkBINOP(OP_NULL, NULL, NULL);
802
83f8bb56
Z		 803 while(1) {
804 I32 c;
805 lex_read_space(0);
806 c = lex_peek_unichar(0);
807 switch(c) {
808 case /*(*/')': case /*{*/'}': {
809 OP *result = pop_rpn_item();
3253bf85
DM		 810 if(cLISTOPx(parent)->op_first)
811 croak("RPN expression must return a single value");
812 op_free(parent);
83f8bb56
Z		 813 return result;
814 } break;
815 case '0': case '1': case '2': case '3': case '4':
816 case '5': case '6': case '7': case '8': case '9': {
817 UV val = 0;
818 do {
819 lex_read_unichar(0);
820 val = 10*val + (c - '0');
821 c = lex_peek_unichar(0);
822 } while(c >= '0' && c <= '9');
823 push_rpn_item(newSVOP(OP_CONST, 0, newSVuv(val)));
824 } break;
825 case '$': {
826 push_rpn_item(parse_var());
827 } break;
828 case '+': {
829 OP *b = pop_rpn_item();
830 OP *a = pop_rpn_item();
831 lex_read_unichar(0);
832 push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
833 } break;
834 case '-': {
835 OP *b = pop_rpn_item();
836 OP *a = pop_rpn_item();
837 lex_read_unichar(0);
838 push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
839 } break;
840 case '*': {
841 OP *b = pop_rpn_item();
842 OP *a = pop_rpn_item();
843 lex_read_unichar(0);
844 push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
845 } break;
846 case '/': {
847 OP *b = pop_rpn_item();
848 OP *a = pop_rpn_item();
849 lex_read_unichar(0);
850 push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
851 } break;
852 case '%': {
853 OP *b = pop_rpn_item();
854 OP *a = pop_rpn_item();
855 lex_read_unichar(0);
856 push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
857 } break;
858 default: {
859 croak("RPN syntax error");
860 } break;
861 }
862 }
863}
864
865#define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
866static OP *THX_parse_keyword_rpn(pTHX)
867{
868 OP *op;
869 lex_read_space(0);
870 if(lex_peek_unichar(0) != '('/*)*/)
871 croak("RPN expression must be parenthesised");
872 lex_read_unichar(0);
873 op = parse_rpn_expr();
874 if(lex_peek_unichar(0) != /*(*/')')
875 croak("RPN expression must be parenthesised");
876 lex_read_unichar(0);
877 return op;
878}
879
880#define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
881static OP *THX_parse_keyword_calcrpn(pTHX)
882{
883 OP *varop, *exprop;
884 lex_read_space(0);
885 varop = parse_var();
886 lex_read_space(0);
887 if(lex_peek_unichar(0) != '{'/*}*/)
888 croak("RPN expression must be braced");
889 lex_read_unichar(0);
890 exprop = parse_rpn_expr();
891 if(lex_peek_unichar(0) != /*{*/'}')
892 croak("RPN expression must be braced");
893 lex_read_unichar(0);
894 return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
895}
896
897#define parse_keyword_stufftest() THX_parse_keyword_stufftest(aTHX)
898static OP *THX_parse_keyword_stufftest(pTHX)
899{
900 I32 c;
901 bool do_stuff;
902 lex_read_space(0);
903 do_stuff = lex_peek_unichar(0) == '+';
904 if(do_stuff) {
905 lex_read_unichar(0);
906 lex_read_space(0);
907 }
908 c = lex_peek_unichar(0);
909 if(c == ';') {
910 lex_read_unichar(0);
911 } else if(c != /*{*/'}') {
912 croak("syntax error");
913 }
914 if(do_stuff) lex_stuff_pvs(" ", 0);
915 return newOP(OP_NULL, 0);
916}
917
918#define parse_keyword_swaptwostmts() THX_parse_keyword_swaptwostmts(aTHX)
919static OP *THX_parse_keyword_swaptwostmts(pTHX)
920{
921 OP *a, *b;
922 a = parse_fullstmt(0);
923 b = parse_fullstmt(0);
924 if(a && b)
925 PL_hints |= HINT_BLOCK_SCOPE;
2fcb4757 926 return op_append_list(OP_LINESEQ, b, a);
83f8bb56
Z		 927}
928
07ffcb73
Z		 929#define parse_keyword_looprest() THX_parse_keyword_looprest(aTHX)
930static OP *THX_parse_keyword_looprest(pTHX)
931{
94bf0465
Z		 932 return newWHILEOP(0, 1, NULL, newSVOP(OP_CONST, 0, &PL_sv_yes),
933 parse_stmtseq(0), NULL, 1);
07ffcb73
Z		 934}
935
a7aaec61
Z		 936#define parse_keyword_scopelessblock() THX_parse_keyword_scopelessblock(aTHX)
937static OP *THX_parse_keyword_scopelessblock(pTHX)
938{
939 I32 c;
940 OP *body;
941 lex_read_space(0);
942 if(lex_peek_unichar(0) != '{'/*}*/) croak("syntax error");
943 lex_read_unichar(0);
944 body = parse_stmtseq(0);
945 c = lex_peek_unichar(0);
946 if(c != /*{*/'}' && c != /*[*/']' && c != /*(*/')') croak("syntax error");
947 lex_read_unichar(0);
948 return body;
949}
950
9eb5c532
Z		 951#define parse_keyword_stmtasexpr() THX_parse_keyword_stmtasexpr(aTHX)
952static OP *THX_parse_keyword_stmtasexpr(pTHX)
953{
8359b381 954 OP *o = parse_barestmt(0);
3ad73efd
Z		 955 if (!o) o = newOP(OP_STUB, 0);
956 if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
957 return op_scope(o);
9eb5c532
Z		 958}
959
960#define parse_keyword_stmtsasexpr() THX_parse_keyword_stmtsasexpr(aTHX)
961static OP *THX_parse_keyword_stmtsasexpr(pTHX)
962{
963 OP *o;
964 lex_read_space(0);
965 if(lex_peek_unichar(0) != '{'/*}*/) croak("syntax error");
966 lex_read_unichar(0);
967 o = parse_stmtseq(0);
968 lex_read_space(0);
969 if(lex_peek_unichar(0) != /*{*/'}') croak("syntax error");
970 lex_read_unichar(0);
3ad73efd
Z		 971 if (!o) o = newOP(OP_STUB, 0);
972 if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
973 return op_scope(o);
9eb5c532
Z		 974}
975
e53d8f76
Z		 976#define parse_keyword_loopblock() THX_parse_keyword_loopblock(aTHX)
977static OP *THX_parse_keyword_loopblock(pTHX)
978{
94bf0465
Z		 979 return newWHILEOP(0, 1, NULL, newSVOP(OP_CONST, 0, &PL_sv_yes),
980 parse_block(0), NULL, 1);
e53d8f76
Z		 981}
982
983#define parse_keyword_blockasexpr() THX_parse_keyword_blockasexpr(aTHX)
984static OP *THX_parse_keyword_blockasexpr(pTHX)
985{
986 OP *o = parse_block(0);
3ad73efd
Z		 987 if (!o) o = newOP(OP_STUB, 0);
988 if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
989 return op_scope(o);
e53d8f76
Z		 990}
991
361d9b55
Z		 992#define parse_keyword_swaplabel() THX_parse_keyword_swaplabel(aTHX)
993static OP *THX_parse_keyword_swaplabel(pTHX)
994{
995 OP *sop = parse_barestmt(0);
996 SV *label = parse_label(PARSE_OPTIONAL);
997 if (label) sv_2mortal(label);
5db1eb8d
BF		 998 return newSTATEOP(label ? SvUTF8(label) : 0,
999 label ? savepv(SvPVX(label)) : NULL,
1000 sop);
361d9b55
Z		 1001}
1002
1003#define parse_keyword_labelconst() THX_parse_keyword_labelconst(aTHX)
1004static OP *THX_parse_keyword_labelconst(pTHX)
1005{
1006 return newSVOP(OP_CONST, 0, parse_label(0));
1007}
1008
78cdf107
Z		 1009#define parse_keyword_arrayfullexpr() THX_parse_keyword_arrayfullexpr(aTHX)
1010static OP *THX_parse_keyword_arrayfullexpr(pTHX)
1011{
1012 return newANONLIST(parse_fullexpr(0));
1013}
1014
1015#define parse_keyword_arraylistexpr() THX_parse_keyword_arraylistexpr(aTHX)
1016static OP *THX_parse_keyword_arraylistexpr(pTHX)
1017{
1018 return newANONLIST(parse_listexpr(0));
1019}
1020
1021#define parse_keyword_arraytermexpr() THX_parse_keyword_arraytermexpr(aTHX)
1022static OP *THX_parse_keyword_arraytermexpr(pTHX)
1023{
1024 return newANONLIST(parse_termexpr(0));
1025}
1026
1027#define parse_keyword_arrayarithexpr() THX_parse_keyword_arrayarithexpr(aTHX)
1028static OP *THX_parse_keyword_arrayarithexpr(pTHX)
1029{
1030 return newANONLIST(parse_arithexpr(0));
1031}
1032
1033#define parse_keyword_arrayexprflags() THX_parse_keyword_arrayexprflags(aTHX)
1034static OP *THX_parse_keyword_arrayexprflags(pTHX)
1035{
1036 U32 flags = 0;
1037 I32 c;
1038 OP *o;
1039 lex_read_space(0);
1040 c = lex_peek_unichar(0);
1041 if (c != '!' && c != '?') croak("syntax error");
1042 lex_read_unichar(0);
1043 if (c == '?') flags |= PARSE_OPTIONAL;
1044 o = parse_listexpr(flags);
1045 return o ? newANONLIST(o) : newANONHASH(newOP(OP_STUB, 0));
1046}
1047
ce409cc8
LM		 1048#define parse_keyword_DEFSV() THX_parse_keyword_DEFSV(aTHX)
1049static OP *THX_parse_keyword_DEFSV(pTHX)
1050{
1051 return newDEFSVOP();
1052}
1053
1d07f51c
LM		 1054#define sv_cat_c(a,b) THX_sv_cat_c(aTHX_ a, b)
1055static void THX_sv_cat_c(pTHX_ SV *sv, U32 c) {
25f5d540
LM		 1056 char ds[UTF8_MAXBYTES + 1], *d;
1057 d = (char *)uvchr_to_utf8((U8 *)ds, c);
1058 if (d - ds > 1) {
1059 sv_utf8_upgrade(sv);
1060 }
1061 sv_catpvn(sv, ds, d - ds);
1062}
1063
1064#define parse_keyword_with_vars() THX_parse_keyword_with_vars(aTHX)
1065static OP *THX_parse_keyword_with_vars(pTHX)
1066{
1067 I32 c;
1068 IV count;
1069 int save_ix;
1070 OP *vardeclseq, *body;
1071
1072 save_ix = block_start(TRUE);
1073 vardeclseq = NULL;
1074
1075 count = 0;
1076
1077 lex_read_space(0);
1078 c = lex_peek_unichar(0);
1079 while (c != '{') {
1080 SV *varname;
1081 PADOFFSET padoff;
1082
1083 if (c == -1) {
1084 croak("unexpected EOF; expecting '{'");
1085 }
1086
1087 if (!isIDFIRST_uni(c)) {
1088 croak("unexpected '%c'; expecting an identifier", (int)c);
1089 }
1090
1091 varname = newSVpvs("$");
1092 if (lex_bufutf8()) {
1093 SvUTF8_on(varname);
1094 }
1095
1096 sv_cat_c(varname, c);
1097 lex_read_unichar(0);
1098
1099 while (c = lex_peek_unichar(0), c != -1 && isIDCONT_uni(c)) {
1100 sv_cat_c(varname, c);
1101 lex_read_unichar(0);
1102 }
1103
1104 padoff = pad_add_name_sv(varname, padadd_NO_DUP_CHECK, NULL, NULL);
1105
1106 {
1107 OP *my_var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8));
1108 my_var->op_targ = padoff;
1109
1110 vardeclseq = op_append_list(
1111 OP_LINESEQ,
1112 vardeclseq,
1113 newSTATEOP(
1114 0, NULL,
1115 newASSIGNOP(
1116 OPf_STACKED,
1117 my_var, 0,
1118 newSVOP(
1119 OP_CONST, 0,
1120 newSViv(++count)
1121 )
1122 )
1123 )
1124 );
1125 }
1126
1127 lex_read_space(0);
1128 c = lex_peek_unichar(0);
1129 }
1130
1131 intro_my();
1132
1133 body = parse_block(0);
1134
1135 return block_end(save_ix, op_append_list(OP_LINESEQ, vardeclseq, body));
1136}
1137
03d05f6e
LM		 1138#define parse_join_with_space() THX_parse_join_with_space(aTHX)
1139static OP *THX_parse_join_with_space(pTHX)
1140{
1141 OP *delim, *args;
1142
1143 args = parse_listexpr(0);
1144 delim = newSVOP(OP_CONST, 0, newSVpvs(" "));
1145 return op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, delim, args));
1146}
1147
83f8bb56
Z		 1148/* plugin glue */
1149
1150#define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
1151static int THX_keyword_active(pTHX_ SV *hintkey_sv)
1152{
1153 HE *he;
1154 if(!GvHV(PL_hintgv)) return 0;
1155 he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0,
1156 SvSHARED_HASH(hintkey_sv));
1157 return he && SvTRUE(HeVAL(he));
1158}
1159
1160static int my_keyword_plugin(pTHX_
1161 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
1162{
33e1c218 1163 if(keyword_len == 3 && strEQs(keyword_ptr, "rpn") &&
83f8bb56
Z		 1164 keyword_active(hintkey_rpn_sv)) {
1165 *op_ptr = parse_keyword_rpn();
1166 return KEYWORD_PLUGIN_EXPR;
33e1c218 1167 } else if(keyword_len == 7 && strEQs(keyword_ptr, "calcrpn") &&
83f8bb56
Z		 1168 keyword_active(hintkey_calcrpn_sv)) {
1169 *op_ptr = parse_keyword_calcrpn();
1170 return KEYWORD_PLUGIN_STMT;
33e1c218 1171 } else if(keyword_len == 9 && strEQs(keyword_ptr, "stufftest") &&
83f8bb56
Z		 1172 keyword_active(hintkey_stufftest_sv)) {
1173 *op_ptr = parse_keyword_stufftest();
1174 return KEYWORD_PLUGIN_STMT;
1175 } else if(keyword_len == 12 &&
33e1c218 1176 strEQs(keyword_ptr, "swaptwostmts") &&
83f8bb56
Z		 1177 keyword_active(hintkey_swaptwostmts_sv)) {
1178 *op_ptr = parse_keyword_swaptwostmts();
1179 return KEYWORD_PLUGIN_STMT;
33e1c218 1180 } else if(keyword_len == 8 && strEQs(keyword_ptr, "looprest") &&
07ffcb73
Z		 1181 keyword_active(hintkey_looprest_sv)) {
1182 *op_ptr = parse_keyword_looprest();
1183 return KEYWORD_PLUGIN_STMT;
33e1c218 1184 } else if(keyword_len == 14 && strEQs(keyword_ptr, "scopelessblock") &&
a7aaec61
Z		 1185 keyword_active(hintkey_scopelessblock_sv)) {
1186 *op_ptr = parse_keyword_scopelessblock();
1187 return KEYWORD_PLUGIN_STMT;
33e1c218 1188 } else if(keyword_len == 10 && strEQs(keyword_ptr, "stmtasexpr") &&
9eb5c532
Z		 1189 keyword_active(hintkey_stmtasexpr_sv)) {
1190 *op_ptr = parse_keyword_stmtasexpr();
1191 return KEYWORD_PLUGIN_EXPR;
33e1c218 1192 } else if(keyword_len == 11 && strEQs(keyword_ptr, "stmtsasexpr") &&
9eb5c532
Z		 1193 keyword_active(hintkey_stmtsasexpr_sv)) {
1194 *op_ptr = parse_keyword_stmtsasexpr();
1195 return KEYWORD_PLUGIN_EXPR;
33e1c218 1196 } else if(keyword_len == 9 && strEQs(keyword_ptr, "loopblock") &&
e53d8f76
Z		 1197 keyword_active(hintkey_loopblock_sv)) {
1198 *op_ptr = parse_keyword_loopblock();
1199 return KEYWORD_PLUGIN_STMT;
33e1c218 1200 } else if(keyword_len == 11 && strEQs(keyword_ptr, "blockasexpr") &&
e53d8f76
Z		 1201 keyword_active(hintkey_blockasexpr_sv)) {
1202 *op_ptr = parse_keyword_blockasexpr();
1203 return KEYWORD_PLUGIN_EXPR;
33e1c218 1204 } else if(keyword_len == 9 && strEQs(keyword_ptr, "swaplabel") &&
361d9b55
Z		 1205 keyword_active(hintkey_swaplabel_sv)) {
1206 *op_ptr = parse_keyword_swaplabel();
1207 return KEYWORD_PLUGIN_STMT;
33e1c218 1208 } else if(keyword_len == 10 && strEQs(keyword_ptr, "labelconst") &&
361d9b55
Z		 1209 keyword_active(hintkey_labelconst_sv)) {
1210 *op_ptr = parse_keyword_labelconst();
1211 return KEYWORD_PLUGIN_EXPR;
33e1c218 1212 } else if(keyword_len == 13 && strEQs(keyword_ptr, "arrayfullexpr") &&
78cdf107
Z		 1213 keyword_active(hintkey_arrayfullexpr_sv)) {
1214 *op_ptr = parse_keyword_arrayfullexpr();
1215 return KEYWORD_PLUGIN_EXPR;
33e1c218 1216 } else if(keyword_len == 13 && strEQs(keyword_ptr, "arraylistexpr") &&
78cdf107
Z		 1217 keyword_active(hintkey_arraylistexpr_sv)) {
1218 *op_ptr = parse_keyword_arraylistexpr();
1219 return KEYWORD_PLUGIN_EXPR;
33e1c218 1220 } else if(keyword_len == 13 && strEQs(keyword_ptr, "arraytermexpr") &&
78cdf107
Z		 1221 keyword_active(hintkey_arraytermexpr_sv)) {
1222 *op_ptr = parse_keyword_arraytermexpr();
1223 return KEYWORD_PLUGIN_EXPR;
33e1c218 1224 } else if(keyword_len == 14 && strEQs(keyword_ptr, "arrayarithexpr") &&
78cdf107
Z		 1225 keyword_active(hintkey_arrayarithexpr_sv)) {
1226 *op_ptr = parse_keyword_arrayarithexpr();
1227 return KEYWORD_PLUGIN_EXPR;
33e1c218 1228 } else if(keyword_len == 14 && strEQs(keyword_ptr, "arrayexprflags") &&
78cdf107
Z		 1229 keyword_active(hintkey_arrayexprflags_sv)) {
1230 *op_ptr = parse_keyword_arrayexprflags();
1231 return KEYWORD_PLUGIN_EXPR;
33e1c218 1232 } else if(keyword_len == 5 && strEQs(keyword_ptr, "DEFSV") &&
ce409cc8
LM		 1233 keyword_active(hintkey_DEFSV_sv)) {
1234 *op_ptr = parse_keyword_DEFSV();
1235 return KEYWORD_PLUGIN_EXPR;
33e1c218 1236 } else if(keyword_len == 9 && strEQs(keyword_ptr, "with_vars") &&
25f5d540
LM		 1237 keyword_active(hintkey_with_vars_sv)) {
1238 *op_ptr = parse_keyword_with_vars();
1239 return KEYWORD_PLUGIN_STMT;
33e1c218 1240 } else if(keyword_len == 15 && strEQs(keyword_ptr, "join_with_space") &&
03d05f6e
LM		 1241 keyword_active(hintkey_join_with_space_sv)) {
1242 *op_ptr = parse_join_with_space();
1243 return KEYWORD_PLUGIN_EXPR;
83f8bb56
Z		 1244 } else {
1245 return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
1246 }
1247}
1248
f568d64d
BM		 1249static XOP my_xop;
1250
1251static OP *
1252pp_xop(pTHX)
1253{
1254 return PL_op->op_next;
1255}
1256
1257static void
1258peep_xop(pTHX_ OP *o, OP *oldop)
1259{
1260 dMY_CXT;
147e3846
KW		 1261 av_push(MY_CXT.xop_record, newSVpvf("peep:%" UVxf, PTR2UV(o)));
1262 av_push(MY_CXT.xop_record, newSVpvf("oldop:%" UVxf, PTR2UV(oldop)));
f568d64d
BM		 1263}
1264
27fcb6ee
FC		 1265static I32
1266filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
1267{
27fcb6ee
FC		 1268 char *p;
1269 char *end;
1270 int n = FILTER_READ(idx + 1, buf_sv, maxlen);
1271
1272 if (n<=0) return n;
1273
1274 p = SvPV_force_nolen(buf_sv);
1275 end = p + SvCUR(buf_sv);
1276 while (p < end) {
1277 if (*p == 'o') *p = 'e';
1278 p++;
1279 }
1280 return SvCUR(buf_sv);
1281}
1282
02cab674
FC		 1283static AV *
1284myget_linear_isa(pTHX_ HV *stash, U32 level) {
02cab674 1285 GV **gvp = (GV **)hv_fetchs(stash, "ISA", 0);
6dbddf4a 1286 PERL_UNUSED_ARG(level);
02cab674
FC		 1287 return gvp && *gvp && GvAV(*gvp)
1288 ? GvAV(*gvp)
1289 : (AV *)sv_2mortal((SV *)newAV());
1290}
1291
27fcb6ee 1292
9777c6aa
S		 1293XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_undef);
1294XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_empty);
1295XS_EXTERNAL(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
7b20c7cd 1296
02cab674
FC		 1297static struct mro_alg mymro;
1298
e8570548
Z		 1299static Perl_check_t addissub_nxck_add;
1300
1301static OP *
1302addissub_myck_add(pTHX_ OP *op)
1303{
1304 SV **flag_svp = hv_fetchs(GvHV(PL_hintgv), "XS::APItest/addissub", 0);
1305 OP *aop, *bop;
1306 U8 flags;
1307 if (!(flag_svp && SvTRUE(*flag_svp) && (op->op_flags & OPf_KIDS) &&
e6dae479
FC		 1308 (aop = cBINOPx(op)->op_first) && (bop = OpSIBLING(aop)) &&
1309 !OpHAS_SIBLING(bop)))
e8570548 1310 return addissub_nxck_add(aTHX_ op);
e8570548 1311 flags = op->op_flags;
3253bf85
DM		 1312 op_sibling_splice(op, NULL, 1, NULL); /* excise aop */
1313 op_sibling_splice(op, NULL, 1, NULL); /* excise bop */
1314 op_free(op); /* free the empty husk */
1315 flags &= ~OPf_KIDS;
e8570548
Z		 1316 return newBINOP(OP_SUBTRACT, flags, aop, bop);
1317}
02cab674 1318
39c012bc
FC		 1319static Perl_check_t old_ck_rv2cv;
1320
1321static OP *
1322my_ck_rv2cv(pTHX_ OP *o)
1323{
1324 SV *ref;
1325 SV **flag_svp = hv_fetchs(GvHV(PL_hintgv), "XS::APItest/addunder", 0);
1326 OP *aop;
1327
1328 if (flag_svp && SvTRUE(*flag_svp) && (o->op_flags & OPf_KIDS)
1329 && (aop = cUNOPx(o)->op_first) && aop->op_type == OP_CONST
1330 && aop->op_private & (OPpCONST_ENTERED|OPpCONST_BARE)
1331 && (ref = cSVOPx(aop)->op_sv) && SvPOK(ref) && SvCUR(ref)
1332 && *(SvEND(ref)-1) == 'o')
1333 {
1334 SvGROW(ref, SvCUR(ref)+2);
1335 *SvEND(ref) = '_';
1336 SvCUR(ref)++;
1337 *SvEND(ref) = '\0';
1338 }
1339 return old_ck_rv2cv(aTHX_ o);
1340}
1341
55289a74
NC		 1342#include "const-c.inc"
1343
ffe53d21 1344MODULE = XS::APItest PACKAGE = XS::APItest
0314122a 1345
55289a74
NC		 1346INCLUDE: const-xs.inc
1347
ffe53d21
NC		 1348INCLUDE: numeric.xs
1349
11f9ab1a
TC		 1350void
1351assertx(int x)
1352 CODE:
1353 /* this only needs to compile and checks that assert() can be
1354 used this way syntactically */
950c540d
JH		 1355 (void)(assert(x), 1);
1356 (void)(x);
11f9ab1a 1357
fed3ba5d
NC		 1358MODULE = XS::APItest::utf8 PACKAGE = XS::APItest::utf8
1359
1360int
1361bytes_cmp_utf8(bytes, utf8)
1362 SV *bytes
1363 SV *utf8
1364 PREINIT:
1365 const U8 *b;
1366 STRLEN blen;
1367 const U8 *u;
1368 STRLEN ulen;
1369 CODE:
1370 b = (const U8 *)SvPVbyte(bytes, blen);
1371 u = (const U8 *)SvPVbyte(utf8, ulen);
1372 RETVAL = bytes_cmp_utf8(b, blen, u, ulen);
1373 OUTPUT:
1374 RETVAL
1375
eb83ed87 1376AV *
f9380377 1377test_utf8n_to_uvchr_error(s, len, flags)
eb83ed87
KW		 1378
1379 SV *s
1380 SV *len
1381 SV *flags
1382 PREINIT:
1383 STRLEN retlen;
1384 UV ret;
1385 STRLEN slen;
f9380377 1386 U32 errors;
eb83ed87
KW		 1387
1388 CODE:
f9380377
KW		 1389 /* Now that utf8n_to_uvchr() is a trivial wrapper for
1390 * utf8n_to_uvchr_error(), call the latter with the inputs. It always
1391 * asks for the actual length to be returned and errors to be returned
eb83ed87
KW		 1392 *
1393 * Length to assume <s> is; not checked, so could have buffer overflow
1394 */
1395 RETVAL = newAV();
1396 sv_2mortal((SV*)RETVAL);
1397
f9380377
KW		 1398 ret = utf8n_to_uvchr_error((U8*) SvPV(s, slen),
1399 SvUV(len),
1400 &retlen,
1401 SvUV(flags),
1402 &errors);
eb83ed87 1403
f9380377 1404 /* Returns the return value in [0]; <retlen> in [1], <errors> in [2] */
eb83ed87
KW		 1405 av_push(RETVAL, newSVuv(ret));
1406 if (retlen == (STRLEN) -1) {
1407 av_push(RETVAL, newSViv(-1));
1408 }
1409 else {
1410 av_push(RETVAL, newSVuv(retlen));
1411 }
f9380377 1412 av_push(RETVAL, newSVuv(errors));
eb83ed87
KW		 1413
1414 OUTPUT:
1415 RETVAL
1416
75ffa578
KW		 1417AV *
1418test_valid_utf8_to_uvchr(s)
1419
1420 SV *s
1421 PREINIT:
1422 STRLEN retlen;
1423 UV ret;
1424 STRLEN slen;
1425
1426 CODE:
1427 /* Call utf8n_to_uvchr() with the inputs. It always asks for the
1428 * actual length to be returned
1429 *
1430 * Length to assume <s> is; not checked, so could have buffer overflow
1431 */
1432 RETVAL = newAV();
1433 sv_2mortal((SV*)RETVAL);
1434
1435 ret
1436 = valid_utf8_to_uvchr((U8*) SvPV(s, slen), &retlen);
1437
1438 /* Returns the return value in [0]; <retlen> in [1] */
1439 av_push(RETVAL, newSVuv(ret));
1440 av_push(RETVAL, newSVuv(retlen));
1441
1442 OUTPUT:
1443 RETVAL
1444
046d01eb
KW		 1445SV *
1446test_uvchr_to_utf8_flags(uv, flags)
1447
1448 SV *uv
1449 SV *flags
1450 PREINIT:
1451 U8 dest[UTF8_MAXBYTES];
1452 U8 *ret;
1453
1454 CODE:
1455 /* Call uvchr_to_utf8_flags() with the inputs. */
1456 ret = uvchr_to_utf8_flags(dest, SvUV(uv), SvUV(flags));
1457 if (! ret) {
1458 XSRETURN_UNDEF;
1459 }
1460 RETVAL = newSVpvn((char *) dest, ret - dest);
1461
1462 OUTPUT:
1463 RETVAL
1464
7d255dc8
NC		 1465MODULE = XS::APItest:Overload PACKAGE = XS::APItest::Overload
1466
c33e8be1 1467void
25a9ffce 1468amagic_deref_call(sv, what)
7d255dc8
NC		 1469 SV *sv
1470 int what
1471 PPCODE:
7d255dc8 1472 /* The reference is owned by something else. */
25a9ffce 1473 PUSHs(amagic_deref_call(sv, what));
7d255dc8 1474
e89bfaa6
NC		 1475# I'd certainly like to discourage the use of this macro, given that we now
1476# have amagic_deref_call
1477
c33e8be1 1478void
e89bfaa6
NC		 1479tryAMAGICunDEREF_var(sv, what)
1480 SV *sv
1481 int what
1482 PPCODE:
1483 {
1484 SV **sp = &sv;
1485 switch(what) {
1486 case to_av_amg:
1487 tryAMAGICunDEREF(to_av);
1488 break;
1489 case to_cv_amg:
1490 tryAMAGICunDEREF(to_cv);
1491 break;
1492 case to_gv_amg:
1493 tryAMAGICunDEREF(to_gv);
1494 break;
1495 case to_hv_amg:
1496 tryAMAGICunDEREF(to_hv);
1497 break;
1498 case to_sv_amg:
1499 tryAMAGICunDEREF(to_sv);
1500 break;
1501 default:
1502 croak("Invalid value %d passed to tryAMAGICunDEREF_var", what);
1503 }
1504 }
1505 /* The reference is owned by something else. */
1506 PUSHs(sv);
1507
7b20c7cd
NC		 1508MODULE = XS::APItest PACKAGE = XS::APItest::XSUB
1509
1510BOOT:
1511 newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
f9cc56fa 1512 newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__);
88c4b02d 1513 newXS("XS::APItest::XSUB::XS_APIVERSION_invalid", XS_XS__APItest__XSUB_XS_APIVERSION_invalid, __FILE__);
7b20c7cd
NC		 1514
1515void
1516XS_VERSION_defined(...)
1517 PPCODE:
1518 XS_VERSION_BOOTCHECK;
1519 XSRETURN_EMPTY;
1520
88c4b02d
NC		 1521void
1522XS_APIVERSION_valid(...)
1523 PPCODE:
1524 XS_APIVERSION_BOOTCHECK;
1525 XSRETURN_EMPTY;
1526
50ceb817
DB		 1527void
1528xsreturn( int len )
1529 PPCODE:
1530 int i = 0;
1531 EXTEND( SP, len );
1532 for ( ; i < len; i++ ) {
1533 ST(i) = sv_2mortal( newSViv(i) );
1534 }
1535 XSRETURN( len );
1536
1537void
1538xsreturn_iv()
1539 PPCODE:
052efbb4 1540 XSRETURN_IV(I32_MIN + 1);
50ceb817
DB		 1541
1542void
1543xsreturn_uv()
1544 PPCODE:
7e327f76 1545 XSRETURN_UV( (U32)((1U<<31) + 1) );
50ceb817
DB		 1546
1547void
1548xsreturn_nv()
1549 PPCODE:
1550 XSRETURN_NV(0.25);
1551
1552void
1553xsreturn_pv()
1554 PPCODE:
1555 XSRETURN_PV("returned");
1556
1557void
1558xsreturn_pvn()
1559 PPCODE:
1560 XSRETURN_PVN("returned too much",8);
1561
1562void
1563xsreturn_no()
1564 PPCODE:
1565 XSRETURN_NO;
1566
1567void
1568xsreturn_yes()
1569 PPCODE:
1570 XSRETURN_YES;
1571
1572void
1573xsreturn_undef()
1574 PPCODE:
1575 XSRETURN_UNDEF;
1576
1577void
1578xsreturn_empty()
1579 PPCODE:
1580 XSRETURN_EMPTY;
1581
ffe53d21
NC		 1582MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
1583
b54b4831
NC		 1584void
1585rot13_hash(hash)
1586 HV *hash
1587 CODE:
1588 {
1589 struct ufuncs uf;
1590 uf.uf_val = rot13_key;
1591 uf.uf_set = 0;
1592 uf.uf_index = 0;
1593
1594 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
1595 }
1596
53c40a8f
NC		 1597void
1598bitflip_hash(hash)
1599 HV *hash
1600 CODE:
1601 {
1602 struct ufuncs uf;
1603 uf.uf_val = bitflip_key;
1604 uf.uf_set = 0;
1605 uf.uf_index = 0;
1606
1607 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
1608 }
1609
028f8eaa
MHM		 1610#define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
1611
0314122a
NC		 1612bool
1613exists(hash, key_sv)
1614 PREINIT:
1615 STRLEN len;
1616 const char *key;
1617 INPUT:
1618 HV *hash
1619 SV *key_sv
1620 CODE:
1621 key = SvPV(key_sv, len);
028f8eaa 1622 RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
0314122a
NC		 1623 OUTPUT:
1624 RETVAL
1625
bdee33e4
NC		 1626bool
1627exists_ent(hash, key_sv)
1628 PREINIT:
1629 INPUT:
1630 HV *hash
1631 SV *key_sv
1632 CODE:
1633 RETVAL = hv_exists_ent(hash, key_sv, 0);
1634 OUTPUT:
1635 RETVAL
1636
b60cf05a 1637SV *
55289a74 1638delete(hash, key_sv, flags = 0)
b60cf05a
NC		 1639 PREINIT:
1640 STRLEN len;
1641 const char *key;
1642 INPUT:
1643 HV *hash
1644 SV *key_sv
55289a74 1645 I32 flags;
b60cf05a
NC		 1646 CODE:
1647 key = SvPV(key_sv, len);
1648 /* It's already mortal, so need to increase reference count. */
55289a74
NC		 1649 RETVAL
1650 = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
1651 OUTPUT:
1652 RETVAL
1653
1654SV *
1655delete_ent(hash, key_sv, flags = 0)
1656 INPUT:
1657 HV *hash
1658 SV *key_sv
1659 I32 flags;
1660 CODE:
1661 /* It's already mortal, so need to increase reference count. */
1662 RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
b60cf05a
NC		 1663 OUTPUT:
1664 RETVAL
1665
1666SV *
858117f8
NC		 1667store_ent(hash, key, value)
1668 PREINIT:
1669 SV *copy;
1670 HE *result;
1671 INPUT:
1672 HV *hash
1673 SV *key
1674 SV *value
1675 CODE:
1676 copy = newSV(0);
1677 result = hv_store_ent(hash, key, copy, 0);
1678 SvSetMagicSV(copy, value);
1679 if (!result) {
1680 SvREFCNT_dec(copy);
1681 XSRETURN_EMPTY;
1682 }
1683 /* It's about to become mortal, so need to increase reference count.
1684 */
1685 RETVAL = SvREFCNT_inc(HeVAL(result));
1686 OUTPUT:
1687 RETVAL
1688
858117f8 1689SV *
b60cf05a
NC		 1690store(hash, key_sv, value)
1691 PREINIT:
1692 STRLEN len;
1693 const char *key;
1694 SV *copy;
1695 SV **result;
1696 INPUT:
1697 HV *hash
1698 SV *key_sv
1699 SV *value
1700 CODE:
1701 key = SvPV(key_sv, len);
1702 copy = newSV(0);
028f8eaa 1703 result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
858117f8 1704 SvSetMagicSV(copy, value);
b60cf05a
NC		 1705 if (!result) {
1706 SvREFCNT_dec(copy);
1707 XSRETURN_EMPTY;
1708 }
1709 /* It's about to become mortal, so need to increase reference count.
1710 */
1711 RETVAL = SvREFCNT_inc(*result);
1712 OUTPUT:
1713 RETVAL
1714
bdee33e4
NC		 1715SV *
1716fetch_ent(hash, key_sv)
1717 PREINIT:
1718 HE *result;
1719 INPUT:
1720 HV *hash
1721 SV *key_sv
1722 CODE:
1723 result = hv_fetch_ent(hash, key_sv, 0, 0);
1724 if (!result) {
1725 XSRETURN_EMPTY;
1726 }
1727 /* Force mg_get */
1728 RETVAL = newSVsv(HeVAL(result));
1729 OUTPUT:
1730 RETVAL
b60cf05a
NC		 1731
1732SV *
1733fetch(hash, key_sv)
1734 PREINIT:
1735 STRLEN len;
1736 const char *key;
1737 SV **result;
1738 INPUT:
1739 HV *hash
1740 SV *key_sv
1741 CODE:
1742 key = SvPV(key_sv, len);
028f8eaa 1743 result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
b60cf05a
NC		 1744 if (!result) {
1745 XSRETURN_EMPTY;
1746 }
1747 /* Force mg_get */
1748 RETVAL = newSVsv(*result);
1749 OUTPUT:
1750 RETVAL
2dc92170 1751
9568a123
NC		 1752#if defined (hv_common)
1753
6b4de907
NC		 1754SV *
1755common(params)
1756 INPUT:
1757 HV *params
1758 PREINIT:
1759 HE *result;
1760 HV *hv = NULL;
1761 SV *keysv = NULL;
1762 const char *key = NULL;
1763 STRLEN klen = 0;
1764 int flags = 0;
1765 int action = 0;
1766 SV *val = NULL;
1767 U32 hash = 0;
1768 SV **svp;
1769 CODE:
1770 if ((svp = hv_fetchs(params, "hv", 0))) {
1771 SV *const rv = *svp;
1772 if (!SvROK(rv))
1773 croak("common passed a non-reference for parameter hv");
1774 hv = (HV *)SvRV(rv);
1775 }
1776 if ((svp = hv_fetchs(params, "keysv", 0)))
1777 keysv = *svp;
1778 if ((svp = hv_fetchs(params, "keypv", 0))) {
1779 key = SvPV_const(*svp, klen);
1780 if (SvUTF8(*svp))
1781 flags = HVhek_UTF8;
1782 }
1783 if ((svp = hv_fetchs(params, "action", 0)))
1784 action = SvIV(*svp);
1785 if ((svp = hv_fetchs(params, "val", 0)))
527df579 1786 val = newSVsv(*svp);
6b4de907 1787 if ((svp = hv_fetchs(params, "hash", 0)))
a44093a9 1788 hash = SvUV(*svp);
6b4de907 1789
de092133 1790 if (hv_fetchs(params, "hash_pv", 0)) {
9959d439 1791 assert(key);
527df579
NC		 1792 PERL_HASH(hash, key, klen);
1793 }
de092133 1794 if (hv_fetchs(params, "hash_sv", 0)) {
9959d439
JH		 1795 assert(keysv);
1796 {
1797 STRLEN len;
1798 const char *const p = SvPV(keysv, len);
1799 PERL_HASH(hash, p, len);
1800 }
58ca560a 1801 }
527df579 1802
a75fcbca 1803 result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
6b4de907
NC		 1804 if (!result) {
1805 XSRETURN_EMPTY;
1806 }
1807 /* Force mg_get */
1808 RETVAL = newSVsv(HeVAL(result));
1809 OUTPUT:
1810 RETVAL
1811
9568a123
NC		 1812#endif
1813
439efdfe 1814void
2dc92170
NC		 1815test_hv_free_ent()
1816 PPCODE:
2e66fe90 1817 test_freeent(&Perl_hv_free_ent);
2dc92170
NC		 1818 XSRETURN(4);
1819
439efdfe 1820void
2dc92170
NC		 1821test_hv_delayfree_ent()
1822 PPCODE:
2e66fe90 1823 test_freeent(&Perl_hv_delayfree_ent);
2dc92170 1824 XSRETURN(4);
35ab5632
NC		 1825
1826SV *
1827test_share_unshare_pvn(input)
1828 PREINIT:
35ab5632
NC		 1829 STRLEN len;
1830 U32 hash;
1831 char *pvx;
1832 char *p;
1833 INPUT:
1834 SV *input
1835 CODE:
1836 pvx = SvPV(input, len);
1837 PERL_HASH(hash, pvx, len);
1838 p = sharepvn(pvx, len, hash);
1839 RETVAL = newSVpvn(p, len);
1840 unsharepvn(p, len, hash);
1841 OUTPUT:
1842 RETVAL
d8c5b3c5 1843
9568a123
NC		 1844#if PERL_VERSION >= 9
1845
d8c5b3c5
NC		 1846bool
1847refcounted_he_exists(key, level=0)
1848 SV *key
1849 IV level
1850 CODE:
1851 if (level) {
147e3846 1852 croak("level must be zero, not %" IVdf, level);
d8c5b3c5 1853 }
20439bc7 1854 RETVAL = (cop_hints_fetch_sv(PL_curcop, key, 0, 0) != &PL_sv_placeholder);
d8c5b3c5
NC		 1855 OUTPUT:
1856 RETVAL
1857
d8c5b3c5
NC		 1858SV *
1859refcounted_he_fetch(key, level=0)
1860 SV *key
1861 IV level
1862 CODE:
1863 if (level) {
147e3846 1864 croak("level must be zero, not %" IVdf, level);
d8c5b3c5 1865 }
20439bc7 1866 RETVAL = cop_hints_fetch_sv(PL_curcop, key, 0, 0);
d8c5b3c5
NC		 1867 SvREFCNT_inc(RETVAL);
1868 OUTPUT:
1869 RETVAL
65bfe90c 1870
9568a123 1871#endif
65bfe90c 1872
5f39160d
TC		 1873void
1874test_force_keys(HV *hv)
1875 PREINIT:
1876 HE *he;
052a7c76 1877 SSize_t count = 0;
5f39160d
TC		 1878 PPCODE:
1879 hv_iterinit(hv);
1880 he = hv_iternext(hv);
1881 while (he) {
1882 SV *sv = HeSVKEY_force(he);
1883 ++count;
1884 EXTEND(SP, count);
1885 PUSHs(sv_mortalcopy(sv));
1886 he = hv_iternext(hv);
1887 }
1888
0314122a
NC		 1889=pod
1890
1891sub TIEHASH { bless {}, $_[0] }
1892sub STORE { $_[0]->{$_[1]} = $_[2] }
1893sub FETCH { $_[0]->{$_[1]} }
1894sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
1895sub NEXTKEY { each %{$_[0]} }
1896sub EXISTS { exists $_[0]->{$_[1]} }
1897sub DELETE { delete $_[0]->{$_[1]} }
1898sub CLEAR { %{$_[0]} = () }
1899
1900=cut
1901
e2fe06dd
EB		 1902MODULE = XS::APItest:TempLv PACKAGE = XS::APItest::TempLv
1903
1904void
1905make_temp_mg_lv(sv)
1906SV* sv
1907 PREINIT:
1908 SV * const lv = newSV_type(SVt_PVLV);
1909 STRLEN len;
1910 PPCODE:
1911 SvPV(sv, len);
1912
1913 sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
1914 LvTYPE(lv) = 'x';
1915 LvTARG(lv) = SvREFCNT_inc_simple(sv);
1916 LvTARGOFF(lv) = len == 0 ? 0 : 1;
1917 LvTARGLEN(lv) = len < 2 ? 0 : len-2;
1918
1919 EXTEND(SP, 1);
1920 ST(0) = sv_2mortal(lv);
1921 XSRETURN(1);
1922
1923
36c2b1d0
NC		 1924MODULE = XS::APItest::PtrTable PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
1925
1926void
1927ptr_table_new(classname)
1928const char * classname
1929 PPCODE:
1930 PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
1931
1932void
1933DESTROY(table)
1934XS::APItest::PtrTable table
1935 CODE:
1936 ptr_table_free(table);
1937
1938void
992b2363 1939ptr_table_store(table, from, to)
36c2b1d0 1940XS::APItest::PtrTable table
992b2363
NC		 1941SVREF from
1942SVREF to
36c2b1d0 1943 CODE:
992b2363 1944 ptr_table_store(table, from, to);
36c2b1d0
NC		 1945
1946UV
992b2363 1947ptr_table_fetch(table, from)
36c2b1d0 1948XS::APItest::PtrTable table
992b2363 1949SVREF from
36c2b1d0 1950 CODE:
992b2363 1951 RETVAL = PTR2UV(ptr_table_fetch(table, from));
36c2b1d0
NC		 1952 OUTPUT:
1953 RETVAL
1954
1955void
1956ptr_table_split(table)
1957XS::APItest::PtrTable table
1958
1959void
1960ptr_table_clear(table)
1961XS::APItest::PtrTable table
1962
6911735f
FC		 1963MODULE = XS::APItest::AutoLoader PACKAGE = XS::APItest::AutoLoader
1964
1965SV *
1966AUTOLOAD()
1967 CODE:
1968 RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
1969 OUTPUT:
1970 RETVAL
1971
8fa6a409
FC		 1972SV *
1973AUTOLOADp(...)
1974 PROTOTYPE: *$
1975 CODE:
5f74c55e 1976 PERL_UNUSED_ARG(items);
8fa6a409
FC		 1977 RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
1978 OUTPUT:
1979 RETVAL
1980
6911735f 1981
3e61d65a
JH		 1982MODULE = XS::APItest PACKAGE = XS::APItest
1983
1984PROTOTYPES: DISABLE
1985
67ecba2f
FC		 1986BOOT:
1987 mymro.resolve = myget_linear_isa;
1988 mymro.name = "justisa";
1989 mymro.length = 7;
1990 mymro.kflags = 0;
1991 mymro.hash = 0;
1992 Perl_mro_register(aTHX_ &mymro);
1993
f568d64d
BM		 1994HV *
1995xop_custom_ops ()
1996 CODE:
1997 RETVAL = PL_custom_ops;
1998 OUTPUT:
1999 RETVAL
2000
2001HV *
2002xop_custom_op_names ()
2003 CODE:
2004 PL_custom_op_names = newHV();
2005 RETVAL = PL_custom_op_names;
2006 OUTPUT:
2007 RETVAL
2008
2009HV *
2010xop_custom_op_descs ()
2011 CODE:
2012 PL_custom_op_descs = newHV();
2013 RETVAL = PL_custom_op_descs;
2014 OUTPUT:
2015 RETVAL
2016
2017void
2018xop_register ()
2019 CODE:
2020 XopENTRY_set(&my_xop, xop_name, "my_xop");
2021 XopENTRY_set(&my_xop, xop_desc, "XOP for testing");
2022 XopENTRY_set(&my_xop, xop_class, OA_UNOP);
2023 XopENTRY_set(&my_xop, xop_peep, peep_xop);
2024 Perl_custom_op_register(aTHX_ pp_xop, &my_xop);
2025
2026void
2027xop_clear ()
2028 CODE:
2029 XopDISABLE(&my_xop, xop_name);
2030 XopDISABLE(&my_xop, xop_desc);
2031 XopDISABLE(&my_xop, xop_class);
2032 XopDISABLE(&my_xop, xop_peep);
2033
2034IV
2035xop_my_xop ()
2036 CODE:
2037 RETVAL = PTR2IV(&my_xop);
2038 OUTPUT:
2039 RETVAL
2040
2041IV
2042xop_ppaddr ()
2043 CODE:
2044 RETVAL = PTR2IV(pp_xop);
2045 OUTPUT:
2046 RETVAL
2047
2048IV
2049xop_OA_UNOP ()
2050 CODE:
2051 RETVAL = OA_UNOP;
2052 OUTPUT:
2053 RETVAL
2054
2055AV *
2056xop_build_optree ()
2057 CODE:
2058 dMY_CXT;
2059 UNOP *unop;
2060 OP *kid;
2061
2062 MY_CXT.xop_record = newAV();
2063
2064 kid = newSVOP(OP_CONST, 0, newSViv(42));
2065
3253bf85 2066 unop = (UNOP*)mkUNOP(OP_CUSTOM, kid);
f568d64d 2067 unop->op_ppaddr = pp_xop;
f568d64d 2068 unop->op_private = 0;
f568d64d
BM		 2069 unop->op_next = NULL;
2070 kid->op_next = (OP*)unop;
2071
147e3846
KW		 2072 av_push(MY_CXT.xop_record, newSVpvf("unop:%" UVxf, PTR2UV(unop)));
2073 av_push(MY_CXT.xop_record, newSVpvf("kid:%" UVxf, PTR2UV(kid)));
f568d64d
BM		 2074
2075 av_push(MY_CXT.xop_record, newSVpvf("NAME:%s", OP_NAME((OP*)unop)));
2076 av_push(MY_CXT.xop_record, newSVpvf("DESC:%s", OP_DESC((OP*)unop)));
c33e8be1 2077 av_push(MY_CXT.xop_record, newSVpvf("CLASS:%d", (int)OP_CLASS((OP*)unop)));
f568d64d
BM		 2078
2079 PL_rpeepp(aTHX_ kid);
2080
2081 FreeOp(kid);
2082 FreeOp(unop);
2083
2084 RETVAL = MY_CXT.xop_record;
2085 MY_CXT.xop_record = NULL;
2086 OUTPUT:
2087 RETVAL
2088
ae103e09
DD		 2089IV
2090xop_from_custom_op ()
2091 CODE:
2092/* author note: this test doesn't imply Perl_custom_op_xop is or isn't public
2093 API or that Perl_custom_op_xop is known to be used outside the core */
2094 UNOP *unop;
2095 XOP *xop;
2096
3253bf85 2097 unop = (UNOP*)mkUNOP(OP_CUSTOM, NULL);
ae103e09 2098 unop->op_ppaddr = pp_xop;
ae103e09 2099 unop->op_private = 0;
ae103e09
DD		 2100 unop->op_next = NULL;
2101
2102 xop = Perl_custom_op_xop(aTHX_ (OP *)unop);
2103 FreeOp(unop);
2104 RETVAL = PTR2IV(xop);
2105 OUTPUT:
2106 RETVAL
2107
85ce96a1
DM		 2108BOOT:
2109{
2110 MY_CXT_INIT;
03569ecf 2111
85ce96a1
DM		 2112 MY_CXT.i = 99;
2113 MY_CXT.sv = newSVpv("initial",0);
13b6b3bc
BM		 2114
2115 MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
2116 MY_CXT.bhk_record = 0;
2117
a88d97bf
BM		 2118 BhkENTRY_set(&bhk_test, bhk_start, blockhook_test_start);
2119 BhkENTRY_set(&bhk_test, bhk_pre_end, blockhook_test_pre_end);
2120 BhkENTRY_set(&bhk_test, bhk_post_end, blockhook_test_post_end);
2121 BhkENTRY_set(&bhk_test, bhk_eval, blockhook_test_eval);
13b6b3bc
BM		 2122 Perl_blockhook_register(aTHX_ &bhk_test);
2123
65bfe90c 2124 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
13b6b3bc 2125 GV_ADDMULTI, SVt_PVAV);
03569ecf
BM		 2126 MY_CXT.cscav = GvAV(MY_CXT.cscgv);
2127
a88d97bf
BM		 2128 BhkENTRY_set(&bhk_csc, bhk_start, blockhook_csc_start);
2129 BhkENTRY_set(&bhk_csc, bhk_pre_end, blockhook_csc_pre_end);
13b6b3bc 2130 Perl_blockhook_register(aTHX_ &bhk_csc);
201c7e1f
FR		 2131
2132 MY_CXT.peep_recorder = newAV();
2133 MY_CXT.rpeep_recorder = newAV();
2134
2135 MY_CXT.orig_peep = PL_peepp;
2136 MY_CXT.orig_rpeep = PL_rpeepp;
2137 PL_peepp = my_peep;
2138 PL_rpeepp = my_rpeep;
65bfe90c 2139}
85ce96a1
DM		 2140
2141void
2142CLONE(...)
2143 CODE:
2144 MY_CXT_CLONE;
c33e8be1 2145 PERL_UNUSED_VAR(items);
85ce96a1 2146 MY_CXT.sv = newSVpv("initial_clone",0);
65bfe90c 2147 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
13b6b3bc 2148 GV_ADDMULTI, SVt_PVAV);
03569ecf 2149 MY_CXT.cscav = NULL;
13b6b3bc
BM		 2150 MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
2151 MY_CXT.bhk_record = 0;
201c7e1f
FR		 2152 MY_CXT.peep_recorder = newAV();
2153 MY_CXT.rpeep_recorder = newAV();
85ce96a1 2154
3e61d65a
JH		 2155void
2156print_double(val)
2157 double val
2158 CODE:
2159 printf("%5.3f\n",val);
2160
2161int
2162have_long_double()
2163 CODE:
2164#ifdef HAS_LONG_DOUBLE
2165 RETVAL = 1;
2166#else
2167 RETVAL = 0;
2168#endif
cabb36f0
CN		 2169 OUTPUT:
2170 RETVAL
3e61d65a
JH		 2171
2172void
2173print_long_double()
2174 CODE:
2175#ifdef HAS_LONG_DOUBLE
fc0bf671 2176# if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
3e61d65a
JH		 2177 long double val = 7.0;
2178 printf("%5.3" PERL_PRIfldbl "\n",val);
2179# else
2180 double val = 7.0;
2181 printf("%5.3f\n",val);
2182# endif
2183#endif
2184
2185void
3e61d65a
JH		 2186print_int(val)
2187 int val
2188 CODE:
2189 printf("%d\n",val);
2190
2191void
2192print_long(val)
2193 long val
2194 CODE:
2195 printf("%ld\n",val);
2196
2197void
2198print_float(val)
2199 float val
2200 CODE:
2201 printf("%5.3f\n",val);
9d911683
NIS		 2202
2203void
2204print_flush()
2205 CODE:
2206 fflush(stdout);
d4b90eee
SH		 2207
2208void
2209mpushp()
2210 PPCODE:
2211 EXTEND(SP, 3);
2212 mPUSHp("one", 3);
2213 mPUSHp("two", 3);
2214 mPUSHp("three", 5);
2215 XSRETURN(3);
2216
2217void
2218mpushn()
2219 PPCODE:
2220 EXTEND(SP, 3);
2221 mPUSHn(0.5);
2222 mPUSHn(-0.25);
2223 mPUSHn(0.125);
2224 XSRETURN(3);
2225
2226void
2227mpushi()
2228 PPCODE:
2229 EXTEND(SP, 3);
d75b63cf
MHM		 2230 mPUSHi(-1);
2231 mPUSHi(2);
2232 mPUSHi(-3);
d4b90eee
SH		 2233 XSRETURN(3);
2234
2235void
2236mpushu()
2237 PPCODE:
2238 EXTEND(SP, 3);
d75b63cf
MHM		 2239 mPUSHu(1);
2240 mPUSHu(2);
2241 mPUSHu(3);
d4b90eee
SH		 2242 XSRETURN(3);
2243
2244void
2245mxpushp()
2246 PPCODE:
2247 mXPUSHp("one", 3);
2248 mXPUSHp("two", 3);
2249 mXPUSHp("three", 5);
2250 XSRETURN(3);
2251
2252void
2253mxpushn()
2254 PPCODE:
2255 mXPUSHn(0.5);
2256 mXPUSHn(-0.25);
2257 mXPUSHn(0.125);
2258 XSRETURN(3);
2259
2260void
2261mxpushi()
2262 PPCODE:
d75b63cf
MHM		 2263 mXPUSHi(-1);
2264 mXPUSHi(2);
2265 mXPUSHi(-3);
d4b90eee
SH		 2266 XSRETURN(3);
2267
2268void
2269mxpushu()
2270 PPCODE:
d75b63cf
MHM		 2271 mXPUSHu(1);
2272 mXPUSHu(2);
2273 mXPUSHu(3);
d4b90eee 2274 XSRETURN(3);
d1f347d7 2275
6768377c
DM		 2276
2277 # test_EXTEND(): excerise the EXTEND() macro.
2278 # After calling EXTEND(), it also does *(p+n) = NULL and
2279 # *PL_stack_max = NULL to allow valgrind etc to spot if the stack hasn't
2280 # actually been extended properly.
2281 #
2282 # max_offset specifies the SP to use. It is treated as a signed offset
2283 # from PL_stack_max.
2284 # nsv is the SV holding the value of n indicating how many slots
2285 # to extend the stack by.
2286 # use_ss is a boolean indicating that n should be cast to a SSize_t
2287
2288void
2289test_EXTEND(max_offset, nsv, use_ss)
2290 IV max_offset;
2291 SV *nsv;
2292 bool use_ss;
2293PREINIT:
2294 SV **sp = PL_stack_max + max_offset;
2295PPCODE:
2296 if (use_ss) {
2297 SSize_t n = (SSize_t)SvIV(nsv);
2298 EXTEND(sp, n);
2299 *(sp + n) = NULL;
2300 }
2301 else {
2302 IV n = SvIV(nsv);
2303 EXTEND(sp, n);
2304 *(sp + n) = NULL;
2305 }
2306 *PL_stack_max = NULL;
2307
2308
a85ce6f0
DD		 2309void
2310call_sv_C()
2311PREINIT:
2312 CV * i_sub;
2313 GV * i_gv;
2314 I32 retcnt;
2315 SV * errsv;
2316 char * errstr;
2317 SV * miscsv = sv_newmortal();
2318 HV * hv = (HV*)sv_2mortal((SV*)newHV());
2319CODE:
2320 i_sub = get_cv("i", 0);
2321 PUSHMARK(SP);
2322 /* PUTBACK not needed since this sub was called with 0 args, and is calling
2323 0 args, so global SP doesn't need to be moved before a call_* */
2324 retcnt = call_sv((SV*)i_sub, 0); /* try a CV* */
2325 SPAGAIN;
2326 SP -= retcnt; /* dont care about return count, wipe everything off */
2327 sv_setpvs(miscsv, "i");
2328 PUSHMARK(SP);
2329 retcnt = call_sv(miscsv, 0); /* try a PV */
2330 SPAGAIN;
2331 SP -= retcnt;
2332 /* no add and SVt_NULL are intentional, sub i should be defined already */
2333 i_gv = gv_fetchpvn_flags("i", sizeof("i")-1, 0, SVt_NULL);
2334 PUSHMARK(SP);
2335 retcnt = call_sv((SV*)i_gv, 0); /* try a GV* */
2336 SPAGAIN;
2337 SP -= retcnt;
2338 /* the tests below are not declaring this being public API behavior,
2339 only current internal behavior, these tests can be changed in the
2340 future if necessery */
2341 PUSHMARK(SP);
2342 retcnt = call_sv(&PL_sv_yes, 0); /* does nothing */
2343 SPAGAIN;
2344 SP -= retcnt;
2345 PUSHMARK(SP);
2346 retcnt = call_sv(&PL_sv_no, G_EVAL);
2347 SPAGAIN;
2348 SP -= retcnt;
2349 errsv = ERRSV;
2350 errstr = SvPV_nolen(errsv);
2351 if(strnEQ(errstr, "Undefined subroutine &main:: called at",
2352 sizeof("Undefined subroutine &main:: called at") - 1)) {
2353 PUSHMARK(SP);
2354 retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
2355 SPAGAIN;
2356 SP -= retcnt;
2357 }
2358 PUSHMARK(SP);
2359 retcnt = call_sv(&PL_sv_undef, G_EVAL);
2360 SPAGAIN;
2361 SP -= retcnt;
2362 errsv = ERRSV;
2363 errstr = SvPV_nolen(errsv);
2364 if(strnEQ(errstr, "Can't use an undefined value as a subroutine reference at",
2365 sizeof("Can't use an undefined value as a subroutine reference at") - 1)) {
2366 PUSHMARK(SP);
2367 retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
2368 SPAGAIN;
2369 SP -= retcnt;
2370 }
2371 PUSHMARK(SP);
2372 retcnt = call_sv((SV*)hv, G_EVAL);
2373 SPAGAIN;
2374 SP -= retcnt;
2375 errsv = ERRSV;
2376 errstr = SvPV_nolen(errsv);
2377 if(strnEQ(errstr, "Not a CODE reference at",
2378 sizeof("Not a CODE reference at") - 1)) {
2379 PUSHMARK(SP);
2380 retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
2381 SPAGAIN;
2382 SP -= retcnt;
2383 }
d1f347d7
DM		 2384
2385void
2386call_sv(sv, flags, ...)
2387 SV* sv
2388 I32 flags
2389 PREINIT:
2390 I32 i;
2391 PPCODE:
2392 for (i=0; i<items-2; i++)
2393 ST(i) = ST(i+2); /* pop first two args */
2394 PUSHMARK(SP);
2395 SP += items - 2;
2396 PUTBACK;
2397 i = call_sv(sv, flags);
2398 SPAGAIN;
2399 EXTEND(SP, 1);
2400 PUSHs(sv_2mortal(newSViv(i)));
2401
2402void
2403call_pv(subname, flags, ...)
2404 char* subname
2405 I32 flags
2406 PREINIT:
2407 I32 i;
2408 PPCODE:
2409 for (i=0; i<items-2; i++)
2410 ST(i) = ST(i+2); /* pop first two args */
2411 PUSHMARK(SP);
2412 SP += items - 2;
2413 PUTBACK;
2414 i = call_pv(subname, flags);
2415 SPAGAIN;
2416 EXTEND(SP, 1);
2417 PUSHs(sv_2mortal(newSViv(i)));
2418
2419void
c06180d6
FC		 2420call_argv(subname, flags, ...)
2421 char* subname
2422 I32 flags
2423 PREINIT:
2424 I32 i;
2425 char *tmpary[4];
2426 PPCODE:
2427 for (i=0; i<items-2; i++)
2428 tmpary[i] = SvPV_nolen(ST(i+2)); /* ignore first two args */
2429 tmpary[i] = NULL;
2430 PUTBACK;
2431 i = call_argv(subname, flags, tmpary);
2432 SPAGAIN;
2433 EXTEND(SP, 1);
2434 PUSHs(sv_2mortal(newSViv(i)));
2435
2436void
d1f347d7
DM		 2437call_method(methname, flags, ...)
2438 char* methname
2439 I32 flags
2440 PREINIT:
2441 I32 i;
2442 PPCODE:
2443 for (i=0; i<items-2; i++)
2444 ST(i) = ST(i+2); /* pop first two args */
2445 PUSHMARK(SP);
2446 SP += items - 2;
2447 PUTBACK;
2448 i = call_method(methname, flags);
2449 SPAGAIN;
2450 EXTEND(SP, 1);
2451 PUSHs(sv_2mortal(newSViv(i)));
2452
2453void
c0810f8e 2454newCONSTSUB(stash, name, flags, sv)
3453414d
BF		 2455 HV* stash
2456 SV* name
2457 I32 flags
8f82b567 2458 SV* sv
c0810f8e
NC		 2459 ALIAS:
2460 newCONSTSUB_flags = 1
3453414d 2461 PREINIT:
5f74c55e 2462 CV* mycv = NULL;
9c0a6090
FC		 2463 STRLEN len;
2464 const char *pv = SvPV(name, len);
3453414d 2465 PPCODE:
c0810f8e 2466 switch (ix) {
3453414d 2467 case 0:
dc4b20bd 2468 mycv = newCONSTSUB(stash, pv, SvOK(sv) ? SvREFCNT_inc(sv) : NULL);
3453414d
BF		 2469 break;
2470 case 1:
dc4b20bd 2471 mycv = newCONSTSUB_flags(
0fc4714a 2472 stash, pv, len, flags | SvUTF8(name), SvOK(sv) ? SvREFCNT_inc(sv) : NULL
8f82b567 2473 );
3453414d
BF		 2474 break;
2475 }
2476 EXTEND(SP, 2);
316ebaf2 2477 assert(mycv);
dc4b20bd
CB		 2478 PUSHs( CvCONST(mycv) ? &PL_sv_yes : &PL_sv_no );
2479 PUSHs((SV*)CvGV(mycv));
3453414d
BF		 2480
2481void
e6066781
BF		 2482gv_init_type(namesv, multi, flags, type)
2483 SV* namesv
2484 int multi
2485 I32 flags
2486 int type
2487 PREINIT:
2488 STRLEN len;
2489 const char * const name = SvPV_const(namesv, len);
2490 GV *gv = *(GV**)hv_fetch(PL_defstash, name, len, TRUE);
2491 PPCODE:
2492 if (SvTYPE(gv) == SVt_PVGV)
2493 Perl_croak(aTHX_ "GV is already a PVGV");
04ec7e59 2494 if (multi) flags |= GV_ADDMULTI;
e6066781
BF		 2495 switch (type) {
2496 case 0:
2497 gv_init(gv, PL_defstash, name, len, multi);
2498 break;
2499 case 1:
04ec7e59 2500 gv_init_sv(gv, PL_defstash, namesv, flags);
e6066781
BF		 2501 break;
2502 case 2:
04ec7e59 2503 gv_init_pv(gv, PL_defstash, name, flags | SvUTF8(namesv));
e6066781
BF		 2504 break;
2505 case 3:
04ec7e59 2506 gv_init_pvn(gv, PL_defstash, name, len, flags | SvUTF8(namesv));
e6066781
BF		 2507 break;
2508 }
2509 XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
2510
2511void
e6919483
BF		 2512gv_fetchmeth_type(stash, methname, type, level, flags)
2513 HV* stash
2514 SV* methname
2515 int type
2516 I32 level
2517 I32 flags
2518 PREINIT:
2519 STRLEN len;
2520 const char * const name = SvPV_const(methname, len);
5f74c55e 2521 GV* gv = NULL;
e6919483
BF		 2522 PPCODE:
2523 switch (type) {
2524 case 0:
2525 gv = gv_fetchmeth(stash, name, len, level);
2526 break;
2527 case 1:
2528 gv = gv_fetchmeth_sv(stash, methname, level, flags);
2529 break;
2530 case 2:
2531 gv = gv_fetchmeth_pv(stash, name, level, flags | SvUTF8(methname));
2532 break;
2533 case 3:
2534 gv = gv_fetchmeth_pvn(stash, name, len, level, flags | SvUTF8(methname));
2535 break;
2536 }
2537 XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
2538
2539void
d21989ed
BF		 2540gv_fetchmeth_autoload_type(stash, methname, type, level, flags)
2541 HV* stash
2542 SV* methname
2543 int type
2544 I32 level
2545 I32 flags
2546 PREINIT:
2547 STRLEN len;
2548 const char * const name = SvPV_const(methname, len);
5f74c55e 2549 GV* gv = NULL;
d21989ed
BF		 2550 PPCODE:
2551 switch (type) {
2552 case 0:
2553 gv = gv_fetchmeth_autoload(stash, name, len, level);
2554 break;
2555 case 1:
2556 gv = gv_fetchmeth_sv_autoload(stash, methname, level, flags);
2557 break;
2558 case 2:
2559 gv = gv_fetchmeth_pv_autoload(stash, name, level, flags | SvUTF8(methname));
2560 break;
2561 case 3:
2562 gv = gv_fetchmeth_pvn_autoload(stash, name, len, level, flags | SvUTF8(methname));
2563 break;
2564 }
2565 XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
2566
2567void
44130a26
BF		 2568gv_fetchmethod_flags_type(stash, methname, type, flags)
2569 HV* stash
2570 SV* methname
2571 int type
2572 I32 flags
2573 PREINIT:
5f74c55e 2574 GV* gv = NULL;
44130a26
BF		 2575 PPCODE:
2576 switch (type) {
2577 case 0:
2578 gv = gv_fetchmethod_flags(stash, SvPVX_const(methname), flags);
2579 break;
2580 case 1:
2581 gv = gv_fetchmethod_sv_flags(stash, methname, flags);
2582 break;
2583 case 2:
2584 gv = gv_fetchmethod_pv_flags(stash, SvPV_nolen(methname), flags | SvUTF8(methname));
2585 break;
2586 case 3: {
2587 STRLEN len;
2588 const char * const name = SvPV_const(methname, len);
2589 gv = gv_fetchmethod_pvn_flags(stash, name, len, flags | SvUTF8(methname));
2590 break;
2591 }
1665b718
FC		 2592 case 4:
2593 gv = gv_fetchmethod_pvn_flags(stash, SvPV_nolen(methname),
2594 flags, SvUTF8(methname));
44130a26 2595 }
5fba3c91 2596 XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
44130a26 2597
5fba3c91 2598void
0eeb01b9 2599gv_autoload_type(stash, methname, type, method)
5fba3c91
BF		 2600 HV* stash
2601 SV* methname
2602 int type
2603 I32 method
5fba3c91
BF		 2604 PREINIT:
2605 STRLEN len;
2606 const char * const name = SvPV_const(methname, len);
5f74c55e 2607 GV* gv = NULL;
0eeb01b9 2608 I32 flags = method ? GV_AUTOLOAD_ISMETHOD : 0;
5fba3c91
BF		 2609 PPCODE:
2610 switch (type) {
2611 case 0:
2612 gv = gv_autoload4(stash, name, len, method);
2613 break;
2614 case 1:
0eeb01b9 2615 gv = gv_autoload_sv(stash, methname, flags);
5fba3c91
BF		 2616 break;
2617 case 2:
0eeb01b9 2618 gv = gv_autoload_pv(stash, name, flags | SvUTF8(methname));
5fba3c91
BF		 2619 break;
2620 case 3:
0eeb01b9 2621 gv = gv_autoload_pvn(stash, name, len, flags | SvUTF8(methname));
5fba3c91
BF		 2622 break;
2623 }
44130a26
BF		 2624 XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
2625
16a6e5a4
TC		 2626SV *
2627gv_const_sv(SV *name)
2628 PREINIT:
2629 GV *gv;
2630 CODE:
2631 if (SvPOK(name)) {
2632 HV *stash = gv_stashpv("main",0);
2633 HE *he = hv_fetch_ent(stash, name, 0, 0);
2634 gv = (GV *)HeVAL(he);
2635 }
2636 else {
2637 gv = (GV *)name;
2638 }
2639 RETVAL = gv_const_sv(gv);
2640 if (!RETVAL)
2641 XSRETURN_EMPTY;
2642 RETVAL = newSVsv(RETVAL);
2643 OUTPUT:
2644 RETVAL
2645
44130a26 2646void
84c7b88c
BF		 2647whichsig_type(namesv, type)
2648 SV* namesv
2649 int type
2650 PREINIT:
2651 STRLEN len;
2652 const char * const name = SvPV_const(namesv, len);
5f74c55e 2653 I32 i = 0;
84c7b88c
BF		 2654 PPCODE:
2655 switch (type) {
2656 case 0:
2657 i = whichsig(name);
2658 break;
2659 case 1:
2660 i = whichsig_sv(namesv);
2661 break;
2662 case 2:
2663 i = whichsig_pv(name);
2664 break;
2665 case 3:
2666 i = whichsig_pvn(name, len);
2667 break;
2668 }
2669 XPUSHs(sv_2mortal(newSViv(i)));
2670
2671void
d1f347d7
DM		 2672eval_sv(sv, flags)
2673 SV* sv
2674 I32 flags
2675 PREINIT:
2676 I32 i;
2677 PPCODE:
2678 PUTBACK;
2679 i = eval_sv(sv, flags);
2680 SPAGAIN;
2681 EXTEND(SP, 1);
2682 PUSHs(sv_2mortal(newSViv(i)));
2683
b8e65a9b 2684void
d1f347d7
DM		 2685eval_pv(p, croak_on_error)
2686 const char* p
2687 I32 croak_on_error
d1f347d7
DM		 2688 PPCODE:
2689 PUTBACK;
2690 EXTEND(SP, 1);
2691 PUSHs(eval_pv(p, croak_on_error));
2692
2693void
2694require_pv(pv)
2695 const char* pv
d1f347d7
DM		 2696 PPCODE:
2697 PUTBACK;
2698 require_pv(pv);
2699
0ca3a874 2700int
7a646707 2701apitest_exception(throw_e)
0ca3a874
MHM		 2702 int throw_e
2703 OUTPUT:
2704 RETVAL
d1f347d7 2705
ef469b03 2706void
7e7a3dfc
GA		 2707mycroak(sv)
2708 SV* sv
ef469b03 2709 CODE:
7e7a3dfc
GA		 2710 if (SvOK(sv)) {
2711 Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
2712 }
2713 else {
2714 Perl_croak(aTHX_ NULL);
2715 }
5d2b1485
NC		 2716
2717SV*
2718strtab()
2719 CODE:
2720 RETVAL = newRV_inc((SV*)PL_strtab);
2721 OUTPUT:
2722 RETVAL
85ce96a1
DM		 2723
2724int
2725my_cxt_getint()
2726 CODE:
2727 dMY_CXT;
2728 RETVAL = my_cxt_getint_p(aMY_CXT);
2729 OUTPUT:
2730 RETVAL
2731
2732void
2733my_cxt_setint(i)
2734 int i;
2735 CODE:
2736 dMY_CXT;
2737 my_cxt_setint_p(aMY_CXT_ i);
2738
2739void
9568a123
NC		 2740my_cxt_getsv(how)
2741 bool how;
85ce96a1 2742 PPCODE:
85ce96a1 2743 EXTEND(SP, 1);
9568a123 2744 ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
85ce96a1
DM		 2745 XSRETURN(1);
2746
2747void
2748my_cxt_setsv(sv)
2749 SV *sv;
2750 CODE:
2751 dMY_CXT;
2752 SvREFCNT_dec(MY_CXT.sv);
2753 my_cxt_setsv_p(sv _aMY_CXT);
2754 SvREFCNT_inc(sv);
34482cd6
NC		 2755
2756bool
2757sv_setsv_cow_hashkey_core()
2758
2759bool
2760sv_setsv_cow_hashkey_notcore()
84ac5fd7
NC		 2761
2762void
74ee33f2
FC		 2763sv_set_deref(SV *sv, SV *sv2, int which)
2764 CODE:
2765 {
2766 STRLEN len;
2767 const char *pv = SvPV(sv2,len);
2768 if (!SvROK(sv)) croak("Not a ref");
2769 sv = SvRV(sv);
2770 switch (which) {
2771 case 0: sv_setsv(sv,sv2); break;
2772 case 1: sv_setpv(sv,pv); break;
2773 case 2: sv_setpvn(sv,pv,len); break;
2774 }
2775 }
2776
2777void
218787bd
VP		 2778rmagical_cast(sv, type)
2779 SV *sv;
2780 SV *type;
2781 PREINIT:
2782 struct ufuncs uf;
2783 PPCODE:
2784 if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
2785 sv = SvRV(sv);
2786 if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
2787 uf.uf_val = rmagical_a_dummy;
2788 uf.uf_set = NULL;
2789 uf.uf_index = 0;
2790 if (SvTRUE(type)) { /* b */
2791 sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
2792 } else { /* a */
2793 sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
2794 }
2795 XSRETURN_YES;
2796
2797void
2798rmagical_flags(sv)
2799 SV *sv;
2800 PPCODE:
2801 if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
2802 sv = SvRV(sv);
2803 EXTEND(SP, 3);
2804 mXPUSHu(SvFLAGS(sv) & SVs_GMG);
2805 mXPUSHu(SvFLAGS(sv) & SVs_SMG);
2806 mXPUSHu(SvFLAGS(sv) & SVs_RMG);
2807 XSRETURN(3);
2808
2809void
90d1f214
BM		 2810my_caller(level)
2811 I32 level
2812 PREINIT:
2813 const PERL_CONTEXT *cx, *dbcx;
2814 const char *pv;
2815 const GV *gv;
2816 HV *hv;
2817 PPCODE:
2818 cx = caller_cx(level, &dbcx);
2819 EXTEND(SP, 8);
2820
2821 pv = CopSTASHPV(cx->blk_oldcop);
2822 ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
2823 gv = CvGV(cx->blk_sub.cv);
2824 ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
2825
2826 pv = CopSTASHPV(dbcx->blk_oldcop);
2827 ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
2828 gv = CvGV(dbcx->blk_sub.cv);
2829 ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
2830
20439bc7
Z		 2831 ST(4) = cop_hints_fetch_pvs(cx->blk_oldcop, "foo", 0);
2832 ST(5) = cop_hints_fetch_pvn(cx->blk_oldcop, "foo", 3, 0, 0);
2833 ST(6) = cop_hints_fetch_sv(cx->blk_oldcop,
c2b90b61 2834 sv_2mortal(newSVpvs("foo")), 0, 0);
90d1f214 2835
20439bc7 2836 hv = cop_hints_2hv(cx->blk_oldcop, 0);
90d1f214
BM		 2837 ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
2838
2839 XSRETURN(8);
2840
2841void
f9c17636
MB		 2842DPeek (sv)
2843 SV *sv
2844
2845 PPCODE:
5b1f7359 2846 ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
f9c17636
MB		 2847 XSRETURN (1);
2848
2849void
84ac5fd7
NC		 2850BEGIN()
2851 CODE:
2852 sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
2853
2854void
2855CHECK()
2856 CODE:
2857 sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
2858
2859void
2860UNITCHECK()
2861 CODE:
0932863f 2862 sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
84ac5fd7
NC		 2863
2864void
2865INIT()
2866 CODE:
2867 sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
2868
2869void
2870END()
2871 CODE:
2872 sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
30685b56
NC		 2873
2874void
2875utf16_to_utf8 (sv, ...)
2876 SV* sv
2877 ALIAS:
2878 utf16_to_utf8_reversed = 1
2879 PREINIT:
2880 STRLEN len;
2881 U8 *source;
2882 SV *dest;
2883 I32 got; /* Gah, badly thought out APIs */
2884 CODE:
a4d7a71b 2885 if (ix) (void)SvPV_force_nolen(sv);
30685b56
NC		 2886 source = (U8 *)SvPVbyte(sv, len);
2887 /* Optionally only convert part of the buffer. */
2888 if (items > 1) {
2889 len = SvUV(ST(1));
2890 }
2891 /* Mortalise this right now, as we'll be testing croak()s */
2892 dest = sv_2mortal(newSV(len * 3 / 2 + 1));
2893 if (ix) {
25f2e844 2894 utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
30685b56 2895 } else {
25f2e844 2896 utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
30685b56
NC		 2897 }
2898 SvCUR_set(dest, got);
2899 SvPVX(dest)[got] = '\0';
2900 SvPOK_on(dest);
2901 ST(0) = dest;
2902 XSRETURN(1);
879d0c72 2903
6bd7445c
GG		 2904void
2905my_exit(int exitcode)
2906 PPCODE:
2907 my_exit(exitcode);
d97c33b5 2908
209e41dc
NT		 2909U8
2910first_byte(sv)
2911 SV *sv
2912 CODE:
2913 char *s;
2914 STRLEN len;
2915 s = SvPVbyte(sv, len);
2916 RETVAL = s[0];
2917 OUTPUT:
2918 RETVAL
2919
d97c33b5
DM		 2920I32
2921sv_count()
2922 CODE:
2923 RETVAL = PL_sv_count;
2924 OUTPUT:
2925 RETVAL
13b6b3bc
BM		 2926
2927void
2928bhk_record(bool on)
2929 CODE:
2930 dMY_CXT;
2931 MY_CXT.bhk_record = on;
2932 if (on)
2933 av_clear(MY_CXT.bhkav);
65bfe90c 2934
defdfed5 2935void
d9088386
Z		 2936test_magic_chain()
2937 PREINIT:
2938 SV *sv;
2939 MAGIC *callmg, *uvarmg;
2940 CODE:
2941 sv = sv_2mortal(newSV(0));
11f9f0ed
NC		 2942 if (SvTYPE(sv) >= SVt_PVMG) croak_fail();
2943 if (SvMAGICAL(sv)) croak_fail();
d9088386 2944 sv_magic(sv, &PL_sv_yes, PERL_MAGIC_checkcall, (char*)&callmg, 0);
11f9f0ed
NC		 2945 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2946 if (!SvMAGICAL(sv)) croak_fail();
2947 if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
d9088386 2948 callmg = mg_find(sv, PERL_MAGIC_checkcall);
11f9f0ed 2949 if (!callmg) croak_fail();
d9088386 2950 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 2951 croak_fail();
d9088386 2952 sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
11f9f0ed
NC		 2953 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2954 if (!SvMAGICAL(sv)) croak_fail();
2955 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
d9088386 2956 uvarmg = mg_find(sv, PERL_MAGIC_uvar);
11f9f0ed 2957 if (!uvarmg) croak_fail();
d9088386 2958 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 2959 croak_fail();
d9088386 2960 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
11f9f0ed 2961 croak_fail();
d9088386 2962 mg_free_type(sv, PERL_MAGIC_vec);
11f9f0ed
NC		 2963 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2964 if (!SvMAGICAL(sv)) croak_fail();
2965 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2966 if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
d9088386 2967 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 2968 croak_fail();
d9088386 2969 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
11f9f0ed 2970 croak_fail();
d9088386 2971 mg_free_type(sv, PERL_MAGIC_uvar);
11f9f0ed
NC		 2972 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2973 if (!SvMAGICAL(sv)) croak_fail();
2974 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2975 if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
d9088386 2976 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 2977 croak_fail();
d9088386 2978 sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
11f9f0ed
NC		 2979 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2980 if (!SvMAGICAL(sv)) croak_fail();
2981 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
d9088386 2982 uvarmg = mg_find(sv, PERL_MAGIC_uvar);
11f9f0ed 2983 if (!uvarmg) croak_fail();
d9088386 2984 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 2985 croak_fail();
d9088386 2986 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
11f9f0ed 2987 croak_fail();
d9088386 2988 mg_free_type(sv, PERL_MAGIC_checkcall);
11f9f0ed
NC		 2989 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2990 if (!SvMAGICAL(sv)) croak_fail();
2991 if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
2992 if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
d9088386 2993 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
11f9f0ed 2994 croak_fail();
d9088386 2995 mg_free_type(sv, PERL_MAGIC_uvar);
11f9f0ed
NC		 2996 if (SvMAGICAL(sv)) croak_fail();
2997 if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
2998 if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
d9088386
Z		 2999
3000void
3001test_op_contextualize()
3002 PREINIT:
3003 OP *o;
3004 CODE:
3005 o = newSVOP(OP_CONST, 0, newSViv(0));
3006 o->op_flags &= ~OPf_WANT;
3007 o = op_contextualize(o, G_SCALAR);
3008 if (o->op_type != OP_CONST ||
3009 (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
11f9f0ed 3010 croak_fail();
d9088386
Z		 3011 op_free(o);
3012 o = newSVOP(OP_CONST, 0, newSViv(0));
3013 o->op_flags &= ~OPf_WANT;
3014 o = op_contextualize(o, G_ARRAY);
3015 if (o->op_type != OP_CONST ||
3016 (o->op_flags & OPf_WANT) != OPf_WANT_LIST)
11f9f0ed 3017 croak_fail();
d9088386
Z		 3018 op_free(o);
3019 o = newSVOP(OP_CONST, 0, newSViv(0));
3020 o->op_flags &= ~OPf_WANT;
3021 o = op_contextualize(o, G_VOID);
11f9f0ed 3022 if (o->op_type != OP_NULL) croak_fail();
d9088386
Z		 3023 op_free(o);
3024
3025void
3026test_rv2cv_op_cv()
3027 PROTOTYPE:
3028 PREINIT:
7616a0c2 3029 GV *troc_gv;
d9088386
Z		 3030 CV *troc_cv;
3031 OP *o;
3032 CODE:
3033 troc_gv = gv_fetchpv("XS::APItest::test_rv2cv_op_cv", 0, SVt_PVGV);
3034 troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
d9088386 3035 o = newCVREF(0, newGVOP(OP_GV, 0, troc_gv));
11f9f0ed 3036 if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
d9088386 3037 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
11f9f0ed 3038 croak_fail();
d9088386 3039 o->op_private |= OPpENTERSUB_AMPER;
11f9f0ed
NC		 3040 if (rv2cv_op_cv(o, 0)) croak_fail();
3041 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386 3042 o->op_private &= ~OPpENTERSUB_AMPER;
11f9f0ed
NC		 3043 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3044 if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
3045 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
d9088386
Z		 3046 op_free(o);
3047 o = newSVOP(OP_CONST, 0, newSVpv("XS::APItest::test_rv2cv_op_cv", 0));
3048 o->op_private = OPpCONST_BARE;
3049 o = newCVREF(0, o);
11f9f0ed 3050 if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
d9088386 3051 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
11f9f0ed 3052 croak_fail();
d9088386 3053 o->op_private |= OPpENTERSUB_AMPER;
11f9f0ed
NC		 3054 if (rv2cv_op_cv(o, 0)) croak_fail();
3055 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386
Z		 3056 op_free(o);
3057 o = newCVREF(0, newSVOP(OP_CONST, 0, newRV_inc((SV*)troc_cv)));
11f9f0ed 3058 if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
d9088386 3059 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
11f9f0ed 3060 croak_fail();
d9088386 3061 o->op_private |= OPpENTERSUB_AMPER;
11f9f0ed
NC		 3062 if (rv2cv_op_cv(o, 0)) croak_fail();
3063 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386 3064 o->op_private &= ~OPpENTERSUB_AMPER;
11f9f0ed
NC		 3065 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3066 if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
3067 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
d9088386
Z		 3068 op_free(o);
3069 o = newCVREF(0, newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0))));
11f9f0ed
NC		 3070 if (rv2cv_op_cv(o, 0)) croak_fail();
3071 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386 3072 o->op_private |= OPpENTERSUB_AMPER;
11f9f0ed
NC		 3073 if (rv2cv_op_cv(o, 0)) croak_fail();
3074 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386 3075 o->op_private &= ~OPpENTERSUB_AMPER;
11f9f0ed
NC		 3076 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3077 if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY)) croak_fail();
3078 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
d9088386
Z		 3079 op_free(o);
3080 o = newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0)));
11f9f0ed
NC		 3081 if (rv2cv_op_cv(o, 0)) croak_fail();
3082 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386
Z		 3083 op_free(o);
3084
3085void
3086test_cv_getset_call_checker()
3087 PREINIT:
3088 CV *troc_cv, *tsh_cv;
3089 Perl_call_checker ckfun;
3090 SV *ckobj;
3091 CODE:
3092#define check_cc(cv, xckfun, xckobj) \
3093 do { \
3094 cv_get_call_checker((cv), &ckfun, &ckobj); \
779bc08a
NC		 3095 if (ckfun != (xckfun)) croak_fail_ne(FPTR2DPTR(void *, ckfun), xckfun); \
3096 if (ckobj != (xckobj)) croak_fail_ne(FPTR2DPTR(void *, ckobj), xckobj); \
d9088386
Z		 3097 } while(0)
3098 troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
3099 tsh_cv = get_cv("XS::APItest::test_savehints", 0);
3100 check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
3101 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
3102 cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3103 &PL_sv_yes);
3104 check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
3105 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
3106 cv_set_call_checker(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
3107 check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
3108 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
3109 cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3110 (SV*)tsh_cv);
3111 check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
3112 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
3113 cv_set_call_checker(troc_cv, Perl_ck_entersub_args_proto_or_list,
3114 (SV*)troc_cv);
3115 check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
3116 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
11f9f0ed
NC		 3117 if (SvMAGICAL((SV*)troc_cv) || SvMAGIC((SV*)troc_cv)) croak_fail();
3118 if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
d9088386
Z		 3119#undef check_cc
3120
3121void
3122cv_set_call_checker_lists(CV *cv)
3123 CODE:
3124 cv_set_call_checker(cv, THX_ck_entersub_args_lists, &PL_sv_undef);
3125
3126void
3127cv_set_call_checker_scalars(CV *cv)
3128 CODE:
3129 cv_set_call_checker(cv, THX_ck_entersub_args_scalars, &PL_sv_undef);
3130
3131void
3132cv_set_call_checker_proto(CV *cv, SV *proto)
3133 CODE:
3134 if (SvROK(proto))
3135 proto = SvRV(proto);
3136 cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto);
3137
3138void
3139cv_set_call_checker_proto_or_list(CV *cv, SV *proto)
3140 CODE:
3141 if (SvROK(proto))
3142 proto = SvRV(proto);
3143 cv_set_call_checker(cv, Perl_ck_entersub_args_proto_or_list, proto);
3144
3145void
3146cv_set_call_checker_multi_sum(CV *cv)
3147 CODE:
3148 cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef);
3149
3150void
20439bc7
Z		 3151test_cophh()
3152 PREINIT:
3153 COPHH *a, *b;
72900640
KW		 3154#ifdef EBCDIC
3155 SV* key_sv;
3156 char * key_name;
3157 STRLEN key_len;
3158#endif
20439bc7
Z		 3159 CODE:
3160#define check_ph(EXPR) \
3161 do { if((EXPR) != &PL_sv_placeholder) croak("fail"); } while(0)
3162#define check_iv(EXPR, EXPECT) \
3163 do { if(SvIV(EXPR) != (EXPECT)) croak("fail"); } while(0)
3164#define msvpvs(STR) sv_2mortal(newSVpvs(STR))
3165#define msviv(VALUE) sv_2mortal(newSViv(VALUE))
3166 a = cophh_new_empty();
3167 check_ph(cophh_fetch_pvn(a, "foo_1", 5, 0, 0));
3168 check_ph(cophh_fetch_pvs(a, "foo_1", 0));
3169 check_ph(cophh_fetch_pv(a, "foo_1", 0, 0));
3170 check_ph(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0));
3171 a = cophh_store_pvn(a, "foo_1abc", 5, 0, msviv(111), 0);
3172 a = cophh_store_pvs(a, "foo_2", msviv(222), 0);
3173 a = cophh_store_pv(a, "foo_3", 0, msviv(333), 0);
3174 a = cophh_store_sv(a, msvpvs("foo_4"), 0, msviv(444), 0);
3175 check_iv(cophh_fetch_pvn(a, "foo_1xyz", 5, 0, 0), 111);
3176 check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111);
3177 check_iv(cophh_fetch_pv(a, "foo_1", 0, 0), 111);
3178 check_iv(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0), 111);
3179 check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222);
3180 check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3181 check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3182 check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3183 b = cophh_copy(a);
3184 b = cophh_store_pvs(b, "foo_1", msviv(1111), 0);
3185 check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111);
3186 check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222);
3187 check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3188 check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3189 check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3190 check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
3191 check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
3192 check_iv(cophh_fetch_pvs(b, "foo_3", 0), 333);
3193 check_iv(cophh_fetch_pvs(b, "foo_4", 0), 444);
3194 check_ph(cophh_fetch_pvs(b, "foo_5", 0));
3195 a = cophh_delete_pvn(a, "foo_1abc", 5, 0, 0);
3196 a = cophh_delete_pvs(a, "foo_2", 0);
3197 b = cophh_delete_pv(b, "foo_3", 0, 0);
3198 b = cophh_delete_sv(b, msvpvs("foo_4"), 0, 0);
3199 check_ph(cophh_fetch_pvs(a, "foo_1", 0));
3200 check_ph(cophh_fetch_pvs(a, "foo_2", 0));
3201 check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3202 check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3203 check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3204 check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
3205 check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
3206 check_ph(cophh_fetch_pvs(b, "foo_3", 0));
3207 check_ph(cophh_fetch_pvs(b, "foo_4", 0));
3208 check_ph(cophh_fetch_pvs(b, "foo_5", 0));
3209 b = cophh_delete_pvs(b, "foo_3", 0);
3210 b = cophh_delete_pvs(b, "foo_5", 0);
3211 check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
3212 check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
3213 check_ph(cophh_fetch_pvs(b, "foo_3", 0));
3214 check_ph(cophh_fetch_pvs(b, "foo_4", 0));
3215 check_ph(cophh_fetch_pvs(b, "foo_5", 0));
3216 cophh_free(b);
3217 check_ph(cophh_fetch_pvs(a, "foo_1", 0));
3218 check_ph(cophh_fetch_pvs(a, "foo_2", 0));
3219 check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3220 check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3221 check_ph(cophh_fetch_pvs(a, "foo_5", 0));
72900640 3222 a = cophh_store_pvs(a, "foo_1", msviv(11111), COPHH_KEY_UTF8);
20439bc7 3223 a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0);
72900640 3224#ifndef EBCDIC
20439bc7 3225 a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8);
72900640
KW		 3226#else
3227 /* On EBCDIC, we need to translate the UTF-8 in the ASCII test to the
3228 * equivalent UTF-EBCDIC for the code page. This is done at runtime
3229 * (with the helper function in this file). Therefore we can't use
3230 * cophhh_store_pvs(), as we don't have literal string */
3231 key_sv = sv_2mortal(newSVpvs("foo_"));
3232 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb"));
3233 key_name = SvPV(key_sv, key_len);
3234 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(456), COPHH_KEY_UTF8);
3235#endif
3236#ifndef EBCDIC
20439bc7 3237 a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8);
72900640
KW		 3238#else
3239 sv_setpvs(key_sv, "foo_");
3240 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c"));
3241 key_name = SvPV(key_sv, key_len);
3242 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(789), COPHH_KEY_UTF8);
3243#endif
3244#ifndef EBCDIC
20439bc7 3245 a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8);
72900640
KW		 3246#else
3247 sv_setpvs(key_sv, "foo_");
3248 cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6"));
3249 key_name = SvPV(key_sv, key_len);
3250 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(666), COPHH_KEY_UTF8);
3251#endif
20439bc7
Z		 3252 check_iv(cophh_fetch_pvs(a, "foo_1", 0), 11111);
3253 check_iv(cophh_fetch_pvs(a, "foo_1", COPHH_KEY_UTF8), 11111);
3254 check_iv(cophh_fetch_pvs(a, "foo_\xaa", 0), 123);
72900640 3255#ifndef EBCDIC
20439bc7
Z		 3256 check_iv(cophh_fetch_pvs(a, "foo_\xc2\xaa", COPHH_KEY_UTF8), 123);
3257 check_ph(cophh_fetch_pvs(a, "foo_\xc2\xaa", 0));
72900640
KW		 3258#else
3259 sv_setpvs(key_sv, "foo_");
3260 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xaa"));
3261 key_name = SvPV(key_sv, key_len);
3262 check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 123);
3263 check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3264#endif
20439bc7 3265 check_iv(cophh_fetch_pvs(a, "foo_\xbb", 0), 456);
72900640 3266#ifndef EBCDIC
20439bc7
Z		 3267 check_iv(cophh_fetch_pvs(a, "foo_\xc2\xbb", COPHH_KEY_UTF8), 456);
3268 check_ph(cophh_fetch_pvs(a, "foo_\xc2\xbb", 0));
72900640
KW		 3269#else
3270 sv_setpvs(key_sv, "foo_");
3271 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb"));
3272 key_name = SvPV(key_sv, key_len);
3273 check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 456);
3274 check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3275#endif
20439bc7 3276 check_iv(cophh_fetch_pvs(a, "foo_\xcc", 0), 789);
72900640 3277#ifndef EBCDIC
20439bc7
Z		 3278 check_iv(cophh_fetch_pvs(a, "foo_\xc3\x8c", COPHH_KEY_UTF8), 789);
3279 check_ph(cophh_fetch_pvs(a, "foo_\xc2\x8c", 0));
72900640
KW		 3280#else
3281 sv_setpvs(key_sv, "foo_");
3282 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c"));
3283 key_name = SvPV(key_sv, key_len);
3284 check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 789);
3285 check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3286#endif
3287#ifndef EBCDIC
20439bc7
Z		 3288 check_iv(cophh_fetch_pvs(a, "foo_\xd9\xa6", COPHH_KEY_UTF8), 666);
3289 check_ph(cophh_fetch_pvs(a, "foo_\xd9\xa6", 0));
72900640
KW		 3290#else
3291 sv_setpvs(key_sv, "foo_");
3292 cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6"));
3293 key_name = SvPV(key_sv, key_len);
3294 check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 666);
3295 check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3296#endif
3987a177
Z		 3297 ENTER;
3298 SAVEFREECOPHH(a);
3299 LEAVE;
20439bc7
Z		 3300#undef check_ph
3301#undef check_iv
3302#undef msvpvs
3303#undef msviv
3304
8375c93e
RU		 3305void
3306test_coplabel()
3307 PREINIT:
3308 COP *cop;
32708f0b
CB		 3309 const char *label;
3310 STRLEN len;
3311 U32 utf8;
8375c93e
RU		 3312 CODE:
3313 cop = &PL_compiling;
32708f0b
CB		 3314 Perl_cop_store_label(aTHX_ cop, "foo", 3, 0);
3315 label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
3316 if (strcmp(label,"foo")) croak("fail # cop_fetch_label label");
3317 if (len != 3) croak("fail # cop_fetch_label len");
3318 if (utf8) croak("fail # cop_fetch_label utf8");
8375c93e 3319 /* SMALL GERMAN UMLAUT A */
a1cd495a 3320 Perl_cop_store_label(aTHX_ cop, "fo\xc3\xa4", 4, SVf_UTF8);
32708f0b 3321 label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
a1cd495a 3322 if (strcmp(label,"fo\xc3\xa4")) croak("fail # cop_fetch_label label");
72024711 3323 if (len != 4) croak("fail # cop_fetch_label len");
32708f0b 3324 if (!utf8) croak("fail # cop_fetch_label utf8");
8375c93e
RU		 3325
3326
20439bc7
Z		 3327HV *
3328example_cophh_2hv()
3329 PREINIT:
3330 COPHH *a;
72900640
KW		 3331#ifdef EBCDIC
3332 SV* key_sv;
3333 char * key_name;
3334 STRLEN key_len;
3335#endif
20439bc7
Z		 3336 CODE:
3337#define msviv(VALUE) sv_2mortal(newSViv(VALUE))
3338 a = cophh_new_empty();
3339 a = cophh_store_pvs(a, "foo_0", msviv(999), 0);
3340 a = cophh_store_pvs(a, "foo_1", msviv(111), 0);
3341 a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0);
72900640 3342#ifndef EBCDIC
20439bc7 3343 a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8);
72900640
KW		 3344#else
3345 key_sv = sv_2mortal(newSVpvs("foo_"));
3346 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb"));
3347 key_name = SvPV(key_sv, key_len);
3348 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(456), COPHH_KEY_UTF8);
3349#endif
3350#ifndef EBCDIC
20439bc7 3351 a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8);
72900640
KW		 3352#else
3353 sv_setpvs(key_sv, "foo_");
3354 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c"));
3355 key_name = SvPV(key_sv, key_len);
3356 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(789), COPHH_KEY_UTF8);
3357#endif
3358#ifndef EBCDIC
20439bc7 3359 a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8);
72900640
KW		 3360#else
3361 sv_setpvs(key_sv, "foo_");
3362 cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6"));
3363 key_name = SvPV(key_sv, key_len);
3364 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(666), COPHH_KEY_UTF8);
3365#endif
20439bc7
Z		 3366 a = cophh_delete_pvs(a, "foo_0", 0);
3367 a = cophh_delete_pvs(a, "foo_2", 0);
3368 RETVAL = cophh_2hv(a, 0);
3369 cophh_free(a);
3370#undef msviv
3371 OUTPUT:
3372 RETVAL
3373
3374void
defdfed5
Z		 3375test_savehints()
3376 PREINIT:
3377 SV **svp, *sv;
3378 CODE:
3379#define store_hint(KEY, VALUE) \
3380 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
3381#define hint_ok(KEY, EXPECT) \
3382 ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
3383 (sv = *svp) && SvIV(sv) == (EXPECT) && \
20439bc7 3384 (sv = cop_hints_fetch_pvs(&PL_compiling, KEY, 0)) && \
defdfed5
Z		 3385 SvIV(sv) == (EXPECT))
3386#define check_hint(KEY, EXPECT) \
11f9f0ed 3387 do { if (!hint_ok(KEY, EXPECT)) croak_fail(); } while(0)
defdfed5
Z		 3388 PL_hints |= HINT_LOCALIZE_HH;
3389 ENTER;
3390 SAVEHINTS();
3391 PL_hints &= HINT_INTEGER;
3392 store_hint("t0", 123);
3393 store_hint("t1", 456);
11f9f0ed 3394 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z		 3395 check_hint("t0", 123); check_hint("t1", 456);
3396 ENTER;
3397 SAVEHINTS();
11f9f0ed 3398 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z		 3399 check_hint("t0", 123); check_hint("t1", 456);
3400 PL_hints |= HINT_INTEGER;
3401 store_hint("t0", 321);
11f9f0ed 3402 if (!(PL_hints & HINT_INTEGER)) croak_fail();
defdfed5
Z		 3403 check_hint("t0", 321); check_hint("t1", 456);
3404 LEAVE;
11f9f0ed 3405 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z		 3406 check_hint("t0", 123); check_hint("t1", 456);
3407 ENTER;
3408 SAVEHINTS();
11f9f0ed 3409 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z		 3410 check_hint("t0", 123); check_hint("t1", 456);
3411 store_hint("t1", 654);
11f9f0ed 3412 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z		 3413 check_hint("t0", 123); check_hint("t1", 654);
3414 LEAVE;
11f9f0ed 3415 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z		 3416 check_hint("t0", 123); check_hint("t1", 456);
3417 LEAVE;
3418#undef store_hint
3419#undef hint_ok
3420#undef check_hint
3421
3422void
3423test_copyhints()
3424 PREINIT:
3425 HV *a, *b;
3426 CODE:
3427 PL_hints |= HINT_LOCALIZE_HH;
3428 ENTER;
3429 SAVEHINTS();
3430 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
20439bc7
Z		 3431 if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123)
3432 croak_fail();
defdfed5
Z		 3433 a = newHVhv(GvHV(PL_hintgv));
3434 sv_2mortal((SV*)a);
3435 sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
20439bc7
Z		 3436 if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123)
3437 croak_fail();
defdfed5
Z		 3438 b = hv_copy_hints_hv(a);
3439 sv_2mortal((SV*)b);
3440 sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
20439bc7
Z		 3441 if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 789)
3442 croak_fail();
defdfed5
Z		 3443 LEAVE;
3444
201c7e1f 3445void
2fcb4757
Z		 3446test_op_list()
3447 PREINIT:
3448 OP *a;
3449 CODE:
3450#define iv_op(iv) newSVOP(OP_CONST, 0, newSViv(iv))
3451#define check_op(o, expect) \
3452 do { \
2e66fe90
FC		 3453 if (strcmp(test_op_list_describe(o), (expect))) \
3454 croak("fail %s %s", test_op_list_describe(o), (expect)); \
2fcb4757
Z		 3455 } while(0)
3456 a = op_append_elem(OP_LIST, NULL, NULL);
3457 check_op(a, "");
3458 a = op_append_elem(OP_LIST, iv_op(1), a);
3459 check_op(a, "const(1).");
3460 a = op_append_elem(OP_LIST, NULL, a);
3461 check_op(a, "const(1).");
3462 a = op_append_elem(OP_LIST, a, iv_op(2));
3463 check_op(a, "list[pushmark.const(1).const(2).]");
3464 a = op_append_elem(OP_LIST, a, iv_op(3));
3465 check_op(a, "list[pushmark.const(1).const(2).const(3).]");
3466 a = op_append_elem(OP_LIST, a, NULL);
3467 check_op(a, "list[pushmark.const(1).const(2).const(3).]");
3468 a = op_append_elem(OP_LIST, NULL, a);
3469 check_op(a, "list[pushmark.const(1).const(2).const(3).]");
3470 a = op_append_elem(OP_LIST, iv_op(4), a);
3471 check_op(a, "list[pushmark.const(4)."
3472 "list[pushmark.const(1).const(2).const(3).]]");
3473 a = op_append_elem(OP_LIST, a, iv_op(5));
3474 check_op(a, "list[pushmark.const(4)."
3475 "list[pushmark.const(1).const(2).const(3).]const(5).]");
3476 a = op_append_elem(OP_LIST, a,
3477 op_append_elem(OP_LIST, iv_op(7), iv_op(6)));
3478 check_op(a, "list[pushmark.const(4)."
3479 "list[pushmark.const(1).const(2).const(3).]const(5)."
3480 "list[pushmark.const(7).const(6).]]");
3481 op_free(a);
3482 a = op_append_elem(OP_LINESEQ, iv_op(1), iv_op(2));
3483 check_op(a, "lineseq[const(1).const(2).]");
3484 a = op_append_elem(OP_LINESEQ, a, iv_op(3));
3485 check_op(a, "lineseq[const(1).const(2).const(3).]");
3486 op_free(a);
3487 a = op_append_elem(OP_LINESEQ,
3488 op_append_elem(OP_LIST, iv_op(1), iv_op(2)),
3489 iv_op(3));
3490 check_op(a, "lineseq[list[pushmark.const(1).const(2).]const(3).]");
3491 op_free(a);
3492 a = op_prepend_elem(OP_LIST, NULL, NULL);
3493 check_op(a, "");
3494 a = op_prepend_elem(OP_LIST, a, iv_op(1));
3495 check_op(a, "const(1).");
3496 a = op_prepend_elem(OP_LIST, a, NULL);
3497 check_op(a, "const(1).");
3498 a = op_prepend_elem(OP_LIST, iv_op(2), a);
3499 check_op(a, "list[pushmark.const(2).const(1).]");
3500 a = op_prepend_elem(OP_LIST, iv_op(3), a);
3501 check_op(a, "list[pushmark.const(3).const(2).const(1).]");
3502 a = op_prepend_elem(OP_LIST, NULL, a);
3503 check_op(a, "list[pushmark.const(3).const(2).const(1).]");
3504 a = op_prepend_elem(OP_LIST, a, NULL);
3505 check_op(a, "list[pushmark.const(3).const(2).const(1).]");
3506 a = op_prepend_elem(OP_LIST, a, iv_op(4));
3507 check_op(a, "list[pushmark."
3508 "list[pushmark.const(3).const(2).const(1).]const(4).]");
3509 a = op_prepend_elem(OP_LIST, iv_op(5), a);
3510 check_op(a, "list[pushmark.const(5)."
3511 "list[pushmark.const(3).const(2).const(1).]const(4).]");
3512 a = op_prepend_elem(OP_LIST,
3513 op_prepend_elem(OP_LIST, iv_op(6), iv_op(7)), a);
3514 check_op(a, "list[pushmark.list[pushmark.const(6).const(7).]const(5)."
3515 "list[pushmark.const(3).const(2).const(1).]const(4).]");
3516 op_free(a);
3517 a = op_prepend_elem(OP_LINESEQ, iv_op(2), iv_op(1));
3518 check_op(a, "lineseq[const(2).const(1).]");
3519 a = op_prepend_elem(OP_LINESEQ, iv_op(3), a);
3520 check_op(a, "lineseq[const(3).const(2).const(1).]");
3521 op_free(a);
3522 a = op_prepend_elem(OP_LINESEQ, iv_op(3),
3523 op_prepend_elem(OP_LIST, iv_op(2), iv_op(1)));
3524 check_op(a, "lineseq[const(3).list[pushmark.const(2).const(1).]]");
3525 op_free(a);
3526 a = op_append_list(OP_LINESEQ, NULL, NULL);
3527 check_op(a, "");
3528 a = op_append_list(OP_LINESEQ, iv_op(1), a);
3529 check_op(a, "const(1).");
3530 a = op_append_list(OP_LINESEQ, NULL, a);
3531 check_op(a, "const(1).");
3532 a = op_append_list(OP_LINESEQ, a, iv_op(2));
3533 check_op(a, "lineseq[const(1).const(2).]");
3534 a = op_append_list(OP_LINESEQ, a, iv_op(3));
3535 check_op(a, "lineseq[const(1).const(2).const(3).]");
3536 a = op_append_list(OP_LINESEQ, iv_op(4), a);
3537 check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
3538 a = op_append_list(OP_LINESEQ, a, NULL);
3539 check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
3540 a = op_append_list(OP_LINESEQ, NULL, a);
3541 check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
3542 a = op_append_list(OP_LINESEQ, a,
3543 op_append_list(OP_LINESEQ, iv_op(5), iv_op(6)));
3544 check_op(a, "lineseq[const(4).const(1).const(2).const(3)."
3545 "const(5).const(6).]");
3546 op_free(a);
3547 a = op_append_list(OP_LINESEQ,
3548 op_append_list(OP_LINESEQ, iv_op(1), iv_op(2)),
3549 op_append_list(OP_LIST, iv_op(3), iv_op(4)));
3550 check_op(a, "lineseq[const(1).const(2)."
3551 "list[pushmark.const(3).const(4).]]");
3552 op_free(a);
3553 a = op_append_list(OP_LINESEQ,
3554 op_append_list(OP_LIST, iv_op(1), iv_op(2)),
3555 op_append_list(OP_LINESEQ, iv_op(3), iv_op(4)));
3556 check_op(a, "lineseq[list[pushmark.const(1).const(2).]"
3557 "const(3).const(4).]");
3558 op_free(a);
2fcb4757
Z		 3559#undef check_op
3560
3561void
5983a79d
BM		 3562test_op_linklist ()
3563 PREINIT:
3564 OP *o;
3565 CODE:
3566#define check_ll(o, expect) \
3567 STMT_START { \
2e66fe90
FC		 3568 if (strNE(test_op_linklist_describe(o), (expect))) \
3569 croak("fail %s %s", test_op_linklist_describe(o), (expect)); \
5983a79d
BM		 3570 } STMT_END
3571 o = iv_op(1);
3572 check_ll(o, ".const1");
3573 op_free(o);
3574
3575 o = mkUNOP(OP_NOT, iv_op(1));
3576 check_ll(o, ".const1.not");
3577 op_free(o);
3578
3579 o = mkUNOP(OP_NOT, mkUNOP(OP_NEGATE, iv_op(1)));
3580 check_ll(o, ".const1.negate.not");
3581 op_free(o);
3582
3583 o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
3584 check_ll(o, ".const1.const2.add");
3585 op_free(o);
3586
3587 o = mkBINOP(OP_ADD, mkUNOP(OP_NOT, iv_op(1)), iv_op(2));
3588 check_ll(o, ".const1.not.const2.add");
3589 op_free(o);
3590
3591 o = mkUNOP(OP_NOT, mkBINOP(OP_ADD, iv_op(1), iv_op(2)));
3592 check_ll(o, ".const1.const2.add.not");
3593 op_free(o);
3594
3595 o = mkLISTOP(OP_LINESEQ, iv_op(1), iv_op(2), iv_op(3));
3596 check_ll(o, ".const1.const2.const3.lineseq");
3597 op_free(o);
3598
3599 o = mkLISTOP(OP_LINESEQ,
3600 mkBINOP(OP_ADD, iv_op(1), iv_op(2)),
3601 mkUNOP(OP_NOT, iv_op(3)),
3602 mkLISTOP(OP_SUBSTR, iv_op(4), iv_op(5), iv_op(6)));
3603 check_ll(o, ".const1.const2.add.const3.not"
3604 ".const4.const5.const6.substr.lineseq");
3605 op_free(o);
3606
3607 o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
3608 LINKLIST(o);
3609 o = mkBINOP(OP_SUBTRACT, o, iv_op(3));
3610 check_ll(o, ".const1.const2.add.const3.subtract");
3611 op_free(o);
3612#undef check_ll
3613#undef iv_op
3614
3615void
201c7e1f
FR		 3616peep_enable ()
3617 PREINIT:
3618 dMY_CXT;
3619 CODE:
3620 av_clear(MY_CXT.peep_recorder);
3621 av_clear(MY_CXT.rpeep_recorder);
3622 MY_CXT.peep_recording = 1;
3623
3624void
3625peep_disable ()
3626 PREINIT:
3627 dMY_CXT;
3628 CODE:
3629 MY_CXT.peep_recording = 0;
3630
3631SV *
3632peep_record ()
3633 PREINIT:
3634 dMY_CXT;
3635 CODE:
95d2461a 3636 RETVAL = newRV_inc((SV *)MY_CXT.peep_recorder);
201c7e1f
FR		 3637 OUTPUT:
3638 RETVAL
3639
3640SV *
3641rpeep_record ()
3642 PREINIT:
3643 dMY_CXT;
3644 CODE:
95d2461a 3645 RETVAL = newRV_inc((SV *)MY_CXT.rpeep_recorder);
201c7e1f
FR		 3646 OUTPUT:
3647 RETVAL
3648
9c540340
DM		 3649=pod
3650
3651multicall_each: call a sub for each item in the list. Used to test MULTICALL
3652
3653=cut
3654
3655void
3656multicall_each(block,...)
3657 SV * block
3658PROTOTYPE: &@
3659CODE:
3660{
3661 dMULTICALL;
3662 int index;
3663 GV *gv;
3664 HV *stash;
3665 I32 gimme = G_SCALAR;
3666 SV **args = &PL_stack_base[ax];
3667 CV *cv;
3668
3669 if(items <= 1) {
3670 XSRETURN_UNDEF;
3671 }
3672 cv = sv_2cv(block, &stash, &gv, 0);
3673 if (cv == Nullcv) {
3674 croak("multicall_each: not a subroutine reference");
3675 }
3676 PUSH_MULTICALL(cv);
3677 SAVESPTR(GvSV(PL_defgv));
3678
3679 for(index = 1 ; index < items ; index++) {
3680 GvSV(PL_defgv) = args[index];
3681 MULTICALL;
3682 }
3683 POP_MULTICALL;
3684 XSRETURN_UNDEF;
3685}
3686
1f0ba93b
DM		 3687=pod
3688
3689multicall_return(): call the passed sub once in the specificed context
3690and return whatever it returns
3691
3692=cut
3693
3694void
3695multicall_return(block, context)
3696 SV *block
3697 I32 context
3698PROTOTYPE: &$
3699CODE:
3700{
3701 dSP;
3702 dMULTICALL;
3703 GV *gv;
3704 HV *stash;
3705 I32 gimme = context;
3706 CV *cv;
3707 AV *av;
3708 SV **p;
052a7c76 3709 SSize_t i, size;
1f0ba93b
DM		 3710
3711 cv = sv_2cv(block, &stash, &gv, 0);
3712 if (cv == Nullcv) {
3713 croak("multicall_return not a subroutine reference");
3714 }
3715 PUSH_MULTICALL(cv);
3716
3717 MULTICALL;
3718
3719 /* copy returned values into an array so they're not freed during
3720 * POP_MULTICALL */
3721
3722 av = newAV();
3723 SPAGAIN;
3724
3725 switch (context) {
3726 case G_VOID:
3727 break;
3728
3729 case G_SCALAR:
3730 av_push(av, SvREFCNT_inc(TOPs));
3731 break;
3732
3733 case G_ARRAY:
3734 for (p = PL_stack_base + 1; p <= SP; p++)
3735 av_push(av, SvREFCNT_inc(*p));
3736 break;
3737 }
3738
3739 POP_MULTICALL;
3740
1f0ba93b
DM		 3741 size = AvFILLp(av) + 1;
3742 EXTEND(SP, size);
3743 for (i = 0; i < size; i++)
3744 ST(i) = *av_fetch(av, i, FALSE);
3745 sv_2mortal((SV*)av);
3746 XSRETURN(size);
3747}
3748
3749
7b81e549
GG		 3750#ifdef USE_ITHREADS
3751
3752void
3753clone_with_stack()
3754CODE:
3755{
3756 PerlInterpreter *interp = aTHX; /* The original interpreter */
3757 PerlInterpreter *interp_dup; /* The duplicate interpreter */
3758 int oldscope = 1; /* We are responsible for all scopes */
3759
3760 interp_dup = perl_clone(interp, CLONEf_COPY_STACKS | CLONEf_CLONE_HOST );
3761
3762 /* destroy old perl */
3763 PERL_SET_CONTEXT(interp);
3764
3765 POPSTACK_TO(PL_mainstack);
9d9ff9a6
DM		 3766 if (cxstack_ix >= 0) {
3767 dounwind(-1);
ed8ff0f3 3768 cx_popblock(cxstack);
9d9ff9a6 3769 }
7b81e549 3770 LEAVE_SCOPE(0);
9d9ff9a6 3771 PL_scopestack_ix = oldscope;
7b81e549
GG		 3772 FREETMPS;
3773
3774 perl_destruct(interp);
3775 perl_free(interp);
3776
3777 /* switch to new perl */
3778 PERL_SET_CONTEXT(interp_dup);
3779
3780 /* continue after 'clone_with_stack' */
4a808ed1
MS		 3781 if (interp_dup->Iop)
3782 interp_dup->Iop = interp_dup->Iop->op_next;
7b81e549
GG		 3783
3784 /* run with new perl */
3785 Perl_runops_standard(interp_dup);
3786
3787 /* We may have additional unclosed scopes if fork() was called
3788 * from within a BEGIN block. See perlfork.pod for more details.
3789 * We cannot clean up these other scopes because they belong to a
3790 * different interpreter, but we also cannot leave PL_scopestack_ix
3791 * dangling because that can trigger an assertion in perl_destruct().
3792 */
3793 if (PL_scopestack_ix > oldscope) {
3794 PL_scopestack[oldscope-1] = PL_scopestack[PL_scopestack_ix-1];
3795 PL_scopestack_ix = oldscope;
3796 }
3797
3798 perl_destruct(interp_dup);
3799 perl_free(interp_dup);
3800
3801 /* call the real 'exit' not PerlProc_exit */
3802#undef exit
3803 exit(0);
3804}
3805
3806#endif /* USE_ITHREDS */
9c540340 3807
88b5a879
GF		 3808SV*
3809take_svref(SVREF sv)
3810CODE:
3811 RETVAL = newRV_inc(sv);
3812OUTPUT:
3813 RETVAL
3814
3815SV*
3816take_avref(AV* av)
3817CODE:
3818 RETVAL = newRV_inc((SV*)av);
3819OUTPUT:
3820 RETVAL
3821
3822SV*
3823take_hvref(HV* hv)
3824CODE:
3825 RETVAL = newRV_inc((SV*)hv);
3826OUTPUT:
3827 RETVAL
3828
3829
3830SV*
3831take_cvref(CV* cv)
3832CODE:
3833 RETVAL = newRV_inc((SV*)cv);
3834OUTPUT:
3835 RETVAL
3836
3837
e2fe06dd
EB		 3838BOOT:
3839 {
3840 HV* stash;
3841 SV** meth = NULL;
3842 CV* cv;
3843 stash = gv_stashpv("XS::APItest::TempLv", 0);
3844 if (stash)
3845 meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
3846 if (!meth)
3847 croak("lost method 'make_temp_mg_lv'");
3848 cv = GvCV(*meth);
3849 CvLVALUE_on(cv);
3850 }
83f8bb56
Z		 3851
3852BOOT:
3853{
3854 hintkey_rpn_sv = newSVpvs_share("XS::APItest/rpn");
3855 hintkey_calcrpn_sv = newSVpvs_share("XS::APItest/calcrpn");
3856 hintkey_stufftest_sv = newSVpvs_share("XS::APItest/stufftest");
3857 hintkey_swaptwostmts_sv = newSVpvs_share("XS::APItest/swaptwostmts");
07ffcb73 3858 hintkey_looprest_sv = newSVpvs_share("XS::APItest/looprest");
a7aaec61 3859 hintkey_scopelessblock_sv = newSVpvs_share("XS::APItest/scopelessblock");
9eb5c532
Z		 3860 hintkey_stmtasexpr_sv = newSVpvs_share("XS::APItest/stmtasexpr");
3861 hintkey_stmtsasexpr_sv = newSVpvs_share("XS::APItest/stmtsasexpr");
e53d8f76
Z		 3862 hintkey_loopblock_sv = newSVpvs_share("XS::APItest/loopblock");
3863 hintkey_blockasexpr_sv = newSVpvs_share("XS::APItest/blockasexpr");
361d9b55
Z		 3864 hintkey_swaplabel_sv = newSVpvs_share("XS::APItest/swaplabel");
3865 hintkey_labelconst_sv = newSVpvs_share("XS::APItest/labelconst");
78cdf107
Z		 3866 hintkey_arrayfullexpr_sv = newSVpvs_share("XS::APItest/arrayfullexpr");
3867 hintkey_arraylistexpr_sv = newSVpvs_share("XS::APItest/arraylistexpr");
3868 hintkey_arraytermexpr_sv = newSVpvs_share("XS::APItest/arraytermexpr");
3869 hintkey_arrayarithexpr_sv = newSVpvs_share("XS::APItest/arrayarithexpr");
3870 hintkey_arrayexprflags_sv = newSVpvs_share("XS::APItest/arrayexprflags");
ce409cc8 3871 hintkey_DEFSV_sv = newSVpvs_share("XS::APItest/DEFSV");
25f5d540 3872 hintkey_with_vars_sv = newSVpvs_share("XS::APItest/with_vars");
03d05f6e 3873 hintkey_join_with_space_sv = newSVpvs_share("XS::APItest/join_with_space");
83f8bb56
Z		 3874 next_keyword_plugin = PL_keyword_plugin;
3875 PL_keyword_plugin = my_keyword_plugin;
3876}
8f89e5a9
Z		 3877
3878void
3879establish_cleanup(...)
3880PROTOTYPE: $
3881CODE:
c33e8be1 3882 PERL_UNUSED_VAR(items);
8f89e5a9
Z		 3883 croak("establish_cleanup called as a function");
3884
3885BOOT:
3886{
3887 CV *estcv = get_cv("XS::APItest::establish_cleanup", 0);
3888 cv_set_call_checker(estcv, THX_ck_entersub_establish_cleanup, (SV*)estcv);
3889}
3ad73efd
Z		 3890
3891void
3892postinc(...)
3893PROTOTYPE: $
3894CODE:
c33e8be1 3895 PERL_UNUSED_VAR(items);
3ad73efd
Z		 3896 croak("postinc called as a function");
3897
27fcb6ee
FC		 3898void
3899filter()
3900CODE:
3901 filter_add(filter_call, NULL);
3902
3ad73efd
Z		 3903BOOT:
3904{
3905 CV *asscv = get_cv("XS::APItest::postinc", 0);
3906 cv_set_call_checker(asscv, THX_ck_entersub_postinc, (SV*)asscv);
3907}
26ab20ee 3908
fba8e77b
FC		 3909SV *
3910lv_temp_object()
3911CODE:
3912 RETVAL =
3913 sv_bless(
3914 newRV_noinc(newSV(0)),
3915 gv_stashpvs("XS::APItest::TempObj",GV_ADD)
3916 ); /* Package defined in test script */
3917OUTPUT:
3918 RETVAL
3919
7d6175ef 3920void
65b22876 3921fill_hash_with_nulls(HV *hv)
a2bf5ab1 3922PREINIT:
7d6175ef 3923 UV i = 0;
a2bf5ab1 3924CODE:
7d6175ef
FC		 3925 for(; i < 1000; ++i) {
3926 HE *entry = hv_fetch_ent(hv, sv_2mortal(newSVuv(i)), 1, 0);
3927 SvREFCNT_dec(HeVAL(entry));
3928 HeVAL(entry) = NULL;
3929 }
3930
3f4d1d78
FC		 3931HV *
3932newHVhv(HV *hv)
3933CODE:
3934 RETVAL = newHVhv(hv);
3935OUTPUT:
3936 RETVAL
3937
dd82de44 3938U32
fa819c1c
FC		 3939SvIsCOW(SV *sv)
3940CODE:
3941 RETVAL = SvIsCOW(sv);
3942OUTPUT:
3943 RETVAL
3944
15103811
Z		 3945void
3946pad_scalar(...)
3947PROTOTYPE: $$
3948CODE:
3949 PERL_UNUSED_VAR(items);
3950 croak("pad_scalar called as a function");
3951
3952BOOT:
3953{
3954 CV *pscv = get_cv("XS::APItest::pad_scalar", 0);
3955 cv_set_call_checker(pscv, THX_ck_entersub_pad_scalar, (SV*)pscv);
3956}
3957
ab8f91e9
BF		 3958SV*
3959fetch_pad_names( cv )
3960CV* cv
3961 PREINIT:
3962 I32 i;
35e035cc 3963 PADNAMELIST *pad_namelist;
ab8f91e9
BF		 3964 AV *retav = newAV();
3965 CODE:
86d2498c 3966 pad_namelist = PadlistNAMES(CvPADLIST(cv));
ab8f91e9 3967
86d2498c
FC		 3968 for ( i = PadnamelistMAX(pad_namelist); i >= 0; i-- ) {
3969 PADNAME* name = PadnamelistARRAY(pad_namelist)[i];
ab8f91e9 3970
325e1816 3971 if (PadnameLEN(name)) {
35e035cc 3972 av_push(retav, newSVpadname(name));
ab8f91e9
BF		 3973 }
3974 }
3975 RETVAL = newRV_noinc((SV*)retav);
3976 OUTPUT:
3977 RETVAL
3978
c12735bb
Z		 3979STRLEN
3980underscore_length()
3981PROTOTYPE:
3982PREINIT:
3983 SV *u;
3984 U8 *pv;
3985 STRLEN bytelen;
3986CODE:
3987 u = find_rundefsv();
3988 pv = (U8*)SvPV(u, bytelen);
3989 RETVAL = SvUTF8(u) ? utf8_length(pv, pv+bytelen) : bytelen;
3990OUTPUT:
3991 RETVAL
3992
e8ed61c5
FC		 3993void
3994stringify(SV *sv)
e8ed61c5 3995CODE:
5f74c55e 3996 (void)SvPV_nolen(sv);
e8ed61c5 3997
c682ebef
FC		 3998SV *
3999HvENAME(HV *hv)
4000CODE:
4001 RETVAL = hv && HvENAME(hv)
4002 ? newSVpvn_flags(
4003 HvENAME(hv),HvENAMELEN(hv),
4004 (HvENAMEUTF8(hv) ? SVf_UTF8 : 0)
4005 )
4006 : NULL;
4007OUTPUT:
4008 RETVAL
4009
2fc49ef1
FC		 4010int
4011xs_cmp(int a, int b)
4012CODE:
4013 /* Odd sorting (odd numbers first), to make sure we are actually
4014 being called */
4015 RETVAL = a % 2 != b % 2
4016 ? a % 2 ? -1 : 1
4017 : a < b ? -1 : a == b ? 0 : 1;
4018OUTPUT:
4019 RETVAL
4020
c19fd8b4
FC		 4021SV *
4022xs_cmp_undef(SV *a, SV *b)
4023CODE:
5f74c55e
DM		 4024 PERL_UNUSED_ARG(a);
4025 PERL_UNUSED_ARG(b);
c19fd8b4
FC		 4026 RETVAL = &PL_sv_undef;
4027OUTPUT:
4028 RETVAL
4029
fe46cbda
FC		 4030char *
4031SvPVbyte(SV *sv)
4032CODE:
4033 RETVAL = SvPVbyte_nolen(sv);
4034OUTPUT:
4035 RETVAL
4036
4037char *
4038SvPVutf8(SV *sv)
4039CODE:
4040 RETVAL = SvPVutf8_nolen(sv);
4041OUTPUT:
4042 RETVAL
4043
e8570548
Z		 4044void
4045setup_addissub()
4046CODE:
4047 wrap_op_checker(OP_ADD, addissub_myck_add, &addissub_nxck_add);
e8ed61c5 4048
39c012bc
FC		 4049void
4050setup_rv2cv_addunderbar()
4051CODE:
4052 wrap_op_checker(OP_RV2CV, my_ck_rv2cv, &old_ck_rv2cv);
4053
c0b8aebd
FC		 4054#ifdef USE_ITHREADS
4055
4056bool
4057test_alloccopstash()
4058CODE:
4059 RETVAL = PL_stashpad[alloccopstash(PL_defstash)] == PL_defstash;
4060OUTPUT:
4061 RETVAL
4062
4063#endif
4064
b448305b
FC		 4065bool
4066test_newFOROP_without_slab()
4067CODE:
4068 {
4069 const I32 floor = start_subparse(0,0);
3f25e47a 4070 OP *o;
b448305b
FC		 4071 /* The slab allocator does not like CvROOT being set. */
4072 CvROOT(PL_compcv) = (OP *)1;
3f25e47a
FC		 4073 o = newFOROP(0, 0, newOP(OP_PUSHMARK, 0), 0, 0);
4074#ifdef PERL_OP_PARENT
86cd3a13 4075 if (cLOOPx(cUNOPo->op_first)->op_last->op_sibparent
3f25e47a
FC		 4076 != cUNOPo->op_first)
4077 {
4078 Perl_warn(aTHX_ "Op parent pointer is stale");
4079 RETVAL = FALSE;
4080 }
4081 else
4082#endif
4083 /* If we do not crash before returning, the test passes. */
4084 RETVAL = TRUE;
4085 op_free(o);
b448305b
FC		 4086 CvROOT(PL_compcv) = NULL;
4087 SvREFCNT_dec(PL_compcv);
4088 LEAVE_SCOPE(floor);
b448305b
FC		 4089 }
4090OUTPUT:
4091 RETVAL
4092
7016d6eb
DM		 4093 # provide access to CALLREGEXEC, except replace pointers within the
4094 # string with offsets from the start of the string
4095
4096I32
4097callregexec(SV *prog, STRLEN stringarg, STRLEN strend, I32 minend, SV *sv, U32 nosave)
4098CODE:
4099 {
4100 STRLEN len;
4101 char *strbeg;
4102 if (SvROK(prog))
4103 prog = SvRV(prog);
4104 strbeg = SvPV_force(sv, len);
4105 RETVAL = CALLREGEXEC((REGEXP *)prog,
4106 strbeg + stringarg,
4107 strbeg + strend,
4108 strbeg,
4109 minend,
4110 sv,
4111 NULL, /* data */
4112 nosave);
4113 }
4114OUTPUT:
4115 RETVAL
4116
0be5d18d
FC		 4117void
4118lexical_import(SV *name, CV *cv)
4119 CODE:
4120 {
4121 PADLIST *pl;
4122 PADOFFSET off;
4123 if (!PL_compcv)
4124 Perl_croak(aTHX_
4125 "lexical_import can only be called at compile time");
4126 pl = CvPADLIST(PL_compcv);
4127 ENTER;
4128 SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(pl);
4129 SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(pl)[1];
4130 SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad);
147e3846 4131 off = pad_add_name_sv(sv_2mortal(newSVpvf("&%" SVf,name)),
1af585b3 4132 padadd_STATE, 0, 0);
0be5d18d
FC		 4133 SvREFCNT_dec(PL_curpad[off]);
4134 PL_curpad[off] = SvREFCNT_inc(cv);
59f30b2e 4135 intro_my();
0be5d18d
FC		 4136 LEAVE;
4137 }
4138
108cb980
FC		 4139SV *
4140sv_mortalcopy(SV *sv)
4141 CODE:
4142 RETVAL = SvREFCNT_inc(sv_mortalcopy(sv));
4143 OUTPUT:
4144 RETVAL
b448305b 4145
3455055f
FC		 4146SV *
4147newRV(SV *sv)
4148
031c6d82
FC		 4149void
4150alias_av(AV *av, IV ix, SV *sv)
4151 CODE:
4152 av_store(av, ix, SvREFCNT_inc(sv));
4153
b5e03f43
FC		 4154SV *
4155cv_name(SVREF ref, ...)
4156 CODE:
ecf05a58
FC		 4157 RETVAL = SvREFCNT_inc(cv_name((CV *)ref,
4158 items>1 && ST(1) != &PL_sv_undef
4159 ? ST(1)
4160 : NULL,
4161 items>2 ? SvUV(ST(2)) : 0));
b5e03f43
FC		 4162 OUTPUT:
4163 RETVAL
4164
20c88bf7
FC		 4165void
4166sv_catpvn(SV *sv, SV *sv2)
4167 CODE:
4168 {
4169 STRLEN len;
4170 const char *s = SvPV(sv2,len);
4171 sv_catpvn_flags(sv,s,len, SvUTF8(sv2) ? SV_CATUTF8 : SV_CATBYTES);
4172 }
4173
1daa0c57
FC		 4174bool
4175test_newOP_CUSTOM()
4176 CODE:
4177 {
4178 OP *o = newLISTOP(OP_CUSTOM, 0, NULL, NULL);
4179 op_free(o);
4180 o = newOP(OP_CUSTOM, 0);
4181 op_free(o);
4182 o = newUNOP(OP_CUSTOM, 0, NULL);
4183 op_free(o);
4184 o = newUNOP_AUX(OP_CUSTOM, 0, NULL, NULL);
4185 op_free(o);
4186 o = newMETHOP(OP_CUSTOM, 0, newOP(OP_NULL,0));
4187 op_free(o);
4188 o = newMETHOP_named(OP_CUSTOM, 0, newSV(0));
4189 op_free(o);
4190 o = newBINOP(OP_CUSTOM, 0, NULL, NULL);
4191 op_free(o);
4192 o = newPMOP(OP_CUSTOM, 0);
4193 op_free(o);
4194 o = newSVOP(OP_CUSTOM, 0, newSV(0));
4195 op_free(o);
4196#ifdef USE_ITHREADS
4197 ENTER;
4198 lex_start(NULL, NULL, 0);
4199 {
4200 I32 ix = start_subparse(FALSE,0);
4201 o = newPADOP(OP_CUSTOM, 0, newSV(0));
4202 op_free(o);
4203 LEAVE_SCOPE(ix);
4204 }
4205 LEAVE;
4206#endif
4207 o = newPVOP(OP_CUSTOM, 0, NULL);
4208 op_free(o);
4209 o = newLOGOP(OP_CUSTOM, 0, newOP(OP_NULL,0), newOP(OP_NULL,0));
4210 op_free(o);
4211 o = newLOOPEX(OP_CUSTOM, newOP(OP_NULL,0));
4212 op_free(o);
4213 RETVAL = TRUE;
4214 }
4215 OUTPUT:
4216 RETVAL
4217
46e58bd2
AC		 4218void
4219test_sv_catpvf(SV *fmtsv)
4220 PREINIT:
4221 SV *sv;
4222 char *fmt;
4223 CODE:
4224 fmt = SvPV_nolen(fmtsv);
4225 sv = sv_2mortal(newSVpvn("", 0));
4226 sv_catpvf(sv, fmt, 5, 6, 7, 8);
4227
a52f2cce
NC		 4228void
4229load_module(flags, name, ...)
4230 U32 flags
4231 SV *name
4232CODE:
4233 if (items == 2) {
4234 Perl_load_module(aTHX_ flags, SvREFCNT_inc(name), NULL);
4235 } else if (items == 3) {
4236 Perl_load_module(aTHX_ flags, SvREFCNT_inc(name), SvREFCNT_inc(ST(2)));
4237 } else
147e3846
KW		 4238 Perl_croak(aTHX_ "load_module can't yet support %" IVdf " items",
4239 (IV)items);
a52f2cce 4240
e426a4af
FC		 4241SV *
4242string_without_null(SV *sv)
4243 CODE:
4244 {
4245 STRLEN len;
4246 const char *s = SvPV(sv, len);
4247 RETVAL = newSVpvn_flags(s, len, SvUTF8(sv));
4248 *SvEND(RETVAL) = 0xff;
4249 }
4250 OUTPUT:
4251 RETVAL
4252
120b7a08
S		 4253MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
4254
4255int
4256AUTOLOAD(...)
4257 INIT:
4258 SV* comms;
120b7a08 4259 SV* class_and_method;
120b7a08 4260 CODE:
5f74c55e 4261 PERL_UNUSED_ARG(items);
bb619f37 4262 class_and_method = GvSV(CvGV(cv));
120b7a08
S		 4263 comms = get_sv("main::the_method", 1);
4264 if (class_and_method == NULL) {
4265 RETVAL = 1;
4266 } else if (!SvOK(class_and_method)) {
4267 RETVAL = 2;
4268 } else if (!SvPOK(class_and_method)) {
4269 RETVAL = 3;
4270 } else {
bb619f37 4271 sv_setsv(comms, class_and_method);
120b7a08
S		 4272 RETVAL = 0;
4273 }
4274 OUTPUT: RETVAL
4275
4276
26ab20ee
FR		 4277MODULE = XS::APItest PACKAGE = XS::APItest::Magic
4278
4279PROTOTYPES: DISABLE
4280
4281void
4282sv_magic_foo(SV *sv, SV *thingy)
4283ALIAS:
4284 sv_magic_bar = 1
4285CODE:
4286 sv_magicext(SvRV(sv), NULL, PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo, (const char *)thingy, 0);
4287
4288SV *
4289mg_find_foo(SV *sv)
4290ALIAS:
4291 mg_find_bar = 1
4292CODE:
4293 MAGIC *mg = mg_findext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
4294 RETVAL = mg ? SvREFCNT_inc((SV *)mg->mg_ptr) : &PL_sv_undef;
4295OUTPUT:
4296 RETVAL
4297
4298void
4299sv_unmagic_foo(SV *sv)
4300ALIAS:
4301 sv_unmagic_bar = 1
4302CODE:
4303 sv_unmagicext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
406700cc 4304
1d5686ec
FC		 4305void
4306sv_magic(SV *sv, SV *thingy)
4307CODE:
4308 sv_magic(SvRV(sv), NULL, PERL_MAGIC_ext, (const char *)thingy, 0);
4309
406700cc
NC		 4310UV
4311test_get_vtbl()
4312 PREINIT:
4313 MGVTBL *have;
4314 MGVTBL *want;
4315 CODE:
4316#define test_get_this_vtable(name) \
55cdf547 4317 want = (MGVTBL*)CAT2(&PL_vtbl_, name); \
406700cc
NC		 4318 have = get_vtbl(CAT2(want_vtbl_, name)); \
4319 if (have != want) \
4320 croak("fail %p!=%p for get_vtbl(want_vtbl_" STRINGIFY(name) ") at " __FILE__ " line %d", have, want, __LINE__)
4321
4322 test_get_this_vtable(sv);
4323 test_get_this_vtable(env);
4324 test_get_this_vtable(envelem);
4325 test_get_this_vtable(sigelem);
4326 test_get_this_vtable(pack);
4327 test_get_this_vtable(packelem);
4328 test_get_this_vtable(dbline);
4329 test_get_this_vtable(isa);
4330 test_get_this_vtable(isaelem);
4331 test_get_this_vtable(arylen);
4332 test_get_this_vtable(mglob);
4333 test_get_this_vtable(nkeys);
4334 test_get_this_vtable(taint);
4335 test_get_this_vtable(substr);
4336 test_get_this_vtable(vec);
4337 test_get_this_vtable(pos);
4338 test_get_this_vtable(bm);
4339 test_get_this_vtable(fm);
4340 test_get_this_vtable(uvar);
4341 test_get_this_vtable(defelem);
4342 test_get_this_vtable(regexp);
4343 test_get_this_vtable(regdata);
4344 test_get_this_vtable(regdatum);
4345#ifdef USE_LOCALE_COLLATE
4346 test_get_this_vtable(collxfrm);
4347#endif
406700cc
NC		 4348 test_get_this_vtable(backref);
4349 test_get_this_vtable(utf8);
4350
4351 RETVAL = PTR2UV(get_vtbl(-1));
4352 OUTPUT:
4353 RETVAL
bdd8600f 4354
80c1439f
DM		 4355
4356 # attach ext magic to the SV pointed to by rsv that only has set magic,
4357 # where that magic's job is to increment thingy
4358
4359void
4360sv_magic_myset(SV *rsv, SV *thingy)
4361CODE:
4362 sv_magicext(SvRV(rsv), NULL, PERL_MAGIC_ext, &vtbl_myset,
4363 (const char *)thingy, 0);
4364
4365
4366
bdd8600f
KW		 4367bool
4368test_isBLANK_uni(UV ord)
4369 CODE:
4370 RETVAL = isBLANK_uni(ord);
4371 OUTPUT:
4372 RETVAL
4373
4374bool
a7fe8528
KW		 4375test_isBLANK_uvchr(UV ord)
4376 CODE:
4377 RETVAL = isBLANK_uvchr(ord);
4378 OUTPUT:
4379 RETVAL
4380
4381bool
981746b9
KW		 4382test_isBLANK_LC_uvchr(UV ord)
4383 CODE:
4384 RETVAL = isBLANK_LC_uvchr(ord);
4385 OUTPUT:
4386 RETVAL
4387
4388bool
ee9e5f10
KW		 4389test_isBLANK(UV ord)
4390 CODE:
4391 RETVAL = isBLANK(ord);
4392 OUTPUT:
4393 RETVAL
4394
4395bool
c9c05358 4396test_isBLANK_A(UV ord)
bdd8600f 4397 CODE:
c9c05358
KW		 4398 RETVAL = isBLANK_A(ord);
4399 OUTPUT:
4400 RETVAL
4401
4402bool
4403test_isBLANK_L1(UV ord)
4404 CODE:
4405 RETVAL = isBLANK_L1(ord);
4406 OUTPUT:
4407 RETVAL
4408
4409bool
981746b9
KW		 4410test_isBLANK_LC(UV ord)
4411 CODE:
4412 RETVAL = isBLANK_LC(ord);
4413 OUTPUT:
4414 RETVAL
4415
4416bool
da8c1a98
KW		 4417test_isBLANK_utf8(unsigned char * p, int type)
4418 PREINIT:
4419 const unsigned char * e;
c9c05358 4420 CODE:
da8c1a98
KW		 4421
4422 /* In this function and those that follow, the boolean 'type'
4423 * indicates if to pass a malformed UTF-8 string to the tested macro
4424 * (malformed by making it too short) */
4425 if (type >= 0) {
4426 e = p + UTF8SKIP(p) - type;
4427 RETVAL = isBLANK_utf8_safe(p, e);
4428 }
4429 else {
4430 RETVAL = isBLANK_utf8(p);
4431 }
c9c05358
KW		 4432 OUTPUT:
4433 RETVAL
4434
4435bool
da8c1a98
KW		 4436test_isBLANK_LC_utf8(unsigned char * p, int type)
4437 PREINIT:
4438 const unsigned char * e;
981746b9 4439 CODE:
da8c1a98
KW		 4440 if (type >= 0) {
4441 e = p + UTF8SKIP(p) - type;
4442 RETVAL = isBLANK_LC_utf8_safe(p, e);
4443 }
4444 else {
4445 RETVAL = isBLANK_LC_utf8(p);
4446 }
981746b9
KW		 4447 OUTPUT:
4448 RETVAL
4449
4450bool
840f8e92
KW		 4451test_isVERTWS_uni(UV ord)
4452 CODE:
4453 RETVAL = isVERTWS_uni(ord);
4454 OUTPUT:
4455 RETVAL
4456
4457bool
a7fe8528
KW		 4458test_isVERTWS_uvchr(UV ord)
4459 CODE:
4460 RETVAL = isVERTWS_uvchr(ord);
4461 OUTPUT:
4462 RETVAL
4463
4464bool
da8c1a98
KW		 4465test_isVERTWS_utf8(unsigned char * p, int type)
4466 PREINIT:
4467 const unsigned char * e;
840f8e92 4468 CODE:
da8c1a98
KW		 4469 if (type >= 0) {
4470 e = p + UTF8SKIP(p) - type;
4471 RETVAL = isVERTWS_utf8_safe(p, e);
4472 }
4473 else {
4474 RETVAL = isVERTWS_utf8(p);
4475 }
840f8e92
KW		 4476 OUTPUT:
4477 RETVAL
4478
4479bool
c9c05358
KW		 4480test_isUPPER_uni(UV ord)
4481 CODE:
4482 RETVAL = isUPPER_uni(ord);
4483 OUTPUT:
4484 RETVAL
4485
4486bool
a7fe8528
KW		 4487test_isUPPER_uvchr(UV ord)
4488 CODE:
4489 RETVAL = isUPPER_uvchr(ord);
4490 OUTPUT:
4491 RETVAL
4492
4493bool
981746b9
KW		 4494test_isUPPER_LC_uvchr(UV ord)
4495 CODE:
4496 RETVAL = isUPPER_LC_uvchr(ord);
4497 OUTPUT:
4498 RETVAL
4499
4500bool
ee9e5f10
KW		 4501test_isUPPER(UV ord)
4502 CODE:
4503 RETVAL = isUPPER(ord);
4504 OUTPUT:
4505 RETVAL
4506
4507bool
c9c05358
KW		 4508test_isUPPER_A(UV ord)
4509 CODE:
4510 RETVAL = isUPPER_A(ord);
4511 OUTPUT:
4512 RETVAL
4513
4514bool
4515test_isUPPER_L1(UV ord)
4516 CODE:
4517 RETVAL = isUPPER_L1(ord);
4518 OUTPUT:
4519 RETVAL
4520
4521bool
981746b9
KW		 4522test_isUPPER_LC(UV ord)
4523 CODE:
4524 RETVAL = isUPPER_LC(ord);
4525 OUTPUT:
4526 RETVAL
4527
4528bool
da8c1a98
KW		 4529test_isUPPER_utf8(unsigned char * p, int type)
4530 PREINIT:
4531 const unsigned char * e;
c9c05358 4532 CODE:
da8c1a98
KW		 4533 if (type >= 0) {
4534 e = p + UTF8SKIP(p) - type;
4535 RETVAL = isUPPER_utf8_safe(p, e);
4536 }
4537 else {
4538 RETVAL = isUPPER_utf8(p);
4539 }
c9c05358
KW		 4540 OUTPUT:
4541 RETVAL
4542
4543bool
da8c1a98
KW		 4544test_isUPPER_LC_utf8(unsigned char * p, int type)
4545 PREINIT:
4546 const unsigned char * e;
981746b9 4547 CODE:
da8c1a98
KW		 4548 if (type >= 0) {
4549 e = p + UTF8SKIP(p) - type;
4550 RETVAL = isUPPER_LC_utf8_safe(p, e);
4551 }
4552 else {
4553 RETVAL = isUPPER_LC_utf8(p);
4554 }
981746b9
KW		 4555 OUTPUT:
4556 RETVAL
4557
4558bool
c9c05358
KW		 4559test_isLOWER_uni(UV ord)
4560 CODE:
4561 RETVAL = isLOWER_uni(ord);
4562 OUTPUT:
4563 RETVAL
4564
4565bool
a7fe8528
KW		 4566test_isLOWER_uvchr(UV ord)
4567 CODE:
4568 RETVAL = isLOWER_uvchr(ord);
4569 OUTPUT:
4570 RETVAL
4571
4572bool
981746b9
KW		 4573test_isLOWER_LC_uvchr(UV ord)
4574 CODE:
4575 RETVAL = isLOWER_LC_uvchr(ord);
4576 OUTPUT:
4577 RETVAL
4578
4579bool
ee9e5f10
KW		 4580test_isLOWER(UV ord)
4581 CODE:
4582 RETVAL = isLOWER(ord);
4583 OUTPUT:
4584 RETVAL
4585
4586bool
c9c05358
KW		 4587test_isLOWER_A(UV ord)
4588 CODE:
4589 RETVAL = isLOWER_A(ord);
4590 OUTPUT:
4591 RETVAL
4592
4593bool
4594test_isLOWER_L1(UV ord)
4595 CODE:
4596 RETVAL = isLOWER_L1(ord);
4597 OUTPUT:
4598 RETVAL
4599
4600bool
981746b9
KW		 4601test_isLOWER_LC(UV ord)
4602 CODE:
4603 RETVAL = isLOWER_LC(ord);
4604 OUTPUT:
4605 RETVAL
4606
4607bool
da8c1a98
KW		 4608test_isLOWER_utf8(unsigned char * p, int type)
4609 PREINIT:
4610 const unsigned char * e;
c9c05358 4611 CODE:
da8c1a98
KW		 4612 if (type >= 0) {
4613 e = p + UTF8SKIP(p) - type;
4614 RETVAL = isLOWER_utf8_safe(p, e);
4615 }
4616 else {
4617 RETVAL = isLOWER_utf8(p);
4618 }
c9c05358
KW		 4619 OUTPUT:
4620 RETVAL
4621
4622bool
da8c1a98
KW		 4623test_isLOWER_LC_utf8(unsigned char * p, int type)
4624 PREINIT:
4625 const unsigned char * e;
981746b9 4626 CODE:
da8c1a98
KW		 4627 if (type >= 0) {
4628 e = p + UTF8SKIP(p) - type;
4629 RETVAL = isLOWER_LC_utf8_safe(p, e);
4630 }
4631 else {
4632 RETVAL = isLOWER_LC_utf8(p);
4633 }
981746b9
KW		 4634 OUTPUT:
4635 RETVAL
4636
4637bool
c9c05358
KW		 4638test_isALPHA_uni(UV ord)
4639 CODE:
4640 RETVAL = isALPHA_uni(ord);
4641 OUTPUT:
4642 RETVAL
4643
4644bool
a7fe8528
KW		 4645test_isALPHA_uvchr(UV ord)
4646 CODE:
4647 RETVAL = isALPHA_uvchr(ord);
4648 OUTPUT:
4649 RETVAL
4650
4651bool
981746b9
KW		 4652test_isALPHA_LC_uvchr(UV ord)
4653 CODE:
4654 RETVAL = isALPHA_LC_uvchr(ord);
4655 OUTPUT:
4656 RETVAL
4657
4658bool
ee9e5f10
KW		 4659test_isALPHA(UV ord)
4660 CODE:
4661 RETVAL = isALPHA(ord);
4662 OUTPUT:
4663 RETVAL
4664
4665bool
c9c05358
KW		 4666test_isALPHA_A(UV ord)
4667 CODE:
4668 RETVAL = isALPHA_A(ord);
4669 OUTPUT:
4670 RETVAL
4671
4672bool
4673test_isALPHA_L1(UV ord)
4674 CODE:
4675 RETVAL = isALPHA_L1(ord);
4676 OUTPUT:
4677 RETVAL
4678
4679bool
981746b9
KW		 4680test_isALPHA_LC(UV ord)
4681 CODE:
4682 RETVAL = isALPHA_LC(ord);
4683 OUTPUT:
4684 RETVAL
4685
4686bool
da8c1a98
KW		 4687test_isALPHA_utf8(unsigned char * p, int type)
4688 PREINIT:
4689 const unsigned char * e;
c9c05358 4690 CODE:
da8c1a98
KW		 4691 if (type >= 0) {
4692 e = p + UTF8SKIP(p) - type;
4693 RETVAL = isALPHA_utf8_safe(p, e);
4694 }
4695 else {
4696 RETVAL = isALPHA_utf8(p);
4697 }
c9c05358
KW		 4698 OUTPUT:
4699 RETVAL
4700
4701bool
da8c1a98
KW		 4702test_isALPHA_LC_utf8(unsigned char * p, int type)
4703 PREINIT:
4704 const unsigned char * e;
c9c05358 4705 CODE:
da8c1a98
KW		 4706 if (type >= 0) {
4707 e = p + UTF8SKIP(p) - type;
4708 RETVAL = isALPHA_LC_utf8_safe(p, e);
4709 }
4710 else {
4711 RETVAL = isALPHA_LC_utf8(p);
4712 }
981746b9
KW		 4713 OUTPUT:
4714 RETVAL
4715
4716bool
4717test_isWORDCHAR_uni(UV ord)
4718 CODE:
4719 RETVAL = isWORDCHAR_uni(ord);
4720 OUTPUT:
4721 RETVAL
4722
4723bool
a7fe8528
KW		 4724test_isWORDCHAR_uvchr(UV ord)
4725 CODE:
4726 RETVAL = isWORDCHAR_uvchr(ord);
4727 OUTPUT:
4728 RETVAL
4729
4730bool
981746b9
KW		 4731test_isWORDCHAR_LC_uvchr(UV ord)
4732 CODE:
4733 RETVAL = isWORDCHAR_LC_uvchr(ord);
c9c05358
KW		 4734 OUTPUT:
4735 RETVAL
4736
4737bool
ee9e5f10
KW		 4738test_isWORDCHAR(UV ord)
4739 CODE:
4740 RETVAL = isWORDCHAR(ord);
4741 OUTPUT:
4742 RETVAL
4743
4744bool
981746b9 4745test_isWORDCHAR_A(UV ord)
c9c05358
KW		 4746 CODE:
4747 RETVAL = isWORDCHAR_A(ord);
4748 OUTPUT:
4749 RETVAL
4750
4751bool
981746b9 4752test_isWORDCHAR_L1(UV ord)
c9c05358
KW		 4753 CODE:
4754 RETVAL = isWORDCHAR_L1(ord);
4755 OUTPUT:
4756 RETVAL
4757
4758bool
981746b9
KW		 4759test_isWORDCHAR_LC(UV ord)
4760 CODE:
4761 RETVAL = isWORDCHAR_LC(ord);
4762 OUTPUT:
4763 RETVAL
4764
4765bool
da8c1a98
KW		 4766test_isWORDCHAR_utf8(unsigned char * p, int type)
4767 PREINIT:
4768 const unsigned char * e;
981746b9 4769 CODE:
da8c1a98
KW		 4770 if (type >= 0) {
4771 e = p + UTF8SKIP(p) - type;
4772 RETVAL = isWORDCHAR_utf8_safe(p, e);
4773 }
4774 else {
4775 RETVAL = isWORDCHAR_utf8(p);
4776 }
981746b9
KW		 4777 OUTPUT:
4778 RETVAL
4779
4780bool
da8c1a98
KW		 4781test_isWORDCHAR_LC_utf8(unsigned char * p, int type)
4782 PREINIT:
4783 const unsigned char * e;
981746b9 4784 CODE:
da8c1a98
KW		 4785 if (type >= 0) {
4786 e = p + UTF8SKIP(p) - type;
4787 RETVAL = isWORDCHAR_LC_utf8_safe(p, e);
4788 }
4789 else {
4790 RETVAL = isWORDCHAR_LC_utf8(p);
4791 }
981746b9
KW		 4792 OUTPUT:
4793 RETVAL
4794
4795bool
15861f94 4796test_isALPHANUMERIC_uni(UV ord)
981746b9 4797 CODE:
15861f94 4798 RETVAL = isALPHANUMERIC_uni(ord);
981746b9
KW		 4799 OUTPUT:
4800 RETVAL
4801
4802bool
a7fe8528
KW		 4803test_isALPHANUMERIC_uvchr(UV ord)
4804 CODE:
4805 RETVAL = isALPHANUMERIC_uvchr(ord);
4806 OUTPUT:
4807 RETVAL
4808
4809bool
15861f94 4810test_isALPHANUMERIC_LC_uvchr(UV ord)
981746b9 4811 CODE:
15861f94 4812 RETVAL = isALPHANUMERIC_LC_uvchr(ord);
981746b9
KW		 4813 OUTPUT:
4814 RETVAL
4815
4816bool
ee9e5f10
KW		 4817test_isALPHANUMERIC(UV ord)
4818 CODE:
4819 RETVAL = isALPHANUMERIC(ord);
4820 OUTPUT:
4821 RETVAL
4822
4823bool
15861f94 4824test_isALPHANUMERIC_A(UV ord)
981746b9 4825 CODE:
15861f94 4826 RETVAL = isALPHANUMERIC_A(ord);
981746b9
KW		 4827 OUTPUT:
4828 RETVAL
4829
4830bool
15861f94 4831test_isALPHANUMERIC_L1(UV ord)
981746b9 4832 CODE:
15861f94 4833 RETVAL = isALPHANUMERIC_L1(ord);
981746b9
KW		 4834 OUTPUT:
4835 RETVAL
4836
4837bool
15861f94 4838test_isALPHANUMERIC_LC(UV ord)
981746b9 4839 CODE:
15861f94 4840 RETVAL = isALPHANUMERIC_LC(ord);
981746b9
KW		 4841 OUTPUT:
4842 RETVAL
4843
4844bool
da8c1a98
KW		 4845test_isALPHANUMERIC_utf8(unsigned char * p, int type)
4846 PREINIT:
4847 const unsigned char * e;
981746b9 4848 CODE:
da8c1a98
KW		 4849 if (type >= 0) {
4850 e = p + UTF8SKIP(p) - type;
4851 RETVAL = isALPHANUMERIC_utf8_safe(p, e);
4852 }
4853 else {
4854 RETVAL = isALPHANUMERIC_utf8(p);
4855 }
981746b9
KW		 4856 OUTPUT:
4857 RETVAL
4858
4859bool
da8c1a98
KW		 4860test_isALPHANUMERIC_LC_utf8(unsigned char * p, int type)
4861 PREINIT:
4862 const unsigned char * e;
981746b9 4863 CODE:
da8c1a98
KW		 4864 if (type >= 0) {
4865 e = p + UTF8SKIP(p) - type;
4866 RETVAL = isALPHANUMERIC_LC_utf8_safe(p, e);
4867 }
4868 else {
4869 RETVAL = isALPHANUMERIC_LC_utf8(p);
4870 }
981746b9
KW		 4871 OUTPUT:
4872 RETVAL
4873
4874bool
ee9e5f10
KW		 4875test_isALNUM(UV ord)
4876 CODE:
4877 RETVAL = isALNUM(ord);
4878 OUTPUT:
4879 RETVAL
4880
4881bool
981746b9
KW		 4882test_isALNUM_uni(UV ord)
4883 CODE:
4884 RETVAL = isALNUM_uni(ord);
4885 OUTPUT:
4886 RETVAL
4887
4888bool
4889test_isALNUM_LC_uvchr(UV ord)
4890 CODE:
4891 RETVAL = isALNUM_LC_uvchr(ord);
4892 OUTPUT:
4893 RETVAL
4894
4895bool
4896test_isALNUM_LC(UV ord)
4897 CODE:
4898 RETVAL = isALNUM_LC(ord);
4899 OUTPUT:
4900 RETVAL
4901
4902bool
da8c1a98
KW		 4903test_isALNUM_utf8(unsigned char * p, int type)
4904 PREINIT:
4905 const unsigned char * e;
c9c05358 4906 CODE:
da8c1a98
KW		 4907 if (type >= 0) {
4908 e = p + UTF8SKIP(p) - type;
4909 RETVAL = isWORDCHAR_utf8_safe(p, e);
4910 }
4911 else {
4912 RETVAL = isWORDCHAR_utf8(p);
4913 }
c9c05358
KW		 4914 OUTPUT:
4915 RETVAL
4916
4917bool
da8c1a98
KW		 4918test_isALNUM_LC_utf8(unsigned char * p, int type)
4919 PREINIT:
4920 const unsigned char * e;
981746b9 4921 CODE:
da8c1a98
KW		 4922 if (type >= 0) {
4923 e = p + UTF8SKIP(p) - type;
4924 RETVAL = isWORDCHAR_LC_utf8_safe(p, e);
4925 }
4926 else {
4927 RETVAL = isWORDCHAR_LC_utf8(p);
4928 }
981746b9
KW		 4929 OUTPUT:
4930 RETVAL
4931
4932bool
c9c05358
KW		 4933test_isDIGIT_uni(UV ord)
4934 CODE:
4935 RETVAL = isDIGIT_uni(ord);
4936 OUTPUT:
4937 RETVAL
4938
4939bool
a7fe8528
KW		 4940test_isDIGIT_uvchr(UV ord)
4941 CODE:
4942 RETVAL = isDIGIT_uvchr(ord);
4943 OUTPUT:
4944 RETVAL
4945
4946bool
981746b9
KW		 4947test_isDIGIT_LC_uvchr(UV ord)
4948 CODE:
4949 RETVAL = isDIGIT_LC_uvchr(ord);
4950 OUTPUT:
4951 RETVAL
4952
4953bool
da8c1a98
KW		 4954test_isDIGIT_utf8(unsigned char * p, int type)
4955 PREINIT:
4956 const unsigned char * e;
c9c05358 4957 CODE:
da8c1a98
KW		 4958 if (type >= 0) {
4959 e = p + UTF8SKIP(p) - type;
4960 RETVAL = isDIGIT_utf8_safe(p, e);
4961 }
4962 else {
4963 RETVAL = isDIGIT_utf8(p);
4964 }
c9c05358
KW		 4965 OUTPUT:
4966 RETVAL
4967
4968bool
da8c1a98
KW		 4969test_isDIGIT_LC_utf8(unsigned char * p, int type)
4970 PREINIT:
4971 const unsigned char * e;
981746b9 4972 CODE:
da8c1a98
KW		 4973 if (type >= 0) {
4974 e = p + UTF8SKIP(p) - type;
4975 RETVAL = isDIGIT_LC_utf8_safe(p, e);
4976 }
4977 else {
4978 RETVAL = isDIGIT_LC_utf8(p);
4979 }
981746b9
KW		 4980 OUTPUT:
4981 RETVAL
4982
4983bool
ee9e5f10
KW		 4984test_isDIGIT(UV ord)
4985 CODE:
4986 RETVAL = isDIGIT(ord);
4987 OUTPUT:
4988 RETVAL
4989
4990bool
c9c05358
KW		 4991test_isDIGIT_A(UV ord)
4992 CODE:
4993 RETVAL = isDIGIT_A(ord);
4994 OUTPUT:
4995 RETVAL
4996
4997bool
4998test_isDIGIT_L1(UV ord)
4999 CODE:
5000 RETVAL = isDIGIT_L1(ord);
5001 OUTPUT:
5002 RETVAL
5003
5004bool
981746b9
KW		 5005test_isDIGIT_LC(UV ord)
5006 CODE:
5007 RETVAL = isDIGIT_LC(ord);
5008 OUTPUT:
5009 RETVAL
5010
5011bool
ee9e5f10
KW		 5012test_isOCTAL(UV ord)
5013 CODE:
5014 RETVAL = isOCTAL(ord);
5015 OUTPUT:
5016 RETVAL
5017
5018bool
8c67216a
KW		 5019test_isOCTAL_A(UV ord)
5020 CODE:
5021 RETVAL = isOCTAL_A(ord);
5022 OUTPUT:
5023 RETVAL
5024
5025bool
5026test_isOCTAL_L1(UV ord)
5027 CODE:
5028 RETVAL = isOCTAL_L1(ord);
5029 OUTPUT:
5030 RETVAL
5031
5032bool
c9c05358
KW		 5033test_isIDFIRST_uni(UV ord)
5034 CODE:
5035 RETVAL = isIDFIRST_uni(ord);
5036 OUTPUT:
5037 RETVAL
5038
5039bool
a7fe8528
KW		 5040test_isIDFIRST_uvchr(UV ord)
5041 CODE:
5042 RETVAL = isIDFIRST_uvchr(ord);
5043 OUTPUT:
5044 RETVAL
5045
5046bool
981746b9
KW		 5047test_isIDFIRST_LC_uvchr(UV ord)
5048 CODE:
5049 RETVAL = isIDFIRST_LC_uvchr(ord);
5050 OUTPUT:
5051 RETVAL
5052
5053bool
ee9e5f10
KW		 5054test_isIDFIRST(UV ord)
5055 CODE:
5056 RETVAL = isIDFIRST(ord);
5057 OUTPUT:
5058 RETVAL
5059
5060bool
c9c05358
KW		 5061test_isIDFIRST_A(UV ord)
5062 CODE:
5063 RETVAL = isIDFIRST_A(ord);
5064 OUTPUT:
5065 RETVAL
5066
5067bool
5068test_isIDFIRST_L1(UV ord)
5069 CODE:
5070 RETVAL = isIDFIRST_L1(ord);
5071 OUTPUT:
5072 RETVAL
5073
5074bool
981746b9
KW		 5075test_isIDFIRST_LC(UV ord)
5076 CODE:
5077 RETVAL = isIDFIRST_LC(ord);
5078 OUTPUT:
5079 RETVAL
5080
5081bool
da8c1a98
KW		 5082test_isIDFIRST_utf8(unsigned char * p, int type)
5083 PREINIT:
5084 const unsigned char * e;
c9c05358 5085 CODE:
da8c1a98
KW		 5086 if (type >= 0) {
5087 e = p + UTF8SKIP(p) - type;
5088 RETVAL = isIDFIRST_utf8_safe(p, e);
5089 }
5090 else {
5091 RETVAL = isIDFIRST_utf8(p);
5092 }
c9c05358
KW		 5093 OUTPUT:
5094 RETVAL
5095
5096bool
da8c1a98
KW		 5097test_isIDFIRST_LC_utf8(unsigned char * p, int type)
5098 PREINIT:
5099 const unsigned char * e;
981746b9 5100 CODE:
da8c1a98
KW		 5101 if (type >= 0) {
5102 e = p + UTF8SKIP(p) - type;
5103 RETVAL = isIDFIRST_LC_utf8_safe(p, e);
5104 }
5105 else {
5106 RETVAL = isIDFIRST_LC_utf8(p);
5107 }
981746b9
KW		 5108 OUTPUT:
5109 RETVAL
5110
5111bool
eba68aa0
KW		 5112test_isIDCONT_uni(UV ord)
5113 CODE:
5114 RETVAL = isIDCONT_uni(ord);
5115 OUTPUT:
5116 RETVAL
5117
5118bool
a7fe8528
KW		 5119test_isIDCONT_uvchr(UV ord)
5120 CODE:
5121 RETVAL = isIDCONT_uvchr(ord);
5122 OUTPUT:
5123 RETVAL
5124
5125bool
eba68aa0
KW		 5126test_isIDCONT_LC_uvchr(UV ord)
5127 CODE:
5128 RETVAL = isIDCONT_LC_uvchr(ord);
5129 OUTPUT:
5130 RETVAL
5131
5132bool
ee9e5f10
KW		 5133test_isIDCONT(UV ord)
5134 CODE:
5135 RETVAL = isIDCONT(ord);
5136 OUTPUT:
5137 RETVAL
5138
5139bool
eba68aa0
KW		 5140test_isIDCONT_A(UV ord)
5141 CODE:
5142 RETVAL = isIDCONT_A(ord);
5143 OUTPUT:
5144 RETVAL
5145
5146bool
5147test_isIDCONT_L1(UV ord)
5148 CODE:
5149 RETVAL = isIDCONT_L1(ord);
5150 OUTPUT:
5151 RETVAL
5152
5153bool
5154test_isIDCONT_LC(UV ord)
5155 CODE:
5156 RETVAL = isIDCONT_LC(ord);
5157 OUTPUT:
5158 RETVAL
5159
5160bool
da8c1a98
KW		 5161test_isIDCONT_utf8(unsigned char * p, int type)
5162 PREINIT:
5163 const unsigned char * e;
eba68aa0 5164 CODE:
da8c1a98
KW		 5165 if (type >= 0) {
5166 e = p + UTF8SKIP(p) - type;
5167 RETVAL = isIDCONT_utf8_safe(p, e);
5168 }
5169 else {
5170 RETVAL = isIDCONT_utf8(p);
5171 }
eba68aa0
KW		 5172 OUTPUT:
5173 RETVAL
5174
5175bool
da8c1a98
KW		 5176test_isIDCONT_LC_utf8(unsigned char * p, int type)
5177 PREINIT:
5178 const unsigned char * e;
eba68aa0 5179 CODE:
da8c1a98
KW		 5180 if (type >= 0) {
5181 e = p + UTF8SKIP(p) - type;
5182 RETVAL = isIDCONT_LC_utf8_safe(p, e);
5183 }
5184 else {
5185 RETVAL = isIDCONT_LC_utf8(p);
5186 }
eba68aa0
KW		 5187 OUTPUT:
5188 RETVAL
5189
5190bool
c9c05358
KW		 5191test_isSPACE_uni(UV ord)
5192 CODE:
5193 RETVAL = isSPACE_uni(ord);
5194 OUTPUT:
5195 RETVAL
5196
5197bool
a7fe8528
KW		 5198test_isSPACE_uvchr(UV ord)
5199 CODE:
5200 RETVAL = isSPACE_uvchr(ord);
5201 OUTPUT:
5202 RETVAL
5203
5204bool
981746b9
KW		 5205test_isSPACE_LC_uvchr(UV ord)
5206 CODE:
5207 RETVAL = isSPACE_LC_uvchr(ord);
5208 OUTPUT:
5209 RETVAL
5210
5211bool
ee9e5f10
KW		 5212test_isSPACE(UV ord)
5213 CODE:
5214 RETVAL = isSPACE(ord);
5215 OUTPUT:
5216 RETVAL
5217
5218bool
c9c05358
KW		 5219test_isSPACE_A(UV ord)
5220 CODE:
5221 RETVAL = isSPACE_A(ord);
5222 OUTPUT:
5223 RETVAL
5224
5225bool
5226test_isSPACE_L1(UV ord)
5227 CODE:
5228 RETVAL = isSPACE_L1(ord);
5229 OUTPUT:
5230 RETVAL
5231
5232bool
981746b9
KW		 5233test_isSPACE_LC(UV ord)
5234 CODE:
5235 RETVAL = isSPACE_LC(ord);
5236 OUTPUT:
5237 RETVAL
5238
5239bool
da8c1a98
KW		 5240test_isSPACE_utf8(unsigned char * p, int type)
5241 PREINIT:
5242 const unsigned char * e;
c9c05358 5243 CODE:
da8c1a98
KW		 5244 if (type >= 0) {
5245 e = p + UTF8SKIP(p) - type;
5246 RETVAL = isSPACE_utf8_safe(p, e);
5247 }
5248 else {
5249 RETVAL = isSPACE_utf8(p);
5250 }
c9c05358
KW		 5251 OUTPUT:
5252 RETVAL
5253
5254bool
da8c1a98
KW		 5255test_isSPACE_LC_utf8(unsigned char * p, int type)
5256 PREINIT:
5257 const unsigned char * e;
981746b9 5258 CODE:
da8c1a98
KW		 5259 if (type >= 0) {
5260 e = p + UTF8SKIP(p) - type;
5261 RETVAL = isSPACE_LC_utf8_safe(p, e);
5262 }
5263 else {
5264 RETVAL = isSPACE_LC_utf8(p);
5265 }
981746b9
KW		 5266 OUTPUT:
5267 RETVAL
5268
5269bool
c9c05358
KW		 5270test_isASCII_uni(UV ord)
5271 CODE:
5272 RETVAL = isASCII_uni(ord);
5273 OUTPUT:
5274 RETVAL
5275
5276bool
a7fe8528
KW		 5277test_isASCII_uvchr(UV ord)
5278 CODE:
5279 RETVAL = isASCII_uvchr(ord);
5280 OUTPUT:
5281 RETVAL
5282
5283bool
981746b9
KW		 5284test_isASCII_LC_uvchr(UV ord)
5285 CODE:
5286 RETVAL = isASCII_LC_uvchr(ord);
5287 OUTPUT:
5288 RETVAL
5289
5290bool
ee9e5f10
KW		 5291test_isASCII(UV ord)
5292 CODE:
5293 RETVAL = isASCII(ord);
5294 OUTPUT:
5295 RETVAL
5296
5297bool
c9c05358
KW		 5298test_isASCII_A(UV ord)
5299 CODE:
5300 RETVAL = isASCII_A(ord);
5301 OUTPUT:
5302 RETVAL
5303
5304bool
5305test_isASCII_L1(UV ord)
5306 CODE:
5307 RETVAL = isASCII_L1(ord);
5308 OUTPUT:
5309 RETVAL
5310
5311bool
981746b9
KW		 5312test_isASCII_LC(UV ord)
5313 CODE:
5314 RETVAL = isASCII_LC(ord);
5315 OUTPUT:
5316 RETVAL
5317
5318bool
da8c1a98
KW		 5319test_isASCII_utf8(unsigned char * p, int type)
5320 PREINIT:
5321 const unsigned char * e;
c9c05358 5322 CODE:
b3611286
KW		 5323#ifndef DEBUGGING
5324 PERL_UNUSED_VAR(e);
5325#endif
da8c1a98
KW		 5326 if (type >= 0) {
5327 e = p + UTF8SKIP(p) - type;
5328 RETVAL = isASCII_utf8_safe(p, e);
5329 }
5330 else {
5331 RETVAL = isASCII_utf8(p);
5332 }
c9c05358
KW		 5333 OUTPUT:
5334 RETVAL
5335
5336bool
da8c1a98
KW		 5337test_isASCII_LC_utf8(unsigned char * p, int type)
5338 PREINIT:
5339 const unsigned char * e;
981746b9 5340 CODE:
b3611286
KW		 5341#ifndef DEBUGGING
5342 PERL_UNUSED_VAR(e);
5343#endif
da8c1a98
KW		 5344 if (type >= 0) {
5345 e = p + UTF8SKIP(p) - type;
5346 RETVAL = isASCII_LC_utf8_safe(p, e);
5347 }
5348 else {
5349 RETVAL = isASCII_LC_utf8(p);
5350 }
981746b9
KW		 5351 OUTPUT:
5352 RETVAL
5353
5354bool
c9c05358
KW		 5355test_isCNTRL_uni(UV ord)
5356 CODE:
5357 RETVAL = isCNTRL_uni(ord);
5358 OUTPUT:
5359 RETVAL
5360
5361bool
a7fe8528
KW		 5362test_isCNTRL_uvchr(UV ord)
5363 CODE:
5364 RETVAL = isCNTRL_uvchr(ord);
5365 OUTPUT:
5366 RETVAL
5367
5368bool
981746b9
KW		 5369test_isCNTRL_LC_uvchr(UV ord)
5370 CODE:
5371 RETVAL = isCNTRL_LC_uvchr(ord);
5372 OUTPUT:
5373 RETVAL
5374
5375bool
ee9e5f10
KW		 5376test_isCNTRL(UV ord)
5377 CODE:
5378 RETVAL = isCNTRL(ord);
5379 OUTPUT:
5380 RETVAL
5381
5382bool
c9c05358
KW		 5383test_isCNTRL_A(UV ord)
5384 CODE:
5385 RETVAL = isCNTRL_A(ord);
5386 OUTPUT:
5387 RETVAL
5388
5389bool
5390test_isCNTRL_L1(UV ord)
5391 CODE:
5392 RETVAL = isCNTRL_L1(ord);
5393 OUTPUT:
5394 RETVAL
5395
5396bool
981746b9
KW		 5397test_isCNTRL_LC(UV ord)
5398 CODE:
5399 RETVAL = isCNTRL_LC(ord);
5400 OUTPUT:
5401 RETVAL
5402
5403bool
da8c1a98
KW		 5404test_isCNTRL_utf8(unsigned char * p, int type)
5405 PREINIT:
5406 const unsigned char * e;
c9c05358 5407 CODE:
da8c1a98
KW		 5408 if (type >= 0) {
5409 e = p + UTF8SKIP(p) - type;
5410 RETVAL = isCNTRL_utf8_safe(p, e);
5411 }
5412 else {
5413 RETVAL = isCNTRL_utf8(p);
5414 }
c9c05358
KW		 5415 OUTPUT:
5416 RETVAL
5417
5418bool
da8c1a98
KW		 5419test_isCNTRL_LC_utf8(unsigned char * p, int type)
5420 PREINIT:
5421 const unsigned char * e;
981746b9 5422 CODE:
da8c1a98
KW		 5423 if (type >= 0) {
5424 e = p + UTF8SKIP(p) - type;
5425 RETVAL = isCNTRL_LC_utf8_safe(p, e);
5426 }
5427 else {
5428 RETVAL = isCNTRL_LC_utf8(p);
5429 }
981746b9
KW		 5430 OUTPUT:
5431 RETVAL
5432
5433bool
c9c05358
KW		 5434test_isPRINT_uni(UV ord)
5435 CODE:
5436 RETVAL = isPRINT_uni(ord);
5437 OUTPUT:
5438 RETVAL
5439
5440bool
a7fe8528
KW		 5441test_isPRINT_uvchr(UV ord)
5442 CODE:
5443 RETVAL = isPRINT_uvchr(ord);
5444 OUTPUT:
5445 RETVAL
5446
5447bool
981746b9
KW		 5448test_isPRINT_LC_uvchr(UV ord)
5449 CODE:
5450 RETVAL = isPRINT_LC_uvchr(ord);
5451 OUTPUT:
5452 RETVAL
5453
5454bool
ee9e5f10
KW		 5455test_isPRINT(UV ord)
5456 CODE:
5457 RETVAL = isPRINT(ord);
5458 OUTPUT:
5459 RETVAL
5460
5461bool
c9c05358
KW		 5462test_isPRINT_A(UV ord)
5463 CODE:
5464 RETVAL = isPRINT_A(ord);
5465 OUTPUT:
5466 RETVAL
5467
5468bool
5469test_isPRINT_L1(UV ord)
5470 CODE:
5471 RETVAL = isPRINT_L1(ord);
5472 OUTPUT:
5473 RETVAL
5474
5475bool
981746b9
KW		 5476test_isPRINT_LC(UV ord)
5477 CODE:
5478 RETVAL = isPRINT_LC(ord);
5479 OUTPUT:
5480 RETVAL
5481
5482bool
da8c1a98
KW		 5483test_isPRINT_utf8(unsigned char * p, int type)
5484 PREINIT:
5485 const unsigned char * e;
c9c05358 5486 CODE:
da8c1a98
KW		 5487 if (type >= 0) {
5488 e = p + UTF8SKIP(p) - type;
5489 RETVAL = isPRINT_utf8_safe(p, e);
5490 }
5491 else {
5492 RETVAL = isPRINT_utf8(p);
5493 }
c9c05358
KW		 5494 OUTPUT:
5495 RETVAL
5496
5497bool
da8c1a98
KW		 5498test_isPRINT_LC_utf8(unsigned char * p, int type)
5499 PREINIT:
5500 const unsigned char * e;
981746b9 5501 CODE:
da8c1a98
KW		 5502 if (type >= 0) {
5503 e = p + UTF8SKIP(p) - type;
5504 RETVAL = isPRINT_LC_utf8_safe(p, e);
5505 }
5506 else {
5507 RETVAL = isPRINT_LC_utf8(p);
5508 }
981746b9
KW		 5509 OUTPUT:
5510 RETVAL
5511
5512bool
c9c05358
KW		 5513test_isGRAPH_uni(UV ord)
5514 CODE:
5515 RETVAL = isGRAPH_uni(ord);
5516 OUTPUT:
5517 RETVAL
5518
5519bool
a7fe8528
KW		 5520test_isGRAPH_uvchr(UV ord)
5521 CODE:
5522 RETVAL = isGRAPH_uvchr(ord);
5523 OUTPUT:
5524 RETVAL
5525
5526bool
981746b9
KW		 5527test_isGRAPH_LC_uvchr(UV ord)
5528 CODE:
5529 RETVAL = isGRAPH_LC_uvchr(ord);
5530 OUTPUT:
5531 RETVAL
5532
5533bool
ee9e5f10
KW		 5534test_isGRAPH(UV ord)
5535 CODE:
5536 RETVAL = isGRAPH(ord);
5537 OUTPUT:
5538 RETVAL
5539
5540bool
c9c05358
KW		 5541test_isGRAPH_A(UV ord)
5542 CODE:
5543 RETVAL = isGRAPH_A(ord);
5544 OUTPUT:
5545 RETVAL
5546
5547bool
5548test_isGRAPH_L1(UV ord)
5549 CODE:
5550 RETVAL = isGRAPH_L1(ord);
5551 OUTPUT:
5552 RETVAL
5553
5554bool
981746b9 5555test_isGRAPH_LC(UV ord)
c9c05358 5556 CODE:
981746b9 5557 RETVAL = isGRAPH_LC(ord);
c9c05358
KW		 5558 OUTPUT:
5559 RETVAL
5560
5561bool
da8c1a98
KW		 5562test_isGRAPH_utf8(unsigned char * p, int type)
5563 PREINIT:
5564 const unsigned char * e;
c9c05358 5565 CODE:
da8c1a98
KW		 5566 if (type >= 0) {
5567 e = p + UTF8SKIP(p) - type;
5568 RETVAL = isGRAPH_utf8_safe(p, e);
5569 }
5570 else {
5571 RETVAL = isGRAPH_utf8(p);
5572 }
c9c05358
KW		 5573 OUTPUT:
5574 RETVAL
5575
5576bool
da8c1a98
KW		 5577test_isGRAPH_LC_utf8(unsigned char * p, int type)
5578 PREINIT:
5579 const unsigned char * e;
c9c05358 5580 CODE:
da8c1a98
KW		 5581 if (type >= 0) {
5582 e = p + UTF8SKIP(p) - type;
5583 RETVAL = isGRAPH_LC_utf8_safe(p, e);
5584 }
5585 else {
5586 RETVAL = isGRAPH_LC_utf8(p);
5587 }
c9c05358
KW		 5588 OUTPUT:
5589 RETVAL
5590
5591bool
5592test_isPUNCT_uni(UV ord)
5593 CODE:
5594 RETVAL = isPUNCT_uni(ord);
5595 OUTPUT:
5596 RETVAL
5597
5598bool
a7fe8528
KW		 5599test_isPUNCT_uvchr(UV ord)
5600 CODE:
5601 RETVAL = isPUNCT_uvchr(ord);
5602 OUTPUT:
5603 RETVAL
5604
5605bool
981746b9
KW		 5606test_isPUNCT_LC_uvchr(UV ord)
5607 CODE:
5608 RETVAL = isPUNCT_LC_uvchr(ord);
5609 OUTPUT:
5610 RETVAL
5611
5612bool
ee9e5f10
KW		 5613test_isPUNCT(UV ord)
5614 CODE:
5615 RETVAL = isPUNCT(ord);
5616 OUTPUT:
5617 RETVAL
5618
5619bool
c9c05358
KW		 5620test_isPUNCT_A(UV ord)
5621 CODE:
5622 RETVAL = isPUNCT_A(ord);
5623 OUTPUT:
5624 RETVAL
5625
5626bool
5627test_isPUNCT_L1(UV ord)
5628 CODE:
5629 RETVAL = isPUNCT_L1(ord);
5630 OUTPUT:
5631 RETVAL
5632
5633bool
981746b9
KW		 5634test_isPUNCT_LC(UV ord)
5635 CODE:
5636 RETVAL = isPUNCT_LC(ord);
5637 OUTPUT:
5638 RETVAL
5639
5640bool
da8c1a98
KW		 5641test_isPUNCT_utf8(unsigned char * p, int type)
5642 PREINIT:
5643 const unsigned char * e;
c9c05358 5644 CODE:
da8c1a98
KW		 5645 if (type >= 0) {
5646 e = p + UTF8SKIP(p) - type;
5647 RETVAL = isPUNCT_utf8_safe(p, e);
5648 }
5649 else {
5650 RETVAL = isPUNCT_utf8(p);
5651 }
c9c05358
KW		 5652 OUTPUT:
5653 RETVAL
5654
5655bool
da8c1a98
KW		 5656test_isPUNCT_LC_utf8(unsigned char * p, int type)
5657 PREINIT:
5658 const unsigned char * e;
981746b9 5659 CODE:
da8c1a98
KW		 5660 if (type >= 0) {
5661 e = p + UTF8SKIP(p) - type;
5662 RETVAL = isPUNCT_LC_utf8_safe(p, e);
5663 }
5664 else {
5665 RETVAL = isPUNCT_LC_utf8(p);
5666 }
981746b9
KW		 5667 OUTPUT:
5668 RETVAL
5669
5670bool
c9c05358
KW		 5671test_isXDIGIT_uni(UV ord)
5672 CODE:
5673 RETVAL = isXDIGIT_uni(ord);
5674 OUTPUT:
5675 RETVAL
5676
5677bool
a7fe8528
KW		 5678test_isXDIGIT_uvchr(UV ord)
5679 CODE:
5680 RETVAL = isXDIGIT_uvchr(ord);
5681 OUTPUT:
5682 RETVAL
5683
5684bool
981746b9
KW		 5685test_isXDIGIT_LC_uvchr(UV ord)
5686 CODE:
5687 RETVAL = isXDIGIT_LC_uvchr(ord);
5688 OUTPUT:
5689 RETVAL
5690
5691bool
ee9e5f10
KW		 5692test_isXDIGIT(UV ord)
5693 CODE:
5694 RETVAL = isXDIGIT(ord);
5695 OUTPUT:
5696 RETVAL
5697
5698bool
c9c05358
KW		 5699test_isXDIGIT_A(UV ord)
5700 CODE:
5701 RETVAL = isXDIGIT_A(ord);
5702 OUTPUT:
5703 RETVAL
5704
5705bool
5706test_isXDIGIT_L1(UV ord)
5707 CODE:
5708 RETVAL = isXDIGIT_L1(ord);
5709 OUTPUT:
5710 RETVAL
5711
5712bool
981746b9
KW		 5713test_isXDIGIT_LC(UV ord)
5714 CODE:
5715 RETVAL = isXDIGIT_LC(ord);
5716 OUTPUT:
5717 RETVAL
5718
5719bool
da8c1a98
KW		 5720test_isXDIGIT_utf8(unsigned char * p, int type)
5721 PREINIT:
5722 const unsigned char * e;
c9c05358 5723 CODE:
da8c1a98
KW		 5724 if (type >= 0) {
5725 e = p + UTF8SKIP(p) - type;
5726 RETVAL = isXDIGIT_utf8_safe(p, e);
5727 }
5728 else {
5729 RETVAL = isXDIGIT_utf8(p);
5730 }
c9c05358
KW		 5731 OUTPUT:
5732 RETVAL
5733
5734bool
da8c1a98
KW		 5735test_isXDIGIT_LC_utf8(unsigned char * p, int type)
5736 PREINIT:
5737 const unsigned char * e;
981746b9 5738 CODE:
da8c1a98
KW		 5739 if (type >= 0) {
5740 e = p + UTF8SKIP(p) - type;
5741 RETVAL = isXDIGIT_LC_utf8_safe(p, e);
5742 }
5743 else {
5744 RETVAL = isXDIGIT_LC_utf8(p);
5745 }
981746b9
KW		 5746 OUTPUT:
5747 RETVAL
5748
5749bool
c9c05358
KW		 5750test_isPSXSPC_uni(UV ord)
5751 CODE:
5752 RETVAL = isPSXSPC_uni(ord);
5753 OUTPUT:
5754 RETVAL
5755
5756bool
a7fe8528
KW		 5757test_isPSXSPC_uvchr(UV ord)
5758 CODE:
5759 RETVAL = isPSXSPC_uvchr(ord);
5760 OUTPUT:
5761 RETVAL
5762
5763bool
981746b9
KW		 5764test_isPSXSPC_LC_uvchr(UV ord)
5765 CODE:
5766 RETVAL = isPSXSPC_LC_uvchr(ord);
5767 OUTPUT:
5768 RETVAL
5769
5770bool
ee9e5f10
KW		 5771test_isPSXSPC(UV ord)
5772 CODE:
5773 RETVAL = isPSXSPC(ord);
5774 OUTPUT:
5775 RETVAL
5776
5777bool
c9c05358
KW		 5778test_isPSXSPC_A(UV ord)
5779 CODE:
5780 RETVAL = isPSXSPC_A(ord);
5781 OUTPUT:
5782 RETVAL
5783
5784bool
5785test_isPSXSPC_L1(UV ord)
5786 CODE:
5787 RETVAL = isPSXSPC_L1(ord);
5788 OUTPUT:
5789 RETVAL
5790
5791bool
981746b9
KW		 5792test_isPSXSPC_LC(UV ord)
5793 CODE:
5794 RETVAL = isPSXSPC_LC(ord);
5795 OUTPUT:
5796 RETVAL
5797
5798bool
da8c1a98
KW		 5799test_isPSXSPC_utf8(unsigned char * p, int type)
5800 PREINIT:
5801 const unsigned char * e;
c9c05358 5802 CODE:
da8c1a98
KW		 5803 if (type >= 0) {
5804 e = p + UTF8SKIP(p) - type;
5805 RETVAL = isPSXSPC_utf8_safe(p, e);
5806 }
5807 else {
5808 RETVAL = isPSXSPC_utf8(p);
5809 }
c9c05358
KW		 5810 OUTPUT:
5811 RETVAL
5812
5813bool
da8c1a98
KW		 5814test_isPSXSPC_LC_utf8(unsigned char * p, int type)
5815 PREINIT:
5816 const unsigned char * e;
981746b9 5817 CODE:
da8c1a98
KW		 5818 if (type >= 0) {
5819 e = p + UTF8SKIP(p) - type;
5820 RETVAL = isPSXSPC_LC_utf8_safe(p, e);
5821 }
5822 else {
5823 RETVAL = isPSXSPC_LC_utf8(p);
5824 }
981746b9
KW		 5825 OUTPUT:
5826 RETVAL
5827
5828bool
c9c05358
KW		 5829test_isQUOTEMETA(UV ord)
5830 CODE:
5831 RETVAL = _isQUOTEMETA(ord);
bdd8600f
KW		 5832 OUTPUT:
5833 RETVAL
2e1414ce
KW		 5834
5835UV
6e3d6c02
KW		 5836test_OFFUNISKIP(UV ord)
5837 CODE:
5838 RETVAL = OFFUNISKIP(ord);
5839 OUTPUT:
5840 RETVAL
5841
5842bool
5843test_OFFUNI_IS_INVARIANT(UV ord)
5844 CODE:
5845 RETVAL = OFFUNI_IS_INVARIANT(ord);
5846 OUTPUT:
5847 RETVAL
5848
5849bool
5850test_UVCHR_IS_INVARIANT(UV ord)
5851 CODE:
5852 RETVAL = UVCHR_IS_INVARIANT(ord);
5853 OUTPUT:
5854 RETVAL
5855
5856bool
5857test_UTF8_IS_INVARIANT(char ch)
5858 CODE:
5859 RETVAL = UTF8_IS_INVARIANT(ch);
5860 OUTPUT:
5861 RETVAL
5862
5863UV
5864test_UVCHR_SKIP(UV ord)
5865 CODE:
5866 RETVAL = UVCHR_SKIP(ord);
5867 OUTPUT:
5868 RETVAL
5869
5870UV
5871test_UTF8_SKIP(char * ch)
5872 CODE:
5873 RETVAL = UTF8_SKIP(ch);
5874 OUTPUT:
5875 RETVAL
5876
5877bool
5878test_UTF8_IS_START(char ch)
5879 CODE:
5880 RETVAL = UTF8_IS_START(ch);
5881 OUTPUT:
5882 RETVAL
5883
5884bool
5885test_UTF8_IS_CONTINUATION(char ch)
5886 CODE:
5887 RETVAL = UTF8_IS_CONTINUATION(ch);
5888 OUTPUT:
5889 RETVAL
5890
5891bool
5892test_UTF8_IS_CONTINUED(char ch)
5893 CODE:
5894 RETVAL = UTF8_IS_CONTINUED(ch);
5895 OUTPUT:
5896 RETVAL
5897
5898bool
5899test_UTF8_IS_DOWNGRADEABLE_START(char ch)
5900 CODE:
5901 RETVAL = UTF8_IS_DOWNGRADEABLE_START(ch);
5902 OUTPUT:
5903 RETVAL
5904
5905bool
5906test_UTF8_IS_ABOVE_LATIN1(char ch)
5907 CODE:
5908 RETVAL = UTF8_IS_ABOVE_LATIN1(ch);
5909 OUTPUT:
5910 RETVAL
5911
5912bool
5913test_isUTF8_POSSIBLY_PROBLEMATIC(char ch)
5914 CODE:
5915 RETVAL = isUTF8_POSSIBLY_PROBLEMATIC(ch);
5916 OUTPUT:
5917 RETVAL
5918
d7874298
KW		 5919STRLEN
5920test_isUTF8_CHAR(char *s, STRLEN len)
5921 CODE:
5922 RETVAL = isUTF8_CHAR((U8 *) s, (U8 *) s + len);
5923 OUTPUT:
5924 RETVAL
5925
e23e8bc1 5926STRLEN
25e3a4e0
KW		 5927test_isUTF8_CHAR_flags(char *s, STRLEN len, U32 flags)
5928 CODE:
5929 RETVAL = isUTF8_CHAR_flags((U8 *) s, (U8 *) s + len, flags);
5930 OUTPUT:
5931 RETVAL
5932
5933STRLEN
e23e8bc1
KW		 5934test_isSTRICT_UTF8_CHAR(char *s, STRLEN len)
5935 CODE:
5936 RETVAL = isSTRICT_UTF8_CHAR((U8 *) s, (U8 *) s + len);
5937 OUTPUT:
5938 RETVAL
5939
a82be82b
KW		 5940STRLEN
5941test_isC9_STRICT_UTF8_CHAR(char *s, STRLEN len)
5942 CODE:
5943 RETVAL = isC9_STRICT_UTF8_CHAR((U8 *) s, (U8 *) s + len);
5944 OUTPUT:
5945 RETVAL
5946
3d56ecbe
KW		 5947IV
5948test_is_utf8_valid_partial_char_flags(char *s, STRLEN len, U32 flags)
5949 CODE:
9f2abfde
KW		 5950 /* RETVAL should be bool (here and in tests below), but making it IV
5951 * allows us to test it returning 0 or 1 */
3d56ecbe
KW		 5952 RETVAL = is_utf8_valid_partial_char_flags((U8 *) s, (U8 *) s + len, flags);
5953 OUTPUT:
5954 RETVAL
5955
9f2abfde
KW		 5956IV
5957test_is_utf8_string(char *s, STRLEN len)
5958 CODE:
5959 RETVAL = is_utf8_string((U8 *) s, len);
5960 OUTPUT:
5961 RETVAL
5962
5963AV *
5964test_is_utf8_string_loc(char *s, STRLEN len)
5965 PREINIT:
5966 AV *av;
5967 const U8 * ep;
5968 CODE:
5969 av = newAV();
5970 av_push(av, newSViv(is_utf8_string_loc((U8 *) s, len, &ep)));
5971 av_push(av, newSViv(ep - (U8 *) s));
5972 RETVAL = av;
5973 OUTPUT:
5974 RETVAL
5975
5976AV *
5977test_is_utf8_string_loclen(char *s, STRLEN len)
5978 PREINIT:
5979 AV *av;
5980 STRLEN ret_len;
5981 const U8 * ep;
5982 CODE:
5983 av = newAV();
5984 av_push(av, newSViv(is_utf8_string_loclen((U8 *) s, len, &ep, &ret_len)));
5985 av_push(av, newSViv(ep - (U8 *) s));
5986 av_push(av, newSVuv(ret_len));
5987 RETVAL = av;
5988 OUTPUT:
5989 RETVAL
5990
5991IV
5992test_is_utf8_string_flags(char *s, STRLEN len, U32 flags)
5993 CODE:
5994 RETVAL = is_utf8_string_flags((U8 *) s, len, flags);
5995 OUTPUT:
5996 RETVAL
5997
5998AV *
5999test_is_utf8_string_loc_flags(char *s, STRLEN len, U32 flags)
6000 PREINIT:
6001 AV *av;
6002 const U8 * ep;
6003 CODE:
6004 av = newAV();
6005 av_push(av, newSViv(is_utf8_string_loc_flags((U8 *) s, len, &ep, flags)));
6006 av_push(av, newSViv(ep - (U8 *) s));
6007 RETVAL = av;
6008 OUTPUT:
6009 RETVAL
6010
6011AV *
6012test_is_utf8_string_loclen_flags(char *s, STRLEN len, U32 flags)
6013 PREINIT:
6014 AV *av;
6015 STRLEN ret_len;
6016 const U8 * ep;
6017 CODE:
6018 av = newAV();
6019 av_push(av, newSViv(is_utf8_string_loclen_flags((U8 *) s, len, &ep, &ret_len, flags)));
6020 av_push(av, newSViv(ep - (U8 *) s));
6021 av_push(av, newSVuv(ret_len));
6022 RETVAL = av;
6023 OUTPUT:
6024 RETVAL
6025
6026IV
6027test_is_strict_utf8_string(char *s, STRLEN len)
6028 CODE:
6029 RETVAL = is_strict_utf8_string((U8 *) s, len);
6030 OUTPUT:
6031 RETVAL
6032
6033AV *
6034test_is_strict_utf8_string_loc(char *s, STRLEN len)
6035 PREINIT:
6036 AV *av;
6037 const U8 * ep;
6038 CODE:
6039 av = newAV();
6040 av_push(av, newSViv(is_strict_utf8_string_loc((U8 *) s, len, &ep)));
6041 av_push(av, newSViv(ep - (U8 *) s));
6042 RETVAL = av;
6043 OUTPUT:
6044 RETVAL
6045
6046AV *
6047test_is_strict_utf8_string_loclen(char *s, STRLEN len)
6048 PREINIT:
6049 AV *av;
6050 STRLEN ret_len;
6051 const U8 * ep;
6052 CODE:
6053 av = newAV();
6054 av_push(av, newSViv(is_strict_utf8_string_loclen((U8 *) s, len, &ep, &ret_len)));
6055 av_push(av, newSViv(ep - (U8 *) s));
6056 av_push(av, newSVuv(ret_len));
6057 RETVAL = av;
6058 OUTPUT:
6059 RETVAL
6060
6061IV
6062test_is_c9strict_utf8_string(char *s, STRLEN len)
6063 CODE:
6064 RETVAL = is_c9strict_utf8_string((U8 *) s, len);
6065 OUTPUT:
6066 RETVAL
6067
6068AV *
6069test_is_c9strict_utf8_string_loc(char *s, STRLEN len)
6070 PREINIT:
6071 AV *av;
6072 const U8 * ep;
6073 CODE:
6074 av = newAV();
6075 av_push(av, newSViv(is_c9strict_utf8_string_loc((U8 *) s, len, &ep)));
6076 av_push(av, newSViv(ep - (U8 *) s));
6077 RETVAL = av;
6078 OUTPUT:
6079 RETVAL
6080
6081AV *
6082test_is_c9strict_utf8_string_loclen(char *s, STRLEN len)
6083 PREINIT:
6084 AV *av;
6085 STRLEN ret_len;
6086 const U8 * ep;
6087 CODE:
6088 av = newAV();
6089 av_push(av, newSViv(is_c9strict_utf8_string_loclen((U8 *) s, len, &ep, &ret_len)));
6090 av_push(av, newSViv(ep - (U8 *) s));
6091 av_push(av, newSVuv(ret_len));
6092 RETVAL = av;
6093 OUTPUT:
6094 RETVAL
6095
8bc127bf
KW		 6096IV
6097test_is_utf8_fixed_width_buf_flags(char *s, STRLEN len, U32 flags)
6098 CODE:
6099 RETVAL = is_utf8_fixed_width_buf_flags((U8 *) s, len, flags);
6100 OUTPUT:
6101 RETVAL
6102
6103AV *
6104test_is_utf8_fixed_width_buf_loc_flags(char *s, STRLEN len, U32 flags)
6105 PREINIT:
6106 AV *av;
6107 const U8 * ep;
6108 CODE:
6109 av = newAV();
6110 av_push(av, newSViv(is_utf8_fixed_width_buf_loc_flags((U8 *) s, len, &ep, flags)));
6111 av_push(av, newSViv(ep - (U8 *) s));
6112 RETVAL = av;
6113 OUTPUT:
6114 RETVAL
6115
6116AV *
6117test_is_utf8_fixed_width_buf_loclen_flags(char *s, STRLEN len, U32 flags)
6118 PREINIT:
6119 AV *av;
6120 STRLEN ret_len;
6121 const U8 * ep;
6122 CODE:
6123 av = newAV();
6124 av_push(av, newSViv(is_utf8_fixed_width_buf_loclen_flags((U8 *) s, len, &ep, &ret_len, flags)));
6125 av_push(av, newSViv(ep - (U8 *) s));
6126 av_push(av, newSVuv(ret_len));
6127 RETVAL = av;
6128 OUTPUT:
6129 RETVAL
6130
65df57a8
TC		 6131IV
6132test_utf8_hop_safe(SV *s_sv, STRLEN s_off, IV off)
6133 PREINIT:
6134 STRLEN len;
6135 U8 *p;
6136 U8 *r;
6137 CODE:
6138 p = (U8 *)SvPV(s_sv, len);
6139 r = utf8_hop_safe(p + s_off, off, p, p + len);
6140 RETVAL = r - p;
6141 OUTPUT:
6142 RETVAL
6143
6e3d6c02 6144UV
2e1414ce
KW		 6145test_toLOWER(UV ord)
6146 CODE:
6147 RETVAL = toLOWER(ord);
6148 OUTPUT:
6149 RETVAL
6150
6151UV
6152test_toLOWER_L1(UV ord)
6153 CODE:
6154 RETVAL = toLOWER_L1(ord);
6155 OUTPUT:
6156 RETVAL
6157
6158UV
6159test_toLOWER_LC(UV ord)
6160 CODE:
6161 RETVAL = toLOWER_LC(ord);
6162 OUTPUT:
6163 RETVAL
6164
6165AV *
6166test_toLOWER_uni(UV ord)
6167 PREINIT:
6168 U8 s[UTF8_MAXBYTES_CASE + 1];
6169 STRLEN len;
6170 AV *av;
6171 SV *utf8;
6172 CODE:
6173 av = newAV();
6174 av_push(av, newSVuv(toLOWER_uni(ord, s, &len)));
6175
6176 utf8 = newSVpvn((char *) s, len);
6177 SvUTF8_on(utf8);
6178 av_push(av, utf8);
6179
6180 av_push(av, newSVuv(len));
6181 RETVAL = av;
6182 OUTPUT:
6183 RETVAL
6184
6185AV *
a7fe8528
KW		 6186test_toLOWER_uvchr(UV ord)
6187 PREINIT:
6188 U8 s[UTF8_MAXBYTES_CASE + 1];
6189 STRLEN len;
6190 AV *av;
6191 SV *utf8;
6192 CODE:
6193 av = newAV();
6194 av_push(av, newSVuv(toLOWER_uvchr(ord, s, &len)));
6195
6196 utf8 = newSVpvn((char *) s, len);
6197 SvUTF8_on(utf8);
6198 av_push(av, utf8);
6199
6200 av_push(av, newSVuv(len));
6201 RETVAL = av;
6202 OUTPUT:
6203 RETVAL
6204
6205AV *
a239b1e2 6206test_toLOWER_utf8(SV * p, int type)
2e1414ce
KW		 6207 PREINIT:
6208 U8 *input;
6209 U8 s[UTF8_MAXBYTES_CASE + 1];
6210 STRLEN len;
6211 AV *av;
6212 SV *utf8;
a239b1e2 6213 const unsigned char * e;
b3611286 6214 UV resultant_cp = UV_MAX; /* Initialized because of dumb compilers */
2e1414ce
KW		 6215 CODE:
6216 input = (U8 *) SvPV(p, len);
6217 av = newAV();
607313a1 6218 if (type >= 0) {
a239b1e2
KW		 6219 e = input + UTF8SKIP(input) - type;
6220 resultant_cp = toLOWER_utf8_safe(input, e, s, &len);
607313a1
KW		 6221 }
6222 else if (type == -1) {
6223 resultant_cp = toLOWER_utf8(input, s, &len);
6224 }
6225#ifndef NO_MATHOMS
6226 else {
6227 resultant_cp = Perl_to_utf8_lower(aTHX_ input, s, &len);
6228 }
6229#endif
a239b1e2 6230 av_push(av, newSVuv(resultant_cp));
2e1414ce
KW		 6231
6232 utf8 = newSVpvn((char *) s, len);
6233 SvUTF8_on(utf8);
6234 av_push(av, utf8);
6235
6236 av_push(av, newSVuv(len));
6237 RETVAL = av;
6238 OUTPUT:
6239 RETVAL
6240
6241UV
6242test_toFOLD(UV ord)
6243 CODE:
6244 RETVAL = toFOLD(ord);
6245 OUTPUT:
6246 RETVAL
6247
6248UV
6249test_toFOLD_LC(UV ord)
6250 CODE:
6251 RETVAL = toFOLD_LC(ord);
6252 OUTPUT:
6253 RETVAL
6254
6255AV *
6256test_toFOLD_uni(UV ord)
6257 PREINIT:
6258 U8 s[UTF8_MAXBYTES_CASE + 1];
6259 STRLEN len;
6260 AV *av;
6261 SV *utf8;
6262 CODE:
6263 av = newAV();
6264 av_push(av, newSVuv(toFOLD_uni(ord, s, &len)));
6265
6266 utf8 = newSVpvn((char *) s, len);
6267 SvUTF8_on(utf8);
6268 av_push(av, utf8);
6269
6270 av_push(av, newSVuv(len));
6271 RETVAL = av;
6272 OUTPUT:
6273 RETVAL
6274
6275AV *
a7fe8528
KW		 6276test_toFOLD_uvchr(UV ord)
6277 PREINIT:
6278 U8 s[UTF8_MAXBYTES_CASE + 1];
6279 STRLEN len;
6280 AV *av;
6281 SV *utf8;
6282 CODE:
6283 av = newAV();
6284 av_push(av, newSVuv(toFOLD_uvchr(ord, s, &len)));
6285
6286 utf8 = newSVpvn((char *) s, len);
6287 SvUTF8_on(utf8);
6288 av_push(av, utf8);
6289
6290 av_push(av, newSVuv(len));
6291 RETVAL = av;
6292 OUTPUT:
6293 RETVAL
6294
6295AV *
a239b1e2 6296test_toFOLD_utf8(SV * p, int type)
2e1414ce
KW		 6297 PREINIT:
6298 U8 *input;
6299 U8 s[UTF8_MAXBYTES_CASE + 1];
6300 STRLEN len;
6301 AV *av;
6302 SV *utf8;
a239b1e2 6303 const unsigned char * e;
b3611286 6304 UV resultant_cp = UV_MAX;
2e1414ce
KW		 6305 CODE:
6306 input = (U8 *) SvPV(p, len);
6307 av = newAV();
607313a1 6308 if (type >= 0) {
a239b1e2
KW		 6309 e = input + UTF8SKIP(input) - type;
6310 resultant_cp = toFOLD_utf8_safe(input, e, s, &len);
607313a1
KW		 6311 }
6312 else if (type == -1) {
6313 resultant_cp = toFOLD_utf8(input, s, &len);
6314 }
6315#ifndef NO_MATHOMS
6316 else {
6317 resultant_cp = Perl_to_utf8_fold(aTHX_ input, s, &len);
6318 }
6319#endif
a239b1e2 6320 av_push(av, newSVuv(resultant_cp));
2e1414ce
KW		 6321
6322 utf8 = newSVpvn((char *) s, len);
6323 SvUTF8_on(utf8);
6324 av_push(av, utf8);
6325
6326 av_push(av, newSVuv(len));
6327 RETVAL = av;
6328 OUTPUT:
6329 RETVAL
6330
6331UV
6332test_toUPPER(UV ord)
6333 CODE:
6334 RETVAL = toUPPER(ord);
6335 OUTPUT:
6336 RETVAL
6337
6338UV
6339test_toUPPER_LC(UV ord)
6340 CODE:
6341 RETVAL = toUPPER_LC(ord);
6342 OUTPUT:
6343 RETVAL
6344
6345AV *
6346test_toUPPER_uni(UV ord)
6347 PREINIT:
6348 U8 s[UTF8_MAXBYTES_CASE + 1];
6349 STRLEN len;
6350 AV *av;
6351 SV *utf8;
6352 CODE:
6353 av = newAV();
6354 av_push(av, newSVuv(toUPPER_uni(ord, s, &len)));
6355
6356 utf8 = newSVpvn((char *) s, len);
6357 SvUTF8_on(utf8);
6358 av_push(av, utf8);
6359
6360 av_push(av, newSVuv(len));
6361 RETVAL = av;
6362 OUTPUT:
6363 RETVAL
6364
6365AV *
a7fe8528
KW		 6366test_toUPPER_uvchr(UV ord)
6367 PREINIT:
6368 U8 s[UTF8_MAXBYTES_CASE + 1];
6369 STRLEN len;
6370 AV *av;
6371 SV *utf8;
6372 CODE:
6373 av = newAV();
6374 av_push(av, newSVuv(toUPPER_uvchr(ord, s, &len)));
6375
6376 utf8 = newSVpvn((char *) s, len);
6377 SvUTF8_on(utf8);
6378 av_push(av, utf8);
6379
6380 av_push(av, newSVuv(len));
6381 RETVAL = av;
6382 OUTPUT:
6383 RETVAL
6384
6385AV *
a239b1e2 6386test_toUPPER_utf8(SV * p, int type)
2e1414ce
KW		 6387 PREINIT:
6388 U8 *input;
6389 U8 s[UTF8_MAXBYTES_CASE + 1];
6390 STRLEN len;
6391 AV *av;
6392 SV *utf8;
a239b1e2 6393 const unsigned char * e;
b3611286 6394 UV resultant_cp = UV_MAX;
2e1414ce
KW		 6395 CODE:
6396 input = (U8 *) SvPV(p, len);
6397 av = newAV();
607313a1 6398 if (type >= 0) {
a239b1e2
KW		 6399 e = input + UTF8SKIP(input) - type;
6400 resultant_cp = toUPPER_utf8_safe(input, e, s, &len);
607313a1
KW		 6401 }
6402 else if (type == -1) {
6403 resultant_cp = toUPPER_utf8(input, s, &len);
6404 }
6405#ifndef NO_MATHOMS
6406 else {
6407 resultant_cp = Perl_to_utf8_upper(aTHX_ input, s, &len);
6408 }
6409#endif
a239b1e2 6410 av_push(av, newSVuv(resultant_cp));
2e1414ce
KW		 6411
6412 utf8 = newSVpvn((char *) s, len);
6413 SvUTF8_on(utf8);
6414 av_push(av, utf8);
6415
6416 av_push(av, newSVuv(len));
6417 RETVAL = av;
6418 OUTPUT:
6419 RETVAL
6420
6421UV
6422test_toTITLE(UV ord)
6423 CODE:
6424 RETVAL = toTITLE(ord);
6425 OUTPUT:
6426 RETVAL
6427
6428AV *
6429test_toTITLE_uni(UV ord)
6430 PREINIT:
6431 U8 s[UTF8_MAXBYTES_CASE + 1];
6432 STRLEN len;
6433 AV *av;
6434 SV *utf8;
6435 CODE:
6436 av = newAV();
6437 av_push(av, newSVuv(toTITLE_uni(ord, s, &len)));
6438
6439 utf8 = newSVpvn((char *) s, len);
6440 SvUTF8_on(utf8);
6441 av_push(av, utf8);
6442
6443 av_push(av, newSVuv(len));
6444 RETVAL = av;
6445 OUTPUT:
6446 RETVAL
6447
6448AV *
a7fe8528
KW		 6449test_toTITLE_uvchr(UV ord)
6450 PREINIT:
6451 U8 s[UTF8_MAXBYTES_CASE + 1];
6452 STRLEN len;
6453 AV *av;
6454 SV *utf8;
6455 CODE:
6456 av = newAV();
6457 av_push(av, newSVuv(toTITLE_uvchr(ord, s, &len)));
6458
6459 utf8 = newSVpvn((char *) s, len);
6460 SvUTF8_on(utf8);
6461 av_push(av, utf8);
6462
6463 av_push(av, newSVuv(len));
6464 RETVAL = av;
6465 OUTPUT:
6466 RETVAL
6467
6468AV *
a239b1e2 6469test_toTITLE_utf8(SV * p, int type)
2e1414ce
KW		 6470 PREINIT:
6471 U8 *input;
6472 U8 s[UTF8_MAXBYTES_CASE + 1];
6473 STRLEN len;
6474 AV *av;
6475 SV *utf8;
a239b1e2 6476 const unsigned char * e;
b3611286 6477 UV resultant_cp = UV_MAX;
2e1414ce
KW		 6478 CODE:
6479 input = (U8 *) SvPV(p, len);
6480 av = newAV();
607313a1 6481 if (type >= 0) {
a239b1e2
KW		 6482 e = input + UTF8SKIP(input) - type;
6483 resultant_cp = toTITLE_utf8_safe(input, e, s, &len);
607313a1
KW		 6484 }
6485 else if (type == -1) {
6486 resultant_cp = toTITLE_utf8(input, s, &len);
6487 }
6488#ifndef NO_MATHOMS
6489 else {
6490 resultant_cp = Perl_to_utf8_title(aTHX_ input, s, &len);
6491 }
6492#endif
a239b1e2 6493 av_push(av, newSVuv(resultant_cp));
2e1414ce
KW		 6494
6495 utf8 = newSVpvn((char *) s, len);
6496 SvUTF8_on(utf8);
6497 av_push(av, utf8);
6498
6499 av_push(av, newSVuv(len));
6500 RETVAL = av;
6501 OUTPUT:
6502 RETVAL
4c28b29c
KW		 6503
6504SV *
6505test_Gconvert(SV * number, SV * num_digits)
6506 PREINIT:
6507 char buffer[100];
6508 int len;
6509 CODE:
6510 len = (int) SvIV(num_digits);
6511 if (len > 99) croak("Too long a number for test_Gconvert");
d2f5c618 6512 if (len < 0) croak("Too short a number for test_Gconvert");
4c28b29c
KW		 6513 PERL_UNUSED_RESULT(Gconvert(SvNV(number), len,
6514 0, /* No trailing zeroes */
6515 buffer));
6516 RETVAL = newSVpv(buffer, 0);
6517 OUTPUT:
6518 RETVAL
eaab5649
YO		 6519
6520MODULE = XS::APItest PACKAGE = XS::APItest::Backrefs
6521
6522void
45c5a37a 6523apitest_weaken(SV *sv)
eaab5649
YO		 6524 PROTOTYPE: $
6525 CODE:
6526 sv_rvweaken(sv);
6527
6528SV *
6529has_backrefs(SV *sv)
6530 CODE:
6531 if (SvROK(sv) && sv_get_backrefs(SvRV(sv)))
6532 RETVAL = &PL_sv_yes;
6533 else
6534 RETVAL = &PL_sv_no;
6535 OUTPUT:
6536 RETVAL
6537
67c6176d
DD		 6538#ifdef WIN32
6539#ifdef PERL_IMPLICIT_SYS
52236464
TC		 6540
6541const char *
6542PerlDir_mapA(const char *path)
6543
6544const WCHAR *
6545PerlDir_mapW(const WCHAR *wpath)
6546
6547#endif
67c6176d
DD		 6548
6549void
6550Comctl32Version()
6551 PREINIT:
6552 HMODULE dll;
6553 VS_FIXEDFILEINFO *info;
6554 UINT len;
6555 HRSRC hrsc;
6556 HGLOBAL ver;
6557 void * vercopy;
6558 PPCODE:
6559 dll = GetModuleHandle("comctl32.dll"); /* must already be in proc */
6560 if(!dll)
6561 croak("Comctl32Version: comctl32.dll not in process???");
6562 hrsc = FindResource(dll, MAKEINTRESOURCE(VS_VERSION_INFO),
6563 MAKEINTRESOURCE(VS_FILE_INFO));
6564 if(!hrsc)
6565 croak("Comctl32Version: comctl32.dll no version???");
6566 ver = LoadResource(dll, hrsc);
6567 len = SizeofResource(dll, hrsc);
f3c6f22e 6568 vercopy = _alloca(len);
67c6176d
DD		 6569 memcpy(vercopy, ver, len);
6570 if (VerQueryValue(vercopy, "\\", (void**)&info, &len)) {
6571 int dwValueMS1 = (info->dwFileVersionMS>>16);
6572 int dwValueMS2 = (info->dwFileVersionMS&0xffff);
6573 int dwValueLS1 = (info->dwFileVersionLS>>16);
6574 int dwValueLS2 = (info->dwFileVersionLS&0xffff);
6575 EXTEND(SP, 4);
6576 mPUSHi(dwValueMS1);
6577 mPUSHi(dwValueMS2);
6578 mPUSHi(dwValueLS1);
6579 mPUSHi(dwValueLS2);
6580 }
6581
6582#endif
6583
6584
Unnamed repository; edit this file 'description' to name the repository.