This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
isPSXSPC() is a synonym for isSPACE
[perl5.git] / dist / Devel-PPPort / parts / inc / misc
CommitLineData
adfe19db
MHM
1################################################################################
2##
b2049988 3## Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
adfe19db
MHM
4## Version 2.x, Copyright (C) 2001, Paul Marquess.
5## Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
6##
7## This program is free software; you can redistribute it and/or
8## modify it under the same terms as Perl itself.
9##
10################################################################################
11
12=provides
13
14__UNDEFINED__
f2615e36
KW
15END_EXTERN_C
16EXTERN_C
f2615e36
KW
17INT2PTR
18MUTABLE_PTR
f2615e36 19NVTYPE
f2615e36
KW
20PERLIO_FUNCS_CAST
21PERLIO_FUNCS_DECL
f2ab5a41 22PERL_UNUSED_ARG
f2ab5a41 23PERL_UNUSED_CONTEXT
f2615e36 24PERL_UNUSED_DECL
94e22bd6 25PERL_UNUSED_RESULT
f2615e36 26PERL_UNUSED_VAR
c07deaaf 27PERL_USE_GCC_BRACE_GROUPS
adfe19db 28PTR2ul
f2615e36 29PTRV
a745474a 30START_EXTERN_C
a745474a 31STMT_END
f2615e36
KW
32STMT_START
33SvRX
b2049988 34WIDEST_UTYPE
0d0f8426 35XSRETURN
adfe19db
MHM
36
37=implementation
38
94e22bd6
MH
39__UNDEFINED__ cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0)
40__UNDEFINED__ OpHAS_SIBLING(o) (cBOOL((o)->op_sibling))
41__UNDEFINED__ OpSIBLING(o) (0 + (o)->op_sibling)
42__UNDEFINED__ OpMORESIB_set(o, sib) ((o)->op_sibling = (sib))
43__UNDEFINED__ OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL)
44__UNDEFINED__ OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib))
58329f0d 45__UNDEFINED__ HEf_SVKEY -2
94e22bd6 46
6a6bfa62
KW
47#if defined(DEBUGGING) && !defined(__COVERITY__)
48__UNDEFINED__ __ASSERT_(statement) assert(statement),
49#else
50__UNDEFINED__ __ASSERT_(statement)
51#endif
52
a1d467bc
KW
53/* These could become provided when they become part of the public API */
54__UNDEF_NOT_PROVIDED__ withinCOUNT(c, l, n) \
55 (((WIDEST_UTYPE) (((c)) - ((l) | 0))) <= (((WIDEST_UTYPE) ((n) | 0))))
56__UNDEF_NOT_PROVIDED__ inRANGE(c, l, u) \
57 ( (sizeof(c) == sizeof(U8)) ? withinCOUNT(((U8) (c)), (l), ((u) - (l))) \
58 : (sizeof(c) == sizeof(U16)) ? withinCOUNT(((U16) (c)), (l), ((u) - (l))) \
59 : (sizeof(c) == sizeof(U32)) ? withinCOUNT(((U32) (c)), (l), ((u) - (l))) \
60 : (withinCOUNT(((WIDEST_UTYPE) (c)), (l), ((u) - (l)))))
61
ab53572c
KW
62/* Create the macro for "is'macro'_utf8_safe(s, e)". For code points below
63 * 256, it calls the equivalent _L1 macro by converting the UTF-8 to code
64 * point. That is so that it can automatically get the bug fixes done in this
65 * file. */
66#define D_PPP_IS_GENERIC_UTF8_SAFE(s, e, macro) \
67 (((e) - (s)) <= 0 \
68 ? 0 \
69 : UTF8_IS_INVARIANT((s)[0]) \
70 ? is ## macro ## _L1((s)[0]) \
71 : (((e) - (s)) < UTF8SKIP(s)) \
72 ? 0 \
73 : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \
74 /* The cast in the line below is only to silence warnings */ \
75 ? is ## macro ## _L1((WIDEST_UTYPE) LATIN1_TO_NATIVE( \
76 UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \
77 & UTF_START_MASK(2), \
78 (s)[1]))) \
79 : is ## macro ## _utf8(s))
80
e2e74bab 81__UNDEFINED__ SvRX(rv) (SvROK((rv)) ? (SvMAGICAL(SvRV((rv))) ? (mg_find(SvRV((rv)), PERL_MAGIC_qr) ? mg_find(SvRV((rv)), PERL_MAGIC_qr)->mg_obj : NULL) : NULL) : NULL)
94e22bd6
MH
82__UNDEFINED__ SvRXOK(sv) (!!SvRX(sv))
83
62093c1c
NC
84#ifndef PERL_UNUSED_DECL
85# ifdef HASATTRIBUTE
86# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
87# define PERL_UNUSED_DECL
88# else
89# define PERL_UNUSED_DECL __attribute__((unused))
90# endif
adfe19db 91# else
62093c1c 92# define PERL_UNUSED_DECL
adfe19db 93# endif
adfe19db
MHM
94#endif
95
f2ab5a41
MHM
96#ifndef PERL_UNUSED_ARG
97# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
98# include <note.h>
99# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
100# else
101# define PERL_UNUSED_ARG(x) ((void)x)
102# endif
103#endif
104
105#ifndef PERL_UNUSED_VAR
106# define PERL_UNUSED_VAR(x) ((void)x)
107#endif
108
109#ifndef PERL_UNUSED_CONTEXT
110# ifdef USE_ITHREADS
111# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
112# else
113# define PERL_UNUSED_CONTEXT
114# endif
115#endif
116
94e22bd6
MH
117#ifndef PERL_UNUSED_RESULT
118# if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT)
119# define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END
120# else
121# define PERL_UNUSED_RESULT(v) ((void)(v))
122# endif
123#endif
124
f2ab5a41
MHM
125__UNDEFINED__ NOOP /*EMPTY*/(void)0
126__UNDEFINED__ dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL
adfe19db
MHM
127
128#ifndef NVTYPE
129# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
130# define NVTYPE long double
131# else
132# define NVTYPE double
133# endif
134typedef NVTYPE NV;
135#endif
136
137#ifndef INT2PTR
adfe19db
MHM
138# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
139# define PTRV UV
140# define INT2PTR(any,d) (any)(d)
141# else
142# if PTRSIZE == LONGSIZE
143# define PTRV unsigned long
144# else
145# define PTRV unsigned
146# endif
147# define INT2PTR(any,d) (any)(PTRV)(d)
148# endif
7bb03b24 149#endif
adfe19db 150
7bb03b24 151#ifndef PTR2ul
adfe19db
MHM
152# if PTRSIZE == LONGSIZE
153# define PTR2ul(p) (unsigned long)(p)
154# else
4a582685 155# define PTR2ul(p) INT2PTR(unsigned long,p)
adfe19db 156# endif
7bb03b24 157#endif
adfe19db 158
7bb03b24
MHM
159__UNDEFINED__ PTR2nat(p) (PTRV)(p)
160__UNDEFINED__ NUM2PTR(any,d) (any)PTR2nat(d)
161__UNDEFINED__ PTR2IV(p) INT2PTR(IV,p)
162__UNDEFINED__ PTR2UV(p) INT2PTR(UV,p)
163__UNDEFINED__ PTR2NV(p) NUM2PTR(NV,p)
adfe19db 164
a745474a
MHM
165#undef START_EXTERN_C
166#undef END_EXTERN_C
167#undef EXTERN_C
168#ifdef __cplusplus
169# define START_EXTERN_C extern "C" {
170# define END_EXTERN_C }
171# define EXTERN_C extern "C"
172#else
173# define START_EXTERN_C
174# define END_EXTERN_C
175# define EXTERN_C extern
176#endif
177
0915d96d 178#if { VERSION < 5.004 } || defined(PERL_GCC_PEDANTIC)
c07deaaf 179# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
12b46422 180__UNDEF_NOT_PROVIDED__ PERL_GCC_BRACE_GROUPS_FORBIDDEN
a745474a
MHM
181# endif
182#endif
183
c07deaaf
MHM
184#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
185# ifndef PERL_USE_GCC_BRACE_GROUPS
186# define PERL_USE_GCC_BRACE_GROUPS
187# endif
188#endif
189
a745474a
MHM
190#undef STMT_START
191#undef STMT_END
c07deaaf 192#ifdef PERL_USE_GCC_BRACE_GROUPS
b2049988
MHM
193# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
194# define STMT_END )
a745474a
MHM
195#else
196# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
b2049988
MHM
197# define STMT_START if (1)
198# define STMT_END else (void)0
a745474a 199# else
b2049988
MHM
200# define STMT_START do
201# define STMT_END while (0)
a745474a
MHM
202# endif
203#endif
204
adfe19db
MHM
205__UNDEFINED__ boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
206
207/* DEFSV appears first in 5.004_56 */
b2049988 208__UNDEFINED__ DEFSV GvSV(PL_defgv)
adfe19db 209__UNDEFINED__ SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
ac2e3cea 210__UNDEFINED__ DEFSV_set(sv) (DEFSV = (sv))
adfe19db
MHM
211
212/* Older perls (<=5.003) lack AvFILLp */
213__UNDEFINED__ AvFILLp AvFILL
214
1eff2a3b
KW
215__UNDEFINED__ av_tindex AvFILL
216__UNDEFINED__ av_top_index AvFILL
217
adfe19db
MHM
218__UNDEFINED__ ERRSV get_sv("@",FALSE)
219
adfe19db
MHM
220/* Hint: gv_stashpvn
221 * This function's backport doesn't support the length parameter, but
222 * rather ignores it. Portability can only be ensured if the length
223 * parameter is used for speed reasons, but the length can always be
224 * correctly computed from the string argument.
225 */
226
227__UNDEFINED__ gv_stashpvn(str,len,create) gv_stashpv(str,create)
228
229/* Replace: 1 */
230__UNDEFINED__ get_cv perl_get_cv
231__UNDEFINED__ get_sv perl_get_sv
232__UNDEFINED__ get_av perl_get_av
233__UNDEFINED__ get_hv perl_get_hv
234/* Replace: 0 */
235
adfe19db
MHM
236__UNDEFINED__ dUNDERBAR dNOOP
237__UNDEFINED__ UNDERBAR DEFSV
238
239__UNDEFINED__ dAX I32 ax = MARK - PL_stack_base + 1
240__UNDEFINED__ dITEMS I32 items = SP - MARK
241
9132e1a3
MHM
242__UNDEFINED__ dXSTARG SV * targ = sv_newmortal()
243
0d0f8426
MHM
244__UNDEFINED__ dAXMARK I32 ax = POPMARK; \
245 register SV ** const mark = PL_stack_base + ax++
246
247
248__UNDEFINED__ XSprePUSH (sp = PL_stack_base + ax - 1)
249
250#if { VERSION < 5.005 }
251# undef XSRETURN
252# define XSRETURN(off) \
253 STMT_START { \
254 PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
255 return; \
256 } STMT_END
257#endif
258
8565c31a
MHM
259__UNDEFINED__ XSPROTO(name) void name(pTHX_ CV* cv)
260__UNDEFINED__ SVfARG(p) ((void*)(p))
261
f2ab5a41
MHM
262__UNDEFINED__ PERL_ABS(x) ((x) < 0 ? -(x) : (x))
263
264__UNDEFINED__ dVAR dNOOP
265
266__UNDEFINED__ SVf "_"
267
fd7af155
MHM
268__UNDEFINED__ CPERLscope(x) x
269
c83e6f19 270__UNDEFINED__ PERL_HASH(hash,str,len) \
b2049988
MHM
271 STMT_START { \
272 const char *s_PeRlHaSh = str; \
273 I32 i_PeRlHaSh = len; \
274 U32 hash_PeRlHaSh = 0; \
275 while (i_PeRlHaSh--) \
276 hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
277 (hash) = hash_PeRlHaSh; \
c83e6f19 278 } STMT_END
679ad62d 279
9c0a17a0
MHM
280#ifndef PERLIO_FUNCS_DECL
281# ifdef PERLIO_FUNCS_CONST
282# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
283# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
284# else
285# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
286# define PERLIO_FUNCS_CAST(funcs) (funcs)
287# endif
288#endif
289
fd7af155
MHM
290/* provide these typedefs for older perls */
291#if { VERSION < 5.9.3 }
292
293# ifdef ARGSproto
294typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto);
295# else
296typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
297# endif
298
299typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
300
301#endif
302
111bb900
CB
303#ifndef WIDEST_UTYPE
304# ifdef QUADKIND
305# ifdef U64TYPE
306# define WIDEST_UTYPE U64TYPE
307# else
308# define WIDEST_UTYPE Quad_t
309# endif
744ef08f 310# else
111bb900 311# define WIDEST_UTYPE U32
744ef08f 312# endif
b2049988
MHM
313#endif
314
2375c233
KW
315/* On versions without NATIVE_TO_ASCII, only ASCII is supported */
316#if defined(EBCDIC) && defined(NATIVE_TO_ASCI)
150ac7cc 317__UNDEFINED__ NATIVE_TO_LATIN1(c) NATIVE_TO_ASCII(c)
150ac7cc 318__UNDEFINED__ LATIN1_TO_NATIVE(c) ASCII_TO_NATIVE(c)
2375c233
KW
319__UNDEFINED__ NATIVE_TO_UNI(c) ((c) > 255 ? (c) : NATIVE_TO_LATIN1(c))
320__UNDEFINED__ UNI_TO_NATIVE(c) ((c) > 255 ? (c) : LATIN1_TO_NATIVE(c))
150ac7cc 321#else
2375c233 322__UNDEFINED__ NATIVE_TO_LATIN1(c) (c)
150ac7cc 323__UNDEFINED__ LATIN1_TO_NATIVE(c) (c)
2375c233
KW
324__UNDEFINED__ NATIVE_TO_UNI(c) (c)
325__UNDEFINED__ UNI_TO_NATIVE(c) (c)
150ac7cc
KW
326#endif
327
2375c233 328/* Warning: LATIN1_TO_NATIVE, NATIVE_TO_LATIN1 NATIVE_TO_UNI UNI_TO_NATIVE
150ac7cc
KW
329 EBCDIC is not supported on versions earlier than 5.7.1
330 */
331
6ec3ee8f
KW
332/* The meaning of this changed; use the modern version */
333#undef isPSXSPC
334#undef isPSXSPC_A
335#undef isPSXSPC_L1
336
337/* Hint: isPSXSPC, isPSXSPC_A, isPSXSPC_L1, isPSXSPC_utf8_safe
338 This is equivalent to the corresponding isSPACE-type macro. On perls
339 before 5.18, this matched a vertical tab and SPACE didn't. But the
340 ppport.h SPACE version does match VT in all perl releases. Since VT's are
341 extremely rarely found in real-life files, this difference effectively
342 doesn't matter */
343
344/* Hint: isSPACE, isSPACE_A, isSPACE_L1, isSPACE_utf8_safe
345 Until Perl 5.18, this did not match the vertical tab (VT). The ppport.h
346 version does match it in all perl releases. Since VT's are extremely rarely
347 found in real-life files, this difference effectively doesn't matter */
348
9dc2cc38
KW
349#ifdef EBCDIC
350
e17f6823
KW
351/* This is the first version where these macros are fully correct on EBCDIC
352 * platforms. Relying on * the C library functions, as earlier releases did,
353 * causes problems with * locales */
9dc2cc38
KW
354# if { VERSION < 5.22.0 }
355# undef isALNUM
356# undef isALNUM_A
876aded1 357# undef isALNUM_L1
9dc2cc38
KW
358# undef isALNUMC
359# undef isALNUMC_A
876aded1 360# undef isALNUMC_L1
9dc2cc38
KW
361# undef isALPHA
362# undef isALPHA_A
876aded1 363# undef isALPHA_L1
9dc2cc38
KW
364# undef isALPHANUMERIC
365# undef isALPHANUMERIC_A
876aded1 366# undef isALPHANUMERIC_L1
9dc2cc38
KW
367# undef isASCII
368# undef isASCII_A
876aded1 369# undef isASCII_L1
9dc2cc38
KW
370# undef isBLANK
371# undef isBLANK_A
876aded1 372# undef isBLANK_L1
9dc2cc38
KW
373# undef isCNTRL
374# undef isCNTRL_A
876aded1 375# undef isCNTRL_L1
9dc2cc38
KW
376# undef isDIGIT
377# undef isDIGIT_A
876aded1 378# undef isDIGIT_L1
9dc2cc38
KW
379# undef isGRAPH
380# undef isGRAPH_A
876aded1 381# undef isGRAPH_L1
9dc2cc38
KW
382# undef isIDCONT
383# undef isIDCONT_A
876aded1 384# undef isIDCONT_L1
9dc2cc38
KW
385# undef isIDFIRST
386# undef isIDFIRST_A
876aded1 387# undef isIDFIRST_L1
9dc2cc38
KW
388# undef isLOWER
389# undef isLOWER_A
876aded1 390# undef isLOWER_L1
9dc2cc38
KW
391# undef isOCTAL
392# undef isOCTAL_A
876aded1 393# undef isOCTAL_L1
9dc2cc38
KW
394# undef isPRINT
395# undef isPRINT_A
876aded1 396# undef isPRINT_L1
9dc2cc38
KW
397# undef isPUNCT
398# undef isPUNCT_A
876aded1 399# undef isPUNCT_L1
9dc2cc38
KW
400# undef isSPACE
401# undef isSPACE_A
876aded1 402# undef isSPACE_L1
9dc2cc38
KW
403# undef isUPPER
404# undef isUPPER_A
876aded1 405# undef isUPPER_L1
9dc2cc38
KW
406# undef isWORDCHAR
407# undef isWORDCHAR_A
876aded1 408# undef isWORDCHAR_L1
9dc2cc38
KW
409# undef isXDIGIT
410# undef isXDIGIT_A
876aded1 411# undef isXDIGIT_L1
9dc2cc38
KW
412# endif
413
414__UNDEFINED__ isASCII(c) (isCNTRL(c) || isPRINT(c))
415
416 /* The below is accurate for all EBCDIC code pages supported by
417 * all the versions of Perl overridden by this */
418__UNDEFINED__ isCNTRL(c) ( (c) == '\0' || (c) == '\a' || (c) == '\b' \
419 || (c) == '\f' || (c) == '\n' || (c) == '\r' \
420 || (c) == '\t' || (c) == '\v' \
421 || ((c) <= 3 && (c) >= 1) /* SOH, STX, ETX */ \
422 || (c) == 7 /* U+7F DEL */ \
423 || ((c) <= 0x13 && (c) >= 0x0E) /* SO, SI */ \
424 /* DLE, DC[1-3] */ \
425 || (c) == 0x18 /* U+18 CAN */ \
426 || (c) == 0x19 /* U+19 EOM */ \
427 || ((c) <= 0x1F && (c) >= 0x1C) /* [FGRU]S */ \
428 || (c) == 0x26 /* U+17 ETB */ \
429 || (c) == 0x27 /* U+1B ESC */ \
430 || (c) == 0x2D /* U+05 ENQ */ \
431 || (c) == 0x2E /* U+06 ACK */ \
432 || (c) == 0x32 /* U+16 SYN */ \
433 || (c) == 0x37 /* U+04 EOT */ \
434 || (c) == 0x3C /* U+14 DC4 */ \
435 || (c) == 0x3D /* U+15 NAK */ \
436 || (c) == 0x3F /* U+1A SUB */ \
437 )
876aded1
KW
438
439#if '^' == 106 /* EBCDIC POSIX-BC */
440# define D_PPP_OUTLIER_CONTROL 0x5F
441#else /* EBCDIC 1047 037 */
442# define D_PPP_OUTLIER_CONTROL 0xFF
443#endif
444
445/* The controls are everything below blank, plus one outlier */
446__UNDEFINED__ isCNTRL_L1(c) ((WIDEST_UTYPE) (c) < ' ' \
447 || (WIDEST_UTYPE) (c) == D_PPP_OUTLIER_CONTROL)
9dc2cc38
KW
448/* The ordering of the tests in this and isUPPER are to exclude most characters
449 * early */
450__UNDEFINED__ isLOWER(c) ( (c) >= 'a' && (c) <= 'z' \
451 && ( (c) <= 'i' \
452 || ((c) >= 'j' && (c) <= 'r') \
453 || (c) >= 's'))
454__UNDEFINED__ isUPPER(c) ( (c) >= 'A' && (c) <= 'Z' \
455 && ( (c) <= 'I' \
456 || ((c) >= 'J' && (c) <= 'R') \
457 || (c) >= 'S'))
458
459#else /* Above is EBCDIC; below is ASCII */
460
461# if { VERSION < 5.4.0 }
462/* The implementation of these in older perl versions can give wrong results if
463 * the C program locale is set to other than the C locale */
464# undef isALNUM
465# undef isALNUM_A
466# undef isALPHA
467# undef isALPHA_A
468# undef isDIGIT
469# undef isDIGIT_A
470# undef isIDFIRST
471# undef isIDFIRST_A
472# undef isLOWER
473# undef isLOWER_A
474# undef isUPPER
475# undef isUPPER_A
476# endif
477
d7412c0a 478# if { VERSION < 5.8.0 } /* earlier perls omitted DEL */
9dc2cc38
KW
479# undef isCNTRL
480# endif
481
482# if { VERSION < 5.10.0 }
d7412c0a
KW
483/* earlier perls included all of the isSPACE() characters, which is wrong. The
484 * version provided by Devel::PPPort always overrides an existing buggy
485 * version. */
9dc2cc38
KW
486# undef isPRINT
487# undef isPRINT_A
488# endif
489
490# if { VERSION < 5.14.0 }
d7412c0a 491/* earlier perls always returned true if the parameter was a signed char */
9dc2cc38
KW
492# undef isASCII
493# undef isASCII_A
494# endif
495
876aded1
KW
496# if { VERSION < 5.17.8 } /* earlier perls didn't include PILCROW, SECTION SIGN */
497# undef isPUNCT_L1
498# endif
499
500# if { VERSION < 5.13.7 } /* khw didn't investigate why this failed */
501# undef isALNUMC_L1
502#endif
503
d7412c0a 504# if { VERSION < 5.20.0 } /* earlier perls didn't include \v */
9dc2cc38
KW
505# undef isSPACE
506# undef isSPACE_A
876aded1 507# undef isSPACE_L1
e17f6823 508
9dc2cc38
KW
509# endif
510
b2049988
MHM
511__UNDEFINED__ isASCII(c) ((WIDEST_UTYPE) (c) <= 127)
512__UNDEFINED__ isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127)
876aded1
KW
513__UNDEFINED__ isCNTRL_L1(c) (isCNTRL(c) || ( (WIDEST_UTYPE) (c) <= 0x9F \
514 && (WIDEST_UTYPE) (c) >= 0x80))
9dc2cc38
KW
515__UNDEFINED__ isLOWER(c) ((c) >= 'a' && (c) <= 'z')
516__UNDEFINED__ isUPPER(c) ((c) <= 'Z' && (c) >= 'A')
e17f6823 517
9dc2cc38
KW
518#endif /* Below are definitions common to EBCDIC and ASCII */
519
876aded1 520__UNDEFINED__ isASCII_L1(c) isASCII(c)
9dc2cc38
KW
521__UNDEFINED__ isALNUM(c) isWORDCHAR(c)
522__UNDEFINED__ isALNUMC(c) isALPHANUMERIC(c)
876aded1 523__UNDEFINED__ isALNUMC_L1(c) isALPHANUMERIC_L1(c)
9dc2cc38 524__UNDEFINED__ isALPHA(c) (isUPPER(c) || isLOWER(c))
876aded1 525__UNDEFINED__ isALPHA_L1(c) (isUPPER_L1(c) || isLOWER_L1(c))
9dc2cc38 526__UNDEFINED__ isALPHANUMERIC(c) (isALPHA(c) || isDIGIT(c))
876aded1 527__UNDEFINED__ isALPHANUMERIC_L1(c) (isALPHA_L1(c) || isDIGIT(c))
9dc2cc38 528__UNDEFINED__ isBLANK(c) ((c) == ' ' || (c) == '\t')
876aded1
KW
529__UNDEFINED__ isBLANK_L1(c) ( isBLANK(c) \
530 || ( (WIDEST_UTYPE) (c) < 256 \
531 && NATIVE_TO_LATIN1((U8) c) == 0xA0))
9dc2cc38 532__UNDEFINED__ isDIGIT(c) ((c) <= '9' && (c) >= '0')
876aded1 533__UNDEFINED__ isDIGIT_L1(c) isDIGIT(c)
9dc2cc38 534__UNDEFINED__ isGRAPH(c) (isWORDCHAR(c) || isPUNCT(c))
3e5aa72a
KW
535__UNDEFINED__ isGRAPH_L1(c) ( isPRINT_L1(c) \
536 && (c) != ' ' \
537 && NATIVE_TO_LATIN1((U8) c) != 0xA0)
9dc2cc38 538__UNDEFINED__ isIDCONT(c) isWORDCHAR(c)
876aded1 539__UNDEFINED__ isIDCONT_L1(c) isWORDCHAR_L1(c)
9dc2cc38 540__UNDEFINED__ isIDFIRST(c) (isALPHA(c) || (c) == '_')
876aded1
KW
541__UNDEFINED__ isIDFIRST_L1(c) (isALPHA_L1(c) || NATIVE_TO_LATIN1(c) == '_')
542__UNDEFINED__ isLOWER_L1(c) ( isLOWER(c) \
543 || ( (WIDEST_UTYPE) (c) < 256 \
544 && ( ( NATIVE_TO_LATIN1((U8) c) >= 0xDF \
545 && NATIVE_TO_LATIN1((U8) c) != 0xF7) \
546 || NATIVE_TO_LATIN1((U8) c) == 0xAA \
547 || NATIVE_TO_LATIN1((U8) c) == 0xBA \
548 || NATIVE_TO_LATIN1((U8) c) == 0xB5)))
9dc2cc38 549__UNDEFINED__ isOCTAL(c) (((WIDEST_UTYPE)((c)) & ~7) == '0')
876aded1 550__UNDEFINED__ isOCTAL_L1(c) isOCTAL(c)
9dc2cc38 551__UNDEFINED__ isPRINT(c) (isGRAPH(c) || (c) == ' ')
876aded1 552__UNDEFINED__ isPRINT_L1(c) ((WIDEST_UTYPE) (c) < 256 && ! isCNTRL_L1(c))
9dc2cc38 553__UNDEFINED__ isPSXSPC(c) isSPACE(c)
876aded1 554__UNDEFINED__ isPSXSPC_L1(c) isSPACE_L1(c)
e17f6823
KW
555__UNDEFINED__ isPUNCT(c) ( (c) == '-' || (c) == '!' || (c) == '"' \
556 || (c) == '#' || (c) == '$' || (c) == '%' \
557 || (c) == '&' || (c) == '\'' || (c) == '(' \
558 || (c) == ')' || (c) == '*' || (c) == '+' \
559 || (c) == ',' || (c) == '.' || (c) == '/' \
560 || (c) == ':' || (c) == ';' || (c) == '<' \
561 || (c) == '=' || (c) == '>' || (c) == '?' \
562 || (c) == '@' || (c) == '[' || (c) == '\\' \
563 || (c) == ']' || (c) == '^' || (c) == '_' \
564 || (c) == '`' || (c) == '{' || (c) == '|' \
9dc2cc38 565 || (c) == '}' || (c) == '~')
876aded1
KW
566__UNDEFINED__ isPUNCT_L1(c) ( isPUNCT(c) \
567 || ( (WIDEST_UTYPE) (c) < 256 \
568 && ( NATIVE_TO_LATIN1((U8) c) == 0xA1 \
569 || NATIVE_TO_LATIN1((U8) c) == 0xA7 \
570 || NATIVE_TO_LATIN1((U8) c) == 0xAB \
571 || NATIVE_TO_LATIN1((U8) c) == 0xB6 \
572 || NATIVE_TO_LATIN1((U8) c) == 0xB7 \
573 || NATIVE_TO_LATIN1((U8) c) == 0xBB \
574 || NATIVE_TO_LATIN1((U8) c) == 0xBF)))
e17f6823 575__UNDEFINED__ isSPACE(c) ( isBLANK(c) || (c) == '\n' || (c) == '\r' \
9dc2cc38 576 || (c) == '\v' || (c) == '\f')
876aded1
KW
577__UNDEFINED__ isSPACE_L1(c) ( isSPACE(c) \
578 || ( (WIDEST_UTYPE) (c) < 256 \
579 && ( NATIVE_TO_LATIN1((U8) c) == 0x85 \
580 || NATIVE_TO_LATIN1((U8) c) == 0xA0)))
581__UNDEFINED__ isUPPER_L1(c) ( isUPPER(c) \
582 || ( (WIDEST_UTYPE) (c) < 256 \
583 && ( NATIVE_TO_LATIN1((U8) c) >= 0xC0 \
584 && NATIVE_TO_LATIN1((U8) c) <= 0xDE \
585 && NATIVE_TO_LATIN1((U8) c) != 0xD7)))
9dc2cc38 586__UNDEFINED__ isWORDCHAR(c) (isALPHANUMERIC(c) || (c) == '_')
876aded1 587__UNDEFINED__ isWORDCHAR_L1(c) (isIDFIRST_L1(c) || isDIGIT(c))
e17f6823
KW
588__UNDEFINED__ isXDIGIT(c) ( isDIGIT(c) \
589 || ((c) >= 'a' && (c) <= 'f') \
9dc2cc38 590 || ((c) >= 'A' && (c) <= 'F'))
876aded1 591__UNDEFINED__ isXDIGIT_L1(c) isXDIGIT(c)
9dc2cc38 592
ef89c4f1
KW
593__UNDEFINED__ isALNUM_A(c) isALNUM(c)
594__UNDEFINED__ isALNUMC_A(c) isALNUMC(c)
595__UNDEFINED__ isALPHA_A(c) isALPHA(c)
596__UNDEFINED__ isALPHANUMERIC_A(c) isALPHANUMERIC(c)
597__UNDEFINED__ isASCII_A(c) isASCII(c)
598__UNDEFINED__ isBLANK_A(c) isBLANK(c)
599__UNDEFINED__ isCNTRL_A(c) isCNTRL(c)
600__UNDEFINED__ isDIGIT_A(c) isDIGIT(c)
601__UNDEFINED__ isGRAPH_A(c) isGRAPH(c)
602__UNDEFINED__ isIDCONT_A(c) isIDCONT(c)
603__UNDEFINED__ isIDFIRST_A(c) isIDFIRST(c)
604__UNDEFINED__ isLOWER_A(c) isLOWER(c)
605__UNDEFINED__ isOCTAL_A(c) isOCTAL(c)
606__UNDEFINED__ isPRINT_A(c) isPRINT(c)
607__UNDEFINED__ isPSXSPC_A(c) isPSXSPC(c)
608__UNDEFINED__ isPUNCT_A(c) isPUNCT(c)
609__UNDEFINED__ isSPACE_A(c) isSPACE(c)
610__UNDEFINED__ isUPPER_A(c) isUPPER(c)
611__UNDEFINED__ isWORDCHAR_A(c) isWORDCHAR(c)
612__UNDEFINED__ isXDIGIT_A(c) isXDIGIT(c)
db42c902 613
ab53572c
KW
614__UNDEFINED__ isASCII_utf8_safe(s,e) isASCII(*(s))
615
616#if { VERSION >= 5.006 }
617
618__UNDEFINED__ isALPHA_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, ALPHA)
619# ifdef isALPHANUMERIC_utf8
620__UNDEFINED__ isALPHANUMERIC_utf8_safe(s,e) \
621 D_PPP_IS_GENERIC_UTF8_SAFE(s, e, ALPHANUMERIC)
622# else
623__UNDEFINED__ isALPHANUMERIC_utf8_safe(s,e) \
624 (isALPHA_utf8_safe(s,e) || isDIGIT_utf8_safe(s,e))
625# endif
626
627/* This was broken before 5.18, and just use this instead of worrying about
628 * which releases the official works on */
629# if 'A' == 65
630__UNDEFINED__ isBLANK_utf8_safe(s,e) \
631( ( LIKELY((e) > (s)) ) ? /* Machine generated */ \
632 ( ( 0x09 == ((const U8*)s)[0] || 0x20 == ((const U8*)s)[0] ) ? 1 \
633 : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \
634 ( ( 0xC2 == ((const U8*)s)[0] ) ? \
635 ( ( 0xA0 == ((const U8*)s)[1] ) ? 2 : 0 ) \
636 : ( 0xE1 == ((const U8*)s)[0] ) ? \
637 ( ( ( 0x9A == ((const U8*)s)[1] ) && ( 0x80 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
638 : ( 0xE2 == ((const U8*)s)[0] ) ? \
639 ( ( 0x80 == ((const U8*)s)[1] ) ? \
640 ( ( inRANGE(((const U8*)s)[2], 0x80, 0x8A ) || 0xAF == ((const U8*)s)[2] ) ? 3 : 0 )\
641 : ( ( 0x81 == ((const U8*)s)[1] ) && ( 0x9F == ((const U8*)s)[2] ) ) ? 3 : 0 )\
642 : ( ( ( 0xE3 == ((const U8*)s)[0] ) && ( 0x80 == ((const U8*)s)[1] ) ) && ( 0x80 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
643 : 0 ) \
644 : 0 )
645
646# elif 'A' == 193 && '^' == 95 /* EBCDIC 1047 */
647
648__UNDEFINED__ isBLANK_utf8_safe(s,e) \
649( ( LIKELY((e) > (s)) ) ? \
650 ( ( 0x05 == ((const U8*)s)[0] || 0x40 == ((const U8*)s)[0] ) ? 1 \
651 : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \
652 ( ( 0x80 == ((const U8*)s)[0] ) ? \
653 ( ( 0x41 == ((const U8*)s)[1] ) ? 2 : 0 ) \
654 : ( 0xBC == ((const U8*)s)[0] ) ? \
655 ( ( ( 0x63 == ((const U8*)s)[1] ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
656 : ( 0xCA == ((const U8*)s)[0] ) ? \
657 ( ( 0x41 == ((const U8*)s)[1] ) ? \
658 ( ( inRANGE(((const U8*)s)[2], 0x41, 0x4A ) || 0x51 == ((const U8*)s)[2] ) ? 3 : 0 )\
659 : ( 0x42 == ((const U8*)s)[1] ) ? \
660 ( ( 0x56 == ((const U8*)s)[2] ) ? 3 : 0 ) \
661 : ( ( 0x43 == ((const U8*)s)[1] ) && ( 0x73 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
662 : ( ( ( 0xCE == ((const U8*)s)[0] ) && ( 0x41 == ((const U8*)s)[1] ) ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
663 : 0 ) \
664: 0 )
665
666# elif 'A' == 193 && '^' == 176 /* EBCDIC 037 */
667
668__UNDEFINED__ isBLANK_utf8_safe(s,e) \
669( ( LIKELY((e) > (s)) ) ? \
670 ( ( 0x05 == ((const U8*)s)[0] || 0x40 == ((const U8*)s)[0] ) ? 1 \
671 : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \
672 ( ( 0x78 == ((const U8*)s)[0] ) ? \
673 ( ( 0x41 == ((const U8*)s)[1] ) ? 2 : 0 ) \
674 : ( 0xBD == ((const U8*)s)[0] ) ? \
675 ( ( ( 0x62 == ((const U8*)s)[1] ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
676 : ( 0xCA == ((const U8*)s)[0] ) ? \
677 ( ( 0x41 == ((const U8*)s)[1] ) ? \
678 ( ( inRANGE(((const U8*)s)[2], 0x41, 0x4A ) || 0x51 == ((const U8*)s)[2] ) ? 3 : 0 )\
679 : ( 0x42 == ((const U8*)s)[1] ) ? \
680 ( ( 0x56 == ((const U8*)s)[2] ) ? 3 : 0 ) \
681 : ( ( 0x43 == ((const U8*)s)[1] ) && ( 0x72 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
682 : ( ( ( 0xCE == ((const U8*)s)[0] ) && ( 0x41 == ((const U8*)s)[1] ) ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
683 : 0 ) \
684: 0 )
685
686# else
687# error Unknown character set
688# endif
689
690__UNDEFINED__ isCNTRL_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, CNTRL)
691__UNDEFINED__ isDIGIT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, DIGIT)
692__UNDEFINED__ isGRAPH_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, GRAPH)
693# ifdef isIDCONT_utf8
694__UNDEFINED__ isIDCONT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, IDCONT)
695# else
696__UNDEFINED__ isIDCONT_utf8_safe(s,e) isWORDCHAR_utf8_safe(s,e)
697# endif
698
699__UNDEFINED__ isIDFIRST_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, IDFIRST)
700__UNDEFINED__ isLOWER_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, LOWER)
701__UNDEFINED__ isPRINT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, PRINT)
702
6ec3ee8f 703# undef isPSXSPC_utf8_safe /* Use the modern definition */
ab53572c
KW
704__UNDEFINED__ isPSXSPC_utf8_safe(s,e) isSPACE_utf8_safe(s,e)
705
706__UNDEFINED__ isPUNCT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, PUNCT)
707__UNDEFINED__ isSPACE_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, SPACE)
708__UNDEFINED__ isUPPER_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, UPPER)
709
710# ifdef isWORDCHAR_utf8
711__UNDEFINED__ isWORDCHAR_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, WORDCHAR)
712# else
713__UNDEFINED__ isWORDCHAR_utf8_safe(s,e) \
714 (isALPHANUMERIC_utf8_safe(s,e) || (*(s)) == '_')
715# endif
716
717/* This was broken before 5.12, and just use this instead of worrying about
718 * which releases the official works on */
719# if 'A' == 65
720__UNDEFINED__ isXDIGIT_utf8_safe(s,e) \
721( ( LIKELY((e) > (s)) ) ? \
722 ( ( inRANGE(((const U8*)s)[0], 0x30, 0x39 ) || inRANGE(((const U8*)s)[0], 0x41, 0x46 ) || inRANGE(((const U8*)s)[0], 0x61, 0x66 ) ) ? 1\
723 : ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xEF == ((const U8*)s)[0] ) ) ? ( ( 0xBC == ((const U8*)s)[1] ) ?\
724 ( ( inRANGE(((const U8*)s)[2], 0x90, 0x99 ) || inRANGE(((const U8*)s)[2], 0xA1, 0xA6 ) ) ? 3 : 0 )\
725 : ( ( 0xBD == ((const U8*)s)[1] ) && ( inRANGE(((const U8*)s)[2], 0x81, 0x86 ) ) ) ? 3 : 0 ) : 0 )\
726: 0 )
727
728# elif 'A' == 193 && '^' == 95 /* EBCDIC 1047 */
729
730__UNDEFINED__ isXDIGIT_utf8_safe(s,e) \
731( ( LIKELY((e) > (s)) ) ? \
732 ( ( inRANGE(((const U8*)s)[0], 0x81, 0x86 ) || inRANGE(((const U8*)s)[0], 0xC1, 0xC6 ) || inRANGE(((const U8*)s)[0], 0xF0, 0xF9 ) ) ? 1\
733 : ( ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xDD == ((const U8*)s)[0] ) ) && ( 0x73 == ((const U8*)s)[1] ) ) ? ( ( 0x67 == ((const U8*)s)[2] ) ?\
734 ( ( inRANGE(((const U8*)s)[3], 0x57, 0x59 ) || inRANGE(((const U8*)s)[3], 0x62, 0x68 ) ) ? 4 : 0 )\
735 : ( ( inRANGE(((const U8*)s)[2], 0x68, 0x69 ) ) && ( inRANGE(((const U8*)s)[3], 0x42, 0x47 ) ) ) ? 4 : 0 ) : 0 )\
736: 0 )
737
738# elif 'A' == 193 && '^' == 176 /* EBCDIC 037 */
739
740__UNDEFINED__ isXDIGIT_utf8_safe(s,e) \
741( ( LIKELY((e) > (s)) ) ? \
742 ( ( inRANGE(((const U8*)s)[0], 0x81, 0x86 ) || inRANGE(((const U8*)s)[0], 0xC1, 0xC6 ) || inRANGE(((const U8*)s)[0], 0xF0, 0xF9 ) ) ? 1\
743 : ( ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xDD == ((const U8*)s)[0] ) ) && ( 0x72 == ((const U8*)s)[1] ) ) ? ( ( 0x66 == ((const U8*)s)[2] ) ?\
744 ( ( inRANGE(((const U8*)s)[3], 0x57, 0x59 ) || 0x5F == ((const U8*)s)[3] || inRANGE(((const U8*)s)[3], 0x62, 0x67 ) ) ? 4 : 0 )\
745 : ( ( inRANGE(((const U8*)s)[2], 0x67, 0x68 ) ) && ( inRANGE(((const U8*)s)[3], 0x42, 0x47 ) ) ) ? 4 : 0 ) : 0 )\
746: 0 )
747
748# else
749# error Unknown character set
750# endif
751#endif
752
753
ea4b7f32
JH
754/* Until we figure out how to support this in older perls... */
755#if { VERSION >= 5.8.0 }
756
757__UNDEFINED__ HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \
758 SvUTF8(HeKEY_sv(he)) : \
759 (U32)HeKUTF8(he))
760
761#endif
762
94e22bd6
MH
763__UNDEFINED__ C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0]))
764__UNDEFINED__ C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a))
765
72ec356a
KW
766__UNDEFINED__ LIKELY(x) (x)
767__UNDEFINED__ UNLIKELY(x) (x)
768
58329f0d
S
769#ifndef MUTABLE_PTR
770#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
771# define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
772#else
773# define MUTABLE_PTR(p) ((void *) (p))
774#endif
775#endif
776
777__UNDEFINED__ MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p))
778
9132e1a3
MHM
779=xsmisc
780
8565c31a
MHM
781typedef XSPROTO(XSPROTO_test_t);
782typedef XSPROTO_test_t *XSPROTO_test_t_ptr;
783
9132e1a3
MHM
784XS(XS_Devel__PPPort_dXSTARG); /* prototype */
785XS(XS_Devel__PPPort_dXSTARG)
786{
787 dXSARGS;
788 dXSTARG;
2dd69576 789 IV iv;
e7368224
MH
790
791 PERL_UNUSED_VAR(cv);
9132e1a3 792 SP -= items;
2dd69576 793 iv = SvIV(ST(0)) + 1;
9132e1a3
MHM
794 PUSHi(iv);
795 XSRETURN(1);
796}
797
0d0f8426
MHM
798XS(XS_Devel__PPPort_dAXMARK); /* prototype */
799XS(XS_Devel__PPPort_dAXMARK)
800{
801 dSP;
802 dAXMARK;
803 dITEMS;
804 IV iv;
e7368224
MH
805
806 PERL_UNUSED_VAR(cv);
0d0f8426
MHM
807 SP -= items;
808 iv = SvIV(ST(0)) - 1;
c1a049cb 809 mPUSHi(iv);
0d0f8426
MHM
810 XSRETURN(1);
811}
812
9132e1a3
MHM
813=xsboot
814
8565c31a
MHM
815{
816 XSPROTO_test_t_ptr p = &XS_Devel__PPPort_dXSTARG;
817 newXS("Devel::PPPort::dXSTARG", *p, file);
818}
0d0f8426 819newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);
9132e1a3 820
adfe19db
MHM
821=xsubs
822
823int
94e22bd6
MH
824OpSIBLING_tests()
825 PREINIT:
826 OP *x;
827 OP *kid;
65d1a6da 828 OP *middlekid;
94e22bd6
MH
829 OP *lastkid;
830 int count = 0;
831 int failures = 0;
832 int i;
833 CODE:
834 x = newOP(OP_PUSHMARK, 0);
835
836 /* No siblings yet! */
837 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
838 failures++; warn("Op should not have had a sib");
839 }
840
841
842 /* Add 2 siblings */
843 kid = x;
844
845 for (i = 0; i < 2; i++) {
846 OP *newsib = newOP(OP_PUSHMARK, 0);
847 OpMORESIB_set(kid, newsib);
848
849 kid = OpSIBLING(kid);
850 lastkid = kid;
851 }
65d1a6da 852 middlekid = OpSIBLING(x);
94e22bd6
MH
853
854 /* Should now have a sibling */
855 if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) {
856 failures++; warn("Op should have had a sib after moresib_set");
857 }
858
859 /* Count the siblings */
860 for (kid = OpSIBLING(x); kid; kid = OpSIBLING(kid)) {
861 count++;
862 }
863
864 if (count != 2) {
865 failures++; warn("Kid had %d sibs, expected 2", count);
866 }
867
868 if (OpHAS_SIBLING(lastkid) || OpSIBLING(lastkid)) {
869 failures++; warn("Last kid should not have a sib");
870 }
871
872 /* Really sets the parent, and says 'no more siblings' */
873 OpLASTSIB_set(x, lastkid);
874
875 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
876 failures++; warn("OpLASTSIB_set failed?");
877 }
878
879 /* Restore the kid */
880 OpMORESIB_set(x, lastkid);
881
882 /* Try to remove it again */
883 OpLASTSIB_set(x, NULL);
884
885 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
886 failures++; warn("OpLASTSIB_set with NULL failed?");
887 }
888
889 /* Try to restore with maybesib_set */
890 OpMAYBESIB_set(x, lastkid, NULL);
891
892 if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) {
893 failures++; warn("Op should have had a sib after maybesibset");
894 }
895
65d1a6da
DM
896 op_free(lastkid);
897 op_free(middlekid);
898 op_free(x);
94e22bd6
MH
899 RETVAL = failures;
900 OUTPUT:
901 RETVAL
902
903int
904SvRXOK(sv)
905 SV *sv
906 CODE:
907 RETVAL = SvRXOK(sv);
908 OUTPUT:
909 RETVAL
910
911int
7bb03b24 912ptrtests()
b2049988
MHM
913 PREINIT:
914 int var, *p = &var;
7bb03b24 915
b2049988
MHM
916 CODE:
917 RETVAL = 0;
918 RETVAL += PTR2nat(p) != 0 ? 1 : 0;
919 RETVAL += PTR2ul(p) != 0UL ? 2 : 0;
920 RETVAL += PTR2UV(p) != (UV) 0 ? 4 : 0;
921 RETVAL += PTR2IV(p) != (IV) 0 ? 8 : 0;
922 RETVAL += PTR2NV(p) != (NV) 0 ? 16 : 0;
923 RETVAL += p > NUM2PTR(int *, 0) ? 32 : 0;
7bb03b24 924
b2049988
MHM
925 OUTPUT:
926 RETVAL
7bb03b24
MHM
927
928int
adfe19db 929gv_stashpvn(name, create)
b2049988
MHM
930 char *name
931 I32 create
932 CODE:
933 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
934 OUTPUT:
935 RETVAL
adfe19db
MHM
936
937int
938get_sv(name, create)
b2049988
MHM
939 char *name
940 I32 create
941 CODE:
942 RETVAL = get_sv(name, create) != NULL;
943 OUTPUT:
944 RETVAL
adfe19db
MHM
945
946int
947get_av(name, create)
b2049988
MHM
948 char *name
949 I32 create
950 CODE:
951 RETVAL = get_av(name, create) != NULL;
952 OUTPUT:
953 RETVAL
adfe19db
MHM
954
955int
956get_hv(name, create)
b2049988
MHM
957 char *name
958 I32 create
959 CODE:
960 RETVAL = get_hv(name, create) != NULL;
961 OUTPUT:
962 RETVAL
adfe19db
MHM
963
964int
965get_cv(name, create)
b2049988
MHM
966 char *name
967 I32 create
968 CODE:
969 RETVAL = get_cv(name, create) != NULL;
970 OUTPUT:
971 RETVAL
adfe19db
MHM
972
973void
0d0f8426 974xsreturn(two)
b2049988
MHM
975 int two
976 PPCODE:
977 mXPUSHp("test1", 5);
978 if (two)
979 mXPUSHp("test2", 5);
980 if (two)
981 XSRETURN(2);
982 else
983 XSRETURN(1);
0d0f8426 984
adfe19db
MHM
985SV*
986boolSV(value)
b2049988
MHM
987 int value
988 CODE:
989 RETVAL = newSVsv(boolSV(value));
990 OUTPUT:
991 RETVAL
adfe19db
MHM
992
993SV*
994DEFSV()
b2049988
MHM
995 CODE:
996 RETVAL = newSVsv(DEFSV);
997 OUTPUT:
998 RETVAL
adfe19db 999
51d6c659
MHM
1000void
1001DEFSV_modify()
b2049988
MHM
1002 PPCODE:
1003 XPUSHs(sv_mortalcopy(DEFSV));
1004 ENTER;
1005 SAVE_DEFSV;
1006 DEFSV_set(newSVpvs("DEFSV"));
1007 XPUSHs(sv_mortalcopy(DEFSV));
1008 /* Yes, this leaks the above scalar; 5.005 with threads for some reason */
1009 /* frees it upon LEAVE, thus mortalizing it causes "attempt to free..." */
1010 /* sv_2mortal(DEFSV); */
1011 LEAVE;
1012 XPUSHs(sv_mortalcopy(DEFSV));
1013 XSRETURN(3);
51d6c659 1014
adfe19db
MHM
1015int
1016ERRSV()
b2049988 1017 CODE:
f1305528 1018 RETVAL = SvTRUEx(ERRSV);
b2049988
MHM
1019 OUTPUT:
1020 RETVAL
adfe19db
MHM
1021
1022SV*
1023UNDERBAR()
b2049988
MHM
1024 CODE:
1025 {
1026 dUNDERBAR;
1027 RETVAL = newSVsv(UNDERBAR);
1028 }
1029 OUTPUT:
1030 RETVAL
adfe19db 1031
0d0f8426
MHM
1032void
1033prepush()
b2049988
MHM
1034 CODE:
1035 {
1036 dXSTARG;
1037 XSprePUSH;
1038 PUSHi(42);
1039 XSRETURN(1);
1040 }
0d0f8426 1041
f2ab5a41
MHM
1042int
1043PERL_ABS(a)
b2049988 1044 int a
f2ab5a41
MHM
1045
1046void
1047SVf(x)
b2049988
MHM
1048 SV *x
1049 PPCODE:
f2ab5a41 1050#if { VERSION >= 5.004 }
71d5fd3c 1051 x = sv_2mortal(newSVpvf("[%" SVf "]", SVfARG(x)));
f2ab5a41 1052#endif
b2049988
MHM
1053 XPUSHs(x);
1054 XSRETURN(1);
f2ab5a41 1055
fd7af155
MHM
1056void
1057Perl_ppaddr_t(string)
b2049988
MHM
1058 char *string
1059 PREINIT:
1060 Perl_ppaddr_t lower;
1061 PPCODE:
1062 lower = PL_ppaddr[OP_LC];
1063 mXPUSHs(newSVpv(string, 0));
1064 PUTBACK;
1065 ENTER;
1066 (void)*(lower)(aTHXR);
1067 SPAGAIN;
1068 LEAVE;
1069 XSRETURN(1);
fd7af155 1070
ea4b7f32
JH
1071#if { VERSION >= 5.8.0 }
1072
1073void
1074check_HeUTF8(utf8_key)
1075 SV *utf8_key;
1076 PREINIT:
1077 HV *hash;
1078 HE *ent;
1079 STRLEN klen;
1080 char *key;
1081 PPCODE:
1082 hash = newHV();
1083
1084 key = SvPV(utf8_key, klen);
1085 if (SvUTF8(utf8_key)) klen *= -1;
1086 hv_store(hash, key, klen, newSVpvs("string"), 0);
1087 hv_iterinit(hash);
1088 ent = hv_iternext(hash);
94e22bd6
MH
1089 assert(ent);
1090 mXPUSHp((HeUTF8(ent) == 0 ? "norm" : "utf8"), 4);
ea4b7f32
JH
1091 hv_undef(hash);
1092
1093
1094#endif
1095
94e22bd6
MH
1096void
1097check_c_array()
1098 PREINIT:
1099 int x[] = { 10, 11, 12, 13 };
1100 PPCODE:
1101 mXPUSHi(C_ARRAY_LENGTH(x)); /* 4 */
1102 mXPUSHi(*(C_ARRAY_END(x)-1)); /* 13 */
1103
9dc2cc38 1104bool
db834d60 1105isBLANK(ord)
9aa6a863 1106 UV ord
9dc2cc38
KW
1107 CODE:
1108 RETVAL = isBLANK(ord);
1109 OUTPUT:
1110 RETVAL
1111
1112bool
db834d60 1113isBLANK_A(ord)
9aa6a863 1114 UV ord
9dc2cc38
KW
1115 CODE:
1116 RETVAL = isBLANK_A(ord);
1117 OUTPUT:
1118 RETVAL
1119
1120bool
876aded1
KW
1121isBLANK_L1(ord)
1122 UV ord
1123 CODE:
1124 RETVAL = isBLANK_L1(ord);
1125 OUTPUT:
1126 RETVAL
1127
1128bool
db834d60 1129isUPPER(ord)
9aa6a863 1130 UV ord
9dc2cc38
KW
1131 CODE:
1132 RETVAL = isUPPER(ord);
1133 OUTPUT:
1134 RETVAL
1135
1136bool
db834d60 1137isUPPER_A(ord)
9aa6a863 1138 UV ord
9dc2cc38
KW
1139 CODE:
1140 RETVAL = isUPPER_A(ord);
1141 OUTPUT:
1142 RETVAL
1143
1144bool
876aded1
KW
1145isUPPER_L1(ord)
1146 UV ord
1147 CODE:
1148 RETVAL = isUPPER_L1(ord);
1149 OUTPUT:
1150 RETVAL
1151
1152bool
db834d60 1153isLOWER(ord)
9aa6a863 1154 UV ord
9dc2cc38
KW
1155 CODE:
1156 RETVAL = isLOWER(ord);
1157 OUTPUT:
1158 RETVAL
1159
1160bool
db834d60 1161isLOWER_A(ord)
9aa6a863 1162 UV ord
9dc2cc38
KW
1163 CODE:
1164 RETVAL = isLOWER_A(ord);
1165 OUTPUT:
1166 RETVAL
1167
1168bool
876aded1
KW
1169isLOWER_L1(ord)
1170 UV ord
1171 CODE:
1172 RETVAL = isLOWER_L1(ord);
1173 OUTPUT:
1174 RETVAL
1175
1176bool
db834d60 1177isALPHA(ord)
9aa6a863 1178 UV ord
9dc2cc38
KW
1179 CODE:
1180 RETVAL = isALPHA(ord);
1181 OUTPUT:
1182 RETVAL
1183
1184bool
db834d60 1185isALPHA_A(ord)
9aa6a863 1186 UV ord
9dc2cc38
KW
1187 CODE:
1188 RETVAL = isALPHA_A(ord);
1189 OUTPUT:
1190 RETVAL
1191
1192bool
876aded1
KW
1193isALPHA_L1(ord)
1194 UV ord
1195 CODE:
1196 RETVAL = isALPHA_L1(ord);
1197 OUTPUT:
1198 RETVAL
1199
1200bool
db834d60 1201isWORDCHAR(ord)
9aa6a863 1202 UV ord
9dc2cc38
KW
1203 CODE:
1204 RETVAL = isWORDCHAR(ord);
1205 OUTPUT:
1206 RETVAL
1207
1208bool
db834d60 1209isWORDCHAR_A(ord)
9aa6a863 1210 UV ord
9dc2cc38
KW
1211 CODE:
1212 RETVAL = isWORDCHAR_A(ord);
1213 OUTPUT:
1214 RETVAL
1215
1216bool
876aded1
KW
1217isWORDCHAR_L1(ord)
1218 UV ord
1219 CODE:
1220 RETVAL = isWORDCHAR_L1(ord);
1221 OUTPUT:
1222 RETVAL
1223
1224bool
db834d60 1225isALPHANUMERIC(ord)
9aa6a863 1226 UV ord
9dc2cc38
KW
1227 CODE:
1228 RETVAL = isALPHANUMERIC(ord);
1229 OUTPUT:
1230 RETVAL
1231
1232bool
db834d60 1233isALPHANUMERIC_A(ord)
9aa6a863 1234 UV ord
9dc2cc38
KW
1235 CODE:
1236 RETVAL = isALPHANUMERIC_A(ord);
1237 OUTPUT:
1238 RETVAL
1239
1240bool
db834d60 1241isALNUM(ord)
9aa6a863 1242 UV ord
9dc2cc38
KW
1243 CODE:
1244 RETVAL = isALNUM(ord);
1245 OUTPUT:
1246 RETVAL
1247
1248bool
db834d60 1249isALNUM_A(ord)
9aa6a863 1250 UV ord
9dc2cc38
KW
1251 CODE:
1252 RETVAL = isALNUM_A(ord);
1253 OUTPUT:
1254 RETVAL
1255
1256bool
db834d60 1257isDIGIT(ord)
9aa6a863 1258 UV ord
9dc2cc38
KW
1259 CODE:
1260 RETVAL = isDIGIT(ord);
1261 OUTPUT:
1262 RETVAL
1263
1264bool
db834d60 1265isDIGIT_A(ord)
9aa6a863 1266 UV ord
9dc2cc38
KW
1267 CODE:
1268 RETVAL = isDIGIT_A(ord);
1269 OUTPUT:
1270 RETVAL
1271
1272bool
db834d60 1273isOCTAL(ord)
9aa6a863 1274 UV ord
9dc2cc38
KW
1275 CODE:
1276 RETVAL = isOCTAL(ord);
1277 OUTPUT:
1278 RETVAL
1279
1280bool
db834d60 1281isOCTAL_A(ord)
9aa6a863 1282 UV ord
9dc2cc38
KW
1283 CODE:
1284 RETVAL = isOCTAL_A(ord);
1285 OUTPUT:
1286 RETVAL
1287
1288bool
db834d60 1289isIDFIRST(ord)
9aa6a863 1290 UV ord
9dc2cc38
KW
1291 CODE:
1292 RETVAL = isIDFIRST(ord);
1293 OUTPUT:
1294 RETVAL
1295
1296bool
db834d60 1297isIDFIRST_A(ord)
9aa6a863 1298 UV ord
9dc2cc38
KW
1299 CODE:
1300 RETVAL = isIDFIRST_A(ord);
1301 OUTPUT:
1302 RETVAL
1303
1304bool
db834d60 1305isIDCONT(ord)
9aa6a863 1306 UV ord
9dc2cc38
KW
1307 CODE:
1308 RETVAL = isIDCONT(ord);
1309 OUTPUT:
1310 RETVAL
1311
1312bool
db834d60 1313isIDCONT_A(ord)
9aa6a863 1314 UV ord
9dc2cc38
KW
1315 CODE:
1316 RETVAL = isIDCONT_A(ord);
1317 OUTPUT:
1318 RETVAL
1319
1320bool
db834d60 1321isSPACE(ord)
9aa6a863 1322 UV ord
9dc2cc38
KW
1323 CODE:
1324 RETVAL = isSPACE(ord);
1325 OUTPUT:
1326 RETVAL
1327
1328bool
db834d60 1329isSPACE_A(ord)
9aa6a863 1330 UV ord
9dc2cc38
KW
1331 CODE:
1332 RETVAL = isSPACE_A(ord);
1333 OUTPUT:
1334 RETVAL
1335
1336bool
db834d60 1337isASCII(ord)
9aa6a863 1338 UV ord
9dc2cc38
KW
1339 CODE:
1340 RETVAL = isASCII(ord);
1341 OUTPUT:
1342 RETVAL
1343
1344bool
db834d60 1345isASCII_A(ord)
9aa6a863 1346 UV ord
9dc2cc38
KW
1347 CODE:
1348 RETVAL = isASCII_A(ord);
1349 OUTPUT:
1350 RETVAL
1351
1352bool
db834d60 1353isCNTRL(ord)
9aa6a863 1354 UV ord
9dc2cc38
KW
1355 CODE:
1356 RETVAL = isCNTRL(ord);
1357 OUTPUT:
1358 RETVAL
1359
1360bool
db834d60 1361isCNTRL_A(ord)
9aa6a863 1362 UV ord
9dc2cc38
KW
1363 CODE:
1364 RETVAL = isCNTRL_A(ord);
1365 OUTPUT:
1366 RETVAL
1367
1368bool
db834d60 1369isPRINT(ord)
9aa6a863 1370 UV ord
9dc2cc38
KW
1371 CODE:
1372 RETVAL = isPRINT(ord);
1373 OUTPUT:
1374 RETVAL
1375
1376bool
db834d60 1377isPRINT_A(ord)
9aa6a863 1378 UV ord
9dc2cc38
KW
1379 CODE:
1380 RETVAL = isPRINT_A(ord);
1381 OUTPUT:
1382 RETVAL
1383
1384bool
db834d60 1385isGRAPH(ord)
9aa6a863 1386 UV ord
9dc2cc38
KW
1387 CODE:
1388 RETVAL = isGRAPH(ord);
1389 OUTPUT:
1390 RETVAL
1391
1392bool
db834d60 1393isGRAPH_A(ord)
9aa6a863 1394 UV ord
9dc2cc38
KW
1395 CODE:
1396 RETVAL = isGRAPH_A(ord);
1397 OUTPUT:
1398 RETVAL
1399
1400bool
db834d60 1401isPUNCT(ord)
9aa6a863 1402 UV ord
9dc2cc38
KW
1403 CODE:
1404 RETVAL = isPUNCT(ord);
1405 OUTPUT:
1406 RETVAL
1407
1408bool
db834d60 1409isPUNCT_A(ord)
9aa6a863 1410 UV ord
9dc2cc38
KW
1411 CODE:
1412 RETVAL = isPUNCT_A(ord);
1413 OUTPUT:
1414 RETVAL
1415
1416bool
db834d60 1417isXDIGIT(ord)
9aa6a863 1418 UV ord
9dc2cc38
KW
1419 CODE:
1420 RETVAL = isXDIGIT(ord);
1421 OUTPUT:
1422 RETVAL
1423
1424bool
db834d60 1425isXDIGIT_A(ord)
9aa6a863 1426 UV ord
9dc2cc38
KW
1427 CODE:
1428 RETVAL = isXDIGIT_A(ord);
1429 OUTPUT:
1430 RETVAL
1431
1432bool
db834d60 1433isPSXSPC(ord)
9aa6a863 1434 UV ord
9dc2cc38
KW
1435 CODE:
1436 RETVAL = isPSXSPC(ord);
1437 OUTPUT:
1438 RETVAL
1439
1440bool
db834d60 1441isPSXSPC_A(ord)
9aa6a863 1442 UV ord
9dc2cc38
KW
1443 CODE:
1444 RETVAL = isPSXSPC_A(ord);
1445 OUTPUT:
1446 RETVAL
1447
876aded1
KW
1448bool
1449isALPHANUMERIC_L1(ord)
1450 UV ord
1451 CODE:
1452 RETVAL = isALPHANUMERIC_L1(ord);
1453 OUTPUT:
1454 RETVAL
1455
1456bool
1457isALNUMC_L1(ord)
1458 UV ord
1459 CODE:
1460 RETVAL = isALNUMC_L1(ord);
1461 OUTPUT:
1462 RETVAL
1463
1464bool
1465isDIGIT_L1(ord)
1466 UV ord
1467 CODE:
1468 RETVAL = isDIGIT_L1(ord);
1469 OUTPUT:
1470 RETVAL
1471
1472bool
1473isOCTAL_L1(ord)
1474 UV ord
1475 CODE:
1476 RETVAL = isOCTAL_L1(ord);
1477 OUTPUT:
1478 RETVAL
1479
1480bool
1481isIDFIRST_L1(ord)
1482 UV ord
1483 CODE:
1484 RETVAL = isIDFIRST_L1(ord);
1485 OUTPUT:
1486 RETVAL
1487
1488bool
1489isIDCONT_L1(ord)
1490 UV ord
1491 CODE:
1492 RETVAL = isIDCONT_L1(ord);
1493 OUTPUT:
1494 RETVAL
1495
1496bool
1497isSPACE_L1(ord)
1498 UV ord
1499 CODE:
1500 RETVAL = isSPACE_L1(ord);
1501 OUTPUT:
1502 RETVAL
1503
1504bool
1505isASCII_L1(ord)
1506 UV ord
1507 CODE:
1508 RETVAL = isASCII_L1(ord);
1509 OUTPUT:
1510 RETVAL
1511
1512bool
1513isCNTRL_L1(ord)
1514 UV ord
1515 CODE:
1516 RETVAL = isCNTRL_L1(ord);
1517 OUTPUT:
1518 RETVAL
1519
1520bool
1521isPRINT_L1(ord)
1522 UV ord
1523 CODE:
1524 RETVAL = isPRINT_L1(ord);
1525 OUTPUT:
1526 RETVAL
1527
1528bool
1529isGRAPH_L1(ord)
1530 UV ord
1531 CODE:
1532 RETVAL = isGRAPH_L1(ord);
1533 OUTPUT:
1534 RETVAL
1535
1536bool
1537isPUNCT_L1(ord)
1538 UV ord
1539 CODE:
1540 RETVAL = isPUNCT_L1(ord);
1541 OUTPUT:
1542 RETVAL
1543
1544bool
1545isXDIGIT_L1(ord)
1546 UV ord
1547 CODE:
1548 RETVAL = isXDIGIT_L1(ord);
1549 OUTPUT:
1550 RETVAL
1551
1552bool
1553isPSXSPC_L1(ord)
1554 UV ord
1555 CODE:
1556 RETVAL = isPSXSPC_L1(ord);
1557 OUTPUT:
1558 RETVAL
1559
ab53572c
KW
1560#if { VERSION >= 5.006 }
1561
1562bool
1563isALPHA_utf8_safe(s, offset)
1564 unsigned char * s
1565 int offset
1566 CODE:
1567 RETVAL = isALPHA_utf8_safe(s, s + UTF8SKIP(s) + offset);
1568 OUTPUT:
1569 RETVAL
1570
1571bool
1572isALPHANUMERIC_utf8_safe(s, offset)
1573 unsigned char * s
1574 int offset
1575 CODE:
1576 RETVAL = isALPHANUMERIC_utf8_safe(s, s + UTF8SKIP(s) + offset);
1577 OUTPUT:
1578 RETVAL
1579
1580bool
1581isASCII_utf8_safe(s, offset)
1582 unsigned char * s
1583 int offset
1584 CODE:
1585 RETVAL = isASCII_utf8_safe(s, s + UTF8SKIP(s) + offset);
1586 OUTPUT:
1587 RETVAL
1588
1589bool
1590isBLANK_utf8_safe(s, offset)
1591 unsigned char * s
1592 int offset
1593 CODE:
1594 RETVAL = isBLANK_utf8_safe(s, s + UTF8SKIP(s) + offset);
1595 OUTPUT:
1596 RETVAL
1597
1598bool
1599isCNTRL_utf8_safe(s, offset)
1600 unsigned char * s
1601 int offset
1602 CODE:
1603 RETVAL = isCNTRL_utf8_safe(s, s + UTF8SKIP(s) + offset);
1604 OUTPUT:
1605 RETVAL
1606
1607bool
1608isDIGIT_utf8_safe(s, offset)
1609 unsigned char * s
1610 int offset
1611 CODE:
1612 RETVAL = isDIGIT_utf8_safe(s, s + UTF8SKIP(s) + offset);
1613 OUTPUT:
1614 RETVAL
1615
1616bool
1617isGRAPH_utf8_safe(s, offset)
1618 unsigned char * s
1619 int offset
1620 CODE:
1621 RETVAL = isGRAPH_utf8_safe(s, s + UTF8SKIP(s) + offset);
1622 OUTPUT:
1623 RETVAL
1624
1625bool
1626isIDCONT_utf8_safe(s, offset)
1627 unsigned char * s
1628 int offset
1629 CODE:
1630 RETVAL = isIDCONT_utf8_safe(s, s + UTF8SKIP(s) + offset);
1631 OUTPUT:
1632 RETVAL
1633
1634bool
1635isIDFIRST_utf8_safe(s, offset)
1636 unsigned char * s
1637 int offset
1638 CODE:
1639 RETVAL = isIDFIRST_utf8_safe(s, s + UTF8SKIP(s) + offset);
1640 OUTPUT:
1641 RETVAL
1642
1643bool
1644isLOWER_utf8_safe(s, offset)
1645 unsigned char * s
1646 int offset
1647 CODE:
1648 RETVAL = isLOWER_utf8_safe(s, s + UTF8SKIP(s) + offset);
1649 OUTPUT:
1650 RETVAL
1651
1652bool
1653isPRINT_utf8_safe(s, offset)
1654 unsigned char * s
1655 int offset
1656 CODE:
1657 RETVAL = isPRINT_utf8_safe(s, s + UTF8SKIP(s) + offset);
1658 OUTPUT:
1659 RETVAL
1660
1661bool
1662isPSXSPC_utf8_safe(s, offset)
1663 unsigned char * s
1664 int offset
1665 CODE:
1666 RETVAL = isPSXSPC_utf8_safe(s, s + UTF8SKIP(s) + offset);
1667 OUTPUT:
1668 RETVAL
1669
1670bool
1671isPUNCT_utf8_safe(s, offset)
1672 unsigned char * s
1673 int offset
1674 CODE:
1675 RETVAL = isPUNCT_utf8_safe(s, s + UTF8SKIP(s) + offset);
1676 OUTPUT:
1677 RETVAL
1678
1679bool
1680isSPACE_utf8_safe(s, offset)
1681 unsigned char * s
1682 int offset
1683 CODE:
1684 RETVAL = isSPACE_utf8_safe(s, s + UTF8SKIP(s) + offset);
1685 OUTPUT:
1686 RETVAL
1687
1688bool
1689isUPPER_utf8_safe(s, offset)
1690 unsigned char * s
1691 int offset
1692 CODE:
1693 RETVAL = isUPPER_utf8_safe(s, s + UTF8SKIP(s) + offset);
1694 OUTPUT:
1695 RETVAL
1696
1697bool
1698isWORDCHAR_utf8_safe(s, offset)
1699 unsigned char * s
1700 int offset
1701 CODE:
1702 RETVAL = isWORDCHAR_utf8_safe(s, s + UTF8SKIP(s) + offset);
1703 OUTPUT:
1704 RETVAL
1705
1706bool
1707isXDIGIT_utf8_safe(s, offset)
1708 unsigned char * s
1709 int offset
1710 CODE:
1711 RETVAL = isXDIGIT_utf8_safe(s, s + UTF8SKIP(s) + offset);
1712 OUTPUT:
1713 RETVAL
1714
1715#endif
1716
92c5e9fa
KW
1717UV
1718LATIN1_TO_NATIVE(cp)
1719 UV cp
1720 CODE:
1721 if (cp > 255) RETVAL= cp;
1722 else RETVAL= LATIN1_TO_NATIVE(cp);
1723 OUTPUT:
1724 RETVAL
1725
1726UV
1727NATIVE_TO_LATIN1(cp)
1728 UV cp
1729 CODE:
1730 RETVAL= NATIVE_TO_LATIN1(cp);
1731 OUTPUT:
1732 RETVAL
1733
1eff2a3b
KW
1734STRLEN
1735av_tindex(av)
9aa6a863 1736 SV *av
1eff2a3b 1737 CODE:
9aa6a863 1738 RETVAL = av_tindex((AV*)SvRV(av));
1eff2a3b
KW
1739 OUTPUT:
1740 RETVAL
1741
1742STRLEN
1743av_top_index(av)
9aa6a863 1744 SV *av
1eff2a3b 1745 CODE:
9aa6a863 1746 RETVAL = av_top_index((AV*)SvRV(av));
1eff2a3b
KW
1747 OUTPUT:
1748 RETVAL
1749
ab53572c 1750=tests plan => 17678
adfe19db
MHM
1751
1752use vars qw($my_sv @my_av %my_hv);
1753
adfe19db
MHM
1754ok(&Devel::PPPort::boolSV(1));
1755ok(!&Devel::PPPort::boolSV(0));
1756
1757$_ = "Fred";
1758ok(&Devel::PPPort::DEFSV(), "Fred");
1759ok(&Devel::PPPort::UNDERBAR(), "Fred");
1760
f551177d 1761if ("$]" >= 5.009002 && "$]" < 5.023 && "$]" < 5.023004) {
0d0f8426 1762 eval q{
b2049988 1763 no warnings "deprecated";
e5b2cbd0 1764 no if $^V > v5.17.9, warnings => "experimental::lexical_topic";
0d0f8426
MHM
1765 my $_ = "Tony";
1766 ok(&Devel::PPPort::DEFSV(), "Fred");
1767 ok(&Devel::PPPort::UNDERBAR(), "Tony");
1768 };
1769}
1770else {
1771 ok(1);
1772 ok(1);
1773}
1774
51d6c659
MHM
1775my @r = &Devel::PPPort::DEFSV_modify();
1776
1777ok(@r == 3);
1778ok($r[0], 'Fred');
1779ok($r[1], 'DEFSV');
1780ok($r[2], 'Fred');
1781
1782ok(&Devel::PPPort::DEFSV(), "Fred");
1783
adfe19db
MHM
1784eval { 1 };
1785ok(!&Devel::PPPort::ERRSV());
1786eval { cannot_call_this_one() };
1787ok(&Devel::PPPort::ERRSV());
1788
1789ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
1790ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
1791ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
1792
1793$my_sv = 1;
1794ok(&Devel::PPPort::get_sv('my_sv', 0));
1795ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
1796ok(&Devel::PPPort::get_sv('not_my_sv', 1));
1797
1798@my_av = (1);
1799ok(&Devel::PPPort::get_av('my_av', 0));
1800ok(!&Devel::PPPort::get_av('not_my_av', 0));
1801ok(&Devel::PPPort::get_av('not_my_av', 1));
1802
1803%my_hv = (a=>1);
1804ok(&Devel::PPPort::get_hv('my_hv', 0));
1805ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
1806ok(&Devel::PPPort::get_hv('not_my_hv', 1));
1807
1808sub my_cv { 1 };
1809ok(&Devel::PPPort::get_cv('my_cv', 0));
1810ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
1811ok(&Devel::PPPort::get_cv('not_my_cv', 1));
1812
9132e1a3 1813ok(Devel::PPPort::dXSTARG(42), 43);
0d0f8426
MHM
1814ok(Devel::PPPort::dAXMARK(4711), 4710);
1815
1816ok(Devel::PPPort::prepush(), 42);
9132e1a3 1817
0d0f8426
MHM
1818ok(join(':', Devel::PPPort::xsreturn(0)), 'test1');
1819ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2');
f2ab5a41
MHM
1820
1821ok(Devel::PPPort::PERL_ABS(42), 42);
1822ok(Devel::PPPort::PERL_ABS(-13), 13);
1823
f551177d
S
1824ok(Devel::PPPort::SVf(42), "$]" >= 5.004 ? '[42]' : '42');
1825ok(Devel::PPPort::SVf('abc'), "$]" >= 5.004 ? '[abc]' : 'abc');
f2ab5a41 1826
fd7af155
MHM
1827ok(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo");
1828
7bb03b24 1829ok(&Devel::PPPort::ptrtests(), 63);
ea4b7f32 1830
94e22bd6
MH
1831ok(&Devel::PPPort::OpSIBLING_tests(), 0);
1832
f551177d 1833if ("$]" >= 5.009000) {
ea4b7f32
JH
1834 eval q{
1835 ok(&Devel::PPPort::check_HeUTF8("hello"), "norm");
1836 ok(&Devel::PPPort::check_HeUTF8("\N{U+263a}"), "utf8");
1837 };
1838} else {
1839 ok(1, 1);
1840 ok(1, 1);
1841}
94e22bd6
MH
1842
1843@r = &Devel::PPPort::check_c_array();
1844ok($r[0], 4);
1845ok($r[1], "13");
1846
1847ok(!Devel::PPPort::SvRXOK(""));
1848ok(!Devel::PPPort::SvRXOK(bless [], "Regexp"));
1849
f551177d 1850if ("$]" < 5.005) {
94e22bd6
MH
1851 skip 'no qr// objects in this perl', 0;
1852 skip 'no qr// objects in this perl', 0;
1853} else {
1854 my $qr = eval 'qr/./';
1855 ok(Devel::PPPort::SvRXOK($qr));
1856 ok(Devel::PPPort::SvRXOK(bless $qr, "Surprise"));
1857}
9dc2cc38 1858
92c5e9fa
KW
1859ok( Devel::PPPort::NATIVE_TO_LATIN1(0xB6) == 0xB6);
1860ok( Devel::PPPort::NATIVE_TO_LATIN1(0x1) == 0x1);
1861ok( Devel::PPPort::NATIVE_TO_LATIN1(ord("A")) == 0x41);
1862ok( Devel::PPPort::NATIVE_TO_LATIN1(ord("0")) == 0x30);
1863
92c5e9fa
KW
1864ok( Devel::PPPort::LATIN1_TO_NATIVE(0xB6) == 0xB6);
1865if (ord("A") == 65) {
1866 ok( Devel::PPPort::LATIN1_TO_NATIVE(0x41) == 0x41);
1867 ok( Devel::PPPort::LATIN1_TO_NATIVE(0x30) == 0x30);
1868}
1869else {
1870 ok( Devel::PPPort::LATIN1_TO_NATIVE(0x41) == 0xC1);
1871 ok( Devel::PPPort::LATIN1_TO_NATIVE(0x30) == 0xF0);
1872}
1873
876aded1
KW
1874ok( Devel::PPPort::isALNUMC_L1(ord("5")));
1875ok( Devel::PPPort::isALNUMC_L1(0xFC));
1876ok(! Devel::PPPort::isALNUMC_L1(0xB6));
1877
db834d60
KW
1878ok( Devel::PPPort::isOCTAL(ord("7")));
1879ok(! Devel::PPPort::isOCTAL(ord("8")));
9dc2cc38 1880
db834d60
KW
1881ok( Devel::PPPort::isOCTAL_A(ord("0")));
1882ok(! Devel::PPPort::isOCTAL_A(ord("9")));
9dc2cc38 1883
876aded1
KW
1884ok( Devel::PPPort::isOCTAL_L1(ord("2")));
1885ok(! Devel::PPPort::isOCTAL_L1(ord("8")));
1886
ab53572c
KW
1887# For the other properties, we test every code point from 0.255, and a
1888# smattering of higher ones. First populate a hash with keys like '65:ALPHA'
1889# to indicate that the code point there is alphabetic
1890my $i;
1891my %types;
1892for $i (0x41..0x5A, 0x61..0x7A, 0xAA, 0xB5, 0xBA, 0xC0..0xD6, 0xD8..0xF6,
1893 0xF8..0x101)
1894{
1895 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i);
1896 $types{"$native:ALPHA"} = 1;
1897 $types{"$native:ALPHANUMERIC"} = 1;
1898 $types{"$native:IDFIRST"} = 1;
1899 $types{"$native:IDCONT"} = 1;
1900 $types{"$native:PRINT"} = 1;
1901 $types{"$native:WORDCHAR"} = 1;
1902}
1903for $i (0x30..0x39, 0x660, 0xFF19) {
1904 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i);
1905 $types{"$native:ALPHANUMERIC"} = 1;
1906 $types{"$native:DIGIT"} = 1;
1907 $types{"$native:IDCONT"} = 1;
1908 $types{"$native:WORDCHAR"} = 1;
1909 $types{"$native:GRAPH"} = 1;
1910 $types{"$native:PRINT"} = 1;
1911 $types{"$native:XDIGIT"} = 1 if $i < 255 || ($i >= 0xFF10 && $i <= 0xFF19);
1912}
9dc2cc38 1913
ab53572c
KW
1914for $i (0..0x7F) {
1915 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i);
1916 $types{"$native:ASCII"} = 1;
876aded1 1917}
ab53572c
KW
1918for $i (0..0x1f, 0x7F..0x9F) {
1919 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i);
1920 $types{"$native:CNTRL"} = 1;
876aded1 1921}
ab53572c
KW
1922for $i (0x21..0x7E, 0xA1..0x101, 0x660) {
1923 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i);
1924 $types{"$native:GRAPH"} = 1;
1925 $types{"$native:PRINT"} = 1;
1926}
1927for $i (0x09, 0x20, 0xA0) {
1928 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i);
1929 $types{"$native:BLANK"} = 1;
1930 $types{"$native:SPACE"} = 1;
1931 $types{"$native:PSXSPC"} = 1;
1932 $types{"$native:PRINT"} = 1 if $i > 0x09;
1933}
1934for $i (0x09..0x0D, 0x85, 0x2029) {
1935 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i);
1936 $types{"$native:SPACE"} = 1;
1937 $types{"$native:PSXSPC"} = 1;
1938}
1939for $i (0x41..0x5A, 0xC0..0xD6, 0xD8..0xDE, 0x100) {
1940 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i);
1941 $types{"$native:UPPER"} = 1;
1942 $types{"$native:XDIGIT"} = 1 if $i < 0x47;
1943}
1944for $i (0x61..0x7A, 0xAA, 0xB5, 0xBA, 0xDF..0xF6, 0xF8..0xFF, 0x101) {
1945 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i);
1946 $types{"$native:LOWER"} = 1;
1947 $types{"$native:XDIGIT"} = 1 if $i < 0x67;
1948}
1949for $i (0x21..0x2F, 0x3A..0x40, 0x5B..0x60, 0x7B..0x7E, 0xB6, 0xA1, 0xA7, 0xAB,
1950 0xB7, 0xBB, 0xBF, 0x5BE)
1951{
1952 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i);
1953 $types{"$native:PUNCT"} = 1;
1954 $types{"$native:GRAPH"} = 1;
1955 $types{"$native:PRINT"} = 1;
876aded1
KW
1956}
1957
ab53572c
KW
1958$i = ord('_');
1959$types{"$i:WORDCHAR"} = 1;
1960$types{"$i:IDFIRST"} = 1;
1961$types{"$i:IDCONT"} = 1;
1962
1963# Now find all the unique code points included above.
1964my %code_points_to_test;
1965my $key;
1966for $key (keys %types) {
1967 $key =~ s/:.*//;
1968 $code_points_to_test{$key} = 1;
1969}
1eff2a3b 1970
ab53572c
KW
1971# And test each one
1972for $i (sort { $a <=> $b } keys %code_points_to_test) {
1973 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i);
1974 my $hex = sprintf("0x%02X", $native);
1975
1976 # And for each code point test each of the classes
1977 my $class;
1978 for $class (qw(ALPHA ALPHANUMERIC ASCII BLANK CNTRL DIGIT GRAPH IDCONT
1979 IDFIRST LOWER PRINT PSXSPC PUNCT SPACE UPPER WORDCHAR
1980 XDIGIT))
1981 {
1982 if ($i < 256) { # For the ones that can fit in a byte, test each of
1983 #three macros.
1984 my $suffix;
1985 for $suffix ("", "_A", "_L1") {
1986 my $should_be = ($i > 0x7F && $suffix ne "_L1")
1987 ? 0 # Fail on non-ASCII unless L1
1988 : ($types{"$native:$class"} || 0);
1989 my $eval_string = "Devel::PPPort::is${class}$suffix($hex)";
1990 my $is = eval $eval_string || 0;
1991 die "eval 'For $i: $eval_string' gave $@" if $@;
1992 ok($is, $should_be, "'$eval_string'");
1993 }
1994 }
1995
1996 # For all code points, test the '_utf8' macros
1997 if ("$]" < 5.006) {
1998 skip("No UTF-8 on this perl", 0);
1999 if ($i > 255) {
2000 skip("No UTF-8 on this perl", 0);
2001 }
2002 }
2003 else {
2004 my $utf8 = quotemeta Devel::PPPort::uvoffuni_to_utf8($i);
2005 if ("$]" < 5.007 && $native > 255) {
2006 skip("Perls earlier than 5.7 give wrong answers for above Latin1 code points", 0);
2007 }
2008 elsif ("$]" <= 5.011003 && $native == 0x2029 && ($class eq 'PRINT' || $class eq 'GRAPH')) {
2009 skip("Perls earlier than 5.11.3 considered high space characters as isPRINT and isGRAPH", 0);
2010 }
2011 else {
2012
2013 my $should_be = $types{"$native:$class"} || 0;
2014 my $eval_string = "Devel::PPPort::is${class}_utf8_safe(\"$utf8\", 0)";
2015 my $is = eval $eval_string || 0;
2016 die "eval 'For $i, $eval_string' gave $@" if $@;
2017 ok($is, $should_be, sprintf("For U+%04X '%s'", $native, $eval_string));
2018 }
2019
2020 # And for the high code points, test that a too short malformation (the
2021 # -1) causes it to fail
2022 if ($i > 255) {
2023 if ("$]" >= 5.025009) {
2024 skip("Prints an annoying error message that khw doesn't know how to easily suppress", 0);
2025 }
2026 else {
2027 my $eval_string = "Devel::PPPort::is${class}_utf8_safe(\"$utf8\", -1)";
2028 my $is = eval "no warnings; $eval_string" || 0;
2029 die "eval '$eval_string' gave $@" if $@;
2030 ok($is, 0, sprintf("For U+%04X '%s'", $native, $eval_string));
2031 }
2032 }
2033 }
2034 }
2035}
876aded1 2036
1eff2a3b
KW
2037ok(&Devel::PPPort::av_top_index([1,2,3]), 2);
2038ok(&Devel::PPPort::av_tindex([1,2,3,4]), 3);