This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
766e543b2fc003f2627c4e3375a49ba5393cda4d
[perl5.git] / dist / Devel-PPPort / parts / inc / misc
1 ################################################################################
2 ##
3 ##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
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__
15 END_EXTERN_C
16 EXTERN_C
17 INT2PTR
18 MUTABLE_PTR
19 NVTYPE
20 PERL_GCC_BRACE_GROUPS_FORBIDDEN
21 PERLIO_FUNCS_CAST
22 PERLIO_FUNCS_DECL
23 PERL_UNUSED_ARG
24 PERL_UNUSED_CONTEXT
25 PERL_UNUSED_DECL
26 PERL_UNUSED_RESULT
27 PERL_UNUSED_VAR
28 PERL_USE_GCC_BRACE_GROUPS
29 PTR2ul
30 PTRV
31 START_EXTERN_C
32 STMT_END
33 STMT_START
34 SvRX
35 WIDEST_UTYPE
36 XSRETURN
37
38 =implementation
39
40 __UNDEFINED__ cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0)
41 __UNDEFINED__ OpHAS_SIBLING(o)      (cBOOL((o)->op_sibling))
42 __UNDEFINED__ OpSIBLING(o)          (0 + (o)->op_sibling)
43 __UNDEFINED__ OpMORESIB_set(o, sib) ((o)->op_sibling = (sib))
44 __UNDEFINED__ OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL)
45 __UNDEFINED__ OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib))
46 __UNDEFINED__ HEf_SVKEY   -2
47
48 #if defined(DEBUGGING) && !defined(__COVERITY__)
49 __UNDEFINED__ __ASSERT_(statement)  assert(statement),
50 #else
51 __UNDEFINED__ __ASSERT_(statement)
52 #endif
53
54 __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)
55 __UNDEFINED__ SvRXOK(sv) (!!SvRX(sv))
56
57 #ifndef PERL_UNUSED_DECL
58 #  ifdef HASATTRIBUTE
59 #    if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
60 #      define PERL_UNUSED_DECL
61 #    else
62 #      define PERL_UNUSED_DECL __attribute__((unused))
63 #    endif
64 #  else
65 #    define PERL_UNUSED_DECL
66 #  endif
67 #endif
68
69 #ifndef PERL_UNUSED_ARG
70 #  if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
71 #    include <note.h>
72 #    define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
73 #  else
74 #    define PERL_UNUSED_ARG(x) ((void)x)
75 #  endif
76 #endif
77
78 #ifndef PERL_UNUSED_VAR
79 #  define PERL_UNUSED_VAR(x) ((void)x)
80 #endif
81
82 #ifndef PERL_UNUSED_CONTEXT
83 #  ifdef USE_ITHREADS
84 #    define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
85 #  else
86 #    define PERL_UNUSED_CONTEXT
87 #  endif
88 #endif
89
90 #ifndef PERL_UNUSED_RESULT
91 #  if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT)
92 #    define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END
93 #  else
94 #    define PERL_UNUSED_RESULT(v) ((void)(v))
95 #  endif
96 #endif
97
98 __UNDEFINED__  NOOP          /*EMPTY*/(void)0
99 __UNDEFINED__  dNOOP         extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL
100
101 #ifndef NVTYPE
102 #  if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
103 #    define NVTYPE long double
104 #  else
105 #    define NVTYPE double
106 #  endif
107 typedef NVTYPE NV;
108 #endif
109
110 #ifndef INT2PTR
111 #  if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
112 #    define PTRV                  UV
113 #    define INT2PTR(any,d)        (any)(d)
114 #  else
115 #    if PTRSIZE == LONGSIZE
116 #      define PTRV                unsigned long
117 #    else
118 #      define PTRV                unsigned
119 #    endif
120 #    define INT2PTR(any,d)        (any)(PTRV)(d)
121 #  endif
122 #endif
123
124 #ifndef PTR2ul
125 #  if PTRSIZE == LONGSIZE
126 #    define PTR2ul(p)     (unsigned long)(p)
127 #  else
128 #    define PTR2ul(p)     INT2PTR(unsigned long,p)
129 #  endif
130 #endif
131
132 __UNDEFINED__  PTR2nat(p)      (PTRV)(p)
133 __UNDEFINED__  NUM2PTR(any,d)  (any)PTR2nat(d)
134 __UNDEFINED__  PTR2IV(p)       INT2PTR(IV,p)
135 __UNDEFINED__  PTR2UV(p)       INT2PTR(UV,p)
136 __UNDEFINED__  PTR2NV(p)       NUM2PTR(NV,p)
137
138 #undef START_EXTERN_C
139 #undef END_EXTERN_C
140 #undef EXTERN_C
141 #ifdef __cplusplus
142 #  define START_EXTERN_C extern "C" {
143 #  define END_EXTERN_C }
144 #  define EXTERN_C extern "C"
145 #else
146 #  define START_EXTERN_C
147 #  define END_EXTERN_C
148 #  define EXTERN_C extern
149 #endif
150
151 #if { VERSION < 5.004 } || defined(PERL_GCC_PEDANTIC)
152 #  ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
153 #    define PERL_GCC_BRACE_GROUPS_FORBIDDEN
154 #  endif
155 #endif
156
157 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
158 #  ifndef PERL_USE_GCC_BRACE_GROUPS
159 #    define PERL_USE_GCC_BRACE_GROUPS
160 #  endif
161 #endif
162
163 #undef STMT_START
164 #undef STMT_END
165 #ifdef PERL_USE_GCC_BRACE_GROUPS
166 #  define STMT_START    (void)( /* gcc supports ``({ STATEMENTS; })'' */
167 #  define STMT_END      )
168 #else
169 #  if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
170 #    define STMT_START  if (1)
171 #    define STMT_END    else (void)0
172 #  else
173 #    define STMT_START  do
174 #    define STMT_END    while (0)
175 #  endif
176 #endif
177
178 __UNDEFINED__  boolSV(b)    ((b) ? &PL_sv_yes : &PL_sv_no)
179
180 /* DEFSV appears first in 5.004_56 */
181 __UNDEFINED__  DEFSV        GvSV(PL_defgv)
182 __UNDEFINED__  SAVE_DEFSV   SAVESPTR(GvSV(PL_defgv))
183 __UNDEFINED__  DEFSV_set(sv) (DEFSV = (sv))
184
185 /* Older perls (<=5.003) lack AvFILLp */
186 __UNDEFINED__  AvFILLp      AvFILL
187
188 __UNDEFINED__  av_tindex    AvFILL
189 __UNDEFINED__  av_top_index AvFILL
190
191 __UNDEFINED__  ERRSV        get_sv("@",FALSE)
192
193 /* Hint: gv_stashpvn
194  * This function's backport doesn't support the length parameter, but
195  * rather ignores it. Portability can only be ensured if the length
196  * parameter is used for speed reasons, but the length can always be
197  * correctly computed from the string argument.
198  */
199
200 __UNDEFINED__  gv_stashpvn(str,len,create)  gv_stashpv(str,create)
201
202 /* Replace: 1 */
203 __UNDEFINED__  get_cv          perl_get_cv
204 __UNDEFINED__  get_sv          perl_get_sv
205 __UNDEFINED__  get_av          perl_get_av
206 __UNDEFINED__  get_hv          perl_get_hv
207 /* Replace: 0 */
208
209 __UNDEFINED__  dUNDERBAR       dNOOP
210 __UNDEFINED__  UNDERBAR        DEFSV
211
212 __UNDEFINED__  dAX             I32 ax = MARK - PL_stack_base + 1
213 __UNDEFINED__  dITEMS          I32 items = SP - MARK
214
215 __UNDEFINED__  dXSTARG         SV * targ = sv_newmortal()
216
217 __UNDEFINED__  dAXMARK         I32 ax = POPMARK; \
218                                register SV ** const mark = PL_stack_base + ax++
219
220
221 __UNDEFINED__  XSprePUSH       (sp = PL_stack_base + ax - 1)
222
223 #if { VERSION < 5.005 }
224 #  undef XSRETURN
225 #  define XSRETURN(off)                                   \
226       STMT_START {                                        \
227           PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
228           return;                                         \
229       } STMT_END
230 #endif
231
232 __UNDEFINED__  XSPROTO(name)   void name(pTHX_ CV* cv)
233 __UNDEFINED__  SVfARG(p)       ((void*)(p))
234
235 __UNDEFINED__  PERL_ABS(x)     ((x) < 0 ? -(x) : (x))
236
237 __UNDEFINED__  dVAR            dNOOP
238
239 __UNDEFINED__  SVf             "_"
240
241 __UNDEFINED__  CPERLscope(x)   x
242
243 __UNDEFINED__  PERL_HASH(hash,str,len) \
244      STMT_START { \
245         const char *s_PeRlHaSh = str; \
246         I32 i_PeRlHaSh = len; \
247         U32 hash_PeRlHaSh = 0; \
248         while (i_PeRlHaSh--) \
249             hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
250         (hash) = hash_PeRlHaSh; \
251     } STMT_END
252
253 #ifndef PERLIO_FUNCS_DECL
254 # ifdef PERLIO_FUNCS_CONST
255 #  define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
256 #  define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
257 # else
258 #  define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
259 #  define PERLIO_FUNCS_CAST(funcs) (funcs)
260 # endif
261 #endif
262
263 /* provide these typedefs for older perls */
264 #if { VERSION < 5.9.3 }
265
266 # ifdef ARGSproto
267 typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto);
268 # else
269 typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
270 # endif
271
272 typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
273
274 #endif
275
276 #ifndef WIDEST_UTYPE
277 # ifdef QUADKIND
278 #  ifdef U64TYPE
279 #   define WIDEST_UTYPE U64TYPE
280 #  else
281 #   define WIDEST_UTYPE Quad_t
282 #  endif
283 # else
284 #  define WIDEST_UTYPE U32
285 # endif
286 #endif
287
288 /* On versions without this, only ASCII is supported */
289 #ifdef NATIVE_TO_ASCII
290 __UNDEFINED__ NATIVE_TO_LATIN1(c) NATIVE_TO_ASCII(c)
291 #else
292 __UNDEFINED__ NATIVE_TO_LATIN1(c) (c)
293 #endif
294
295 #ifdef ASCII_TO_NATIVE
296 __UNDEFINED__ LATIN1_TO_NATIVE(c) ASCII_TO_NATIVE(c)
297 #else
298 __UNDEFINED__ LATIN1_TO_NATIVE(c) (c)
299 #endif
300
301 /* Warning: LATIN1_TO_NATIVE, NATIVE_TO_LATIN1
302    EBCDIC is not supported on versions earlier than 5.7.1
303  */
304
305 #ifdef EBCDIC
306
307 /* This is the first version where these macros are fully correct.  Relying on
308  * the C library functions, as earlier releases did, causes problems with
309  * locales */
310 # if { VERSION < 5.22.0 }
311 #  undef isALNUM
312 #  undef isALNUM_A
313 #  undef isALNUM_L1
314 #  undef isALNUMC
315 #  undef isALNUMC_A
316 #  undef isALNUMC_L1
317 #  undef isALPHA
318 #  undef isALPHA_A
319 #  undef isALPHA_L1
320 #  undef isALPHANUMERIC
321 #  undef isALPHANUMERIC_A
322 #  undef isALPHANUMERIC_L1
323 #  undef isASCII
324 #  undef isASCII_A
325 #  undef isASCII_L1
326 #  undef isBLANK
327 #  undef isBLANK_A
328 #  undef isBLANK_L1
329 #  undef isCNTRL
330 #  undef isCNTRL_A
331 #  undef isCNTRL_L1
332 #  undef isDIGIT
333 #  undef isDIGIT_A
334 #  undef isDIGIT_L1
335 #  undef isGRAPH
336 #  undef isGRAPH_A
337 #  undef isGRAPH_L1
338 #  undef isIDCONT
339 #  undef isIDCONT_A
340 #  undef isIDCONT_L1
341 #  undef isIDFIRST
342 #  undef isIDFIRST_A
343 #  undef isIDFIRST_L1
344 #  undef isLOWER
345 #  undef isLOWER_A
346 #  undef isLOWER_L1
347 #  undef isOCTAL
348 #  undef isOCTAL_A
349 #  undef isOCTAL_L1
350 #  undef isPRINT
351 #  undef isPRINT_A
352 #  undef isPRINT_L1
353 #  undef isPSXSPC
354 #  undef isPSXSPC_A
355 #  undef isPSXSPC_L1
356 #  undef isPUNCT
357 #  undef isPUNCT_A
358 #  undef isPUNCT_L1
359 #  undef isSPACE
360 #  undef isSPACE_A
361 #  undef isSPACE_L1
362 #  undef isUPPER
363 #  undef isUPPER_A
364 #  undef isUPPER_L1
365 #  undef isWORDCHAR
366 #  undef isWORDCHAR_A
367 #  undef isWORDCHAR_L1
368 #  undef isXDIGIT
369 #  undef isXDIGIT_A
370 #  undef isXDIGIT_L1
371 # endif
372
373 __UNDEFINED__ isASCII(c)    (isCNTRL(c) || isPRINT(c))
374
375         /* The below is accurate for all EBCDIC code pages supported by
376          * all the versions of Perl overridden by this */
377 __UNDEFINED__ isCNTRL(c)    (    (c) == '\0' || (c) == '\a' || (c) == '\b'      \
378                              ||  (c) == '\f' || (c) == '\n' || (c) == '\r'      \
379                              ||  (c) == '\t' || (c) == '\v'                     \
380                              || ((c) <= 3 && (c) >= 1) /* SOH, STX, ETX */      \
381                              ||  (c) == 7    /* U+7F DEL */                     \
382                              || ((c) <= 0x13 && (c) >= 0x0E) /* SO, SI */       \
383                                                       /* DLE, DC[1-3] */        \
384                              ||  (c) == 0x18 /* U+18 CAN */                     \
385                              ||  (c) == 0x19 /* U+19 EOM */                     \
386                              || ((c) <= 0x1F && (c) >= 0x1C) /* [FGRU]S */      \
387                              ||  (c) == 0x26 /* U+17 ETB */                     \
388                              ||  (c) == 0x27 /* U+1B ESC */                     \
389                              ||  (c) == 0x2D /* U+05 ENQ */                     \
390                              ||  (c) == 0x2E /* U+06 ACK */                     \
391                              ||  (c) == 0x32 /* U+16 SYN */                     \
392                              ||  (c) == 0x37 /* U+04 EOT */                     \
393                              ||  (c) == 0x3C /* U+14 DC4 */                     \
394                              ||  (c) == 0x3D /* U+15 NAK */                     \
395                              ||  (c) == 0x3F /* U+1A SUB */                     \
396                             )
397
398 #if '^' == 106    /* EBCDIC POSIX-BC */
399 #  define D_PPP_OUTLIER_CONTROL 0x5F
400 #else   /* EBCDIC 1047 037 */
401 #  define D_PPP_OUTLIER_CONTROL 0xFF
402 #endif
403
404 /* The controls are everything below blank, plus one outlier */
405 __UNDEFINED__ isCNTRL_L1(c) ((WIDEST_UTYPE) (c) < ' '                           \
406                           || (WIDEST_UTYPE) (c) == D_PPP_OUTLIER_CONTROL)
407                             )
408 /* The ordering of the tests in this and isUPPER are to exclude most characters
409  * early */
410 __UNDEFINED__ isLOWER(c)    (        (c) >= 'a' && (c) <= 'z'                   \
411                              &&  (   (c) <= 'i'                                 \
412                                  || ((c) >= 'j' && (c) <= 'r')                  \
413                                  ||  (c) >= 's'))
414 __UNDEFINED__ isUPPER(c)    (        (c) >= 'A' && (c) <= 'Z'                   \
415                              && (    (c) <= 'I'                                 \
416                                  || ((c) >= 'J' && (c) <= 'R')                  \
417                                  ||  (c) >= 'S'))
418
419 #else   /* Above is EBCDIC; below is ASCII */
420
421 # if { VERSION < 5.4.0 }
422 /* The implementation of these in older perl versions can give wrong results if
423  * the C program locale is set to other than the C locale */
424 #  undef isALNUM
425 #  undef isALNUM_A
426 #  undef isALPHA
427 #  undef isALPHA_A
428 #  undef isDIGIT
429 #  undef isDIGIT_A
430 #  undef isIDFIRST
431 #  undef isIDFIRST_A
432 #  undef isLOWER
433 #  undef isLOWER_A
434 #  undef isUPPER
435 #  undef isUPPER_A
436 # endif
437
438 # if { VERSION < 5.8.0 } /* earlier perls omitted DEL */
439 #  undef isCNTRL
440 # endif
441
442 # if { VERSION < 5.10.0 }
443 /* earlier perls included all of the isSPACE() characters, which is wrong. The
444  * version provided by Devel::PPPort always overrides an existing buggy
445  * version. */
446 #  undef isPRINT
447 #  undef isPRINT_A
448 # endif
449
450 # if { VERSION < 5.14.0 }
451 /* earlier perls always returned true if the parameter was a signed char */
452 #  undef isASCII
453 #  undef isASCII_A
454 # endif
455
456 # if { VERSION < 5.17.8 } /* earlier perls didn't include PILCROW, SECTION SIGN */
457 #  undef isPUNCT_L1
458 # endif
459
460 # if { VERSION < 5.13.7 } /* khw didn't investigate why this failed */
461 #  undef isALNUMC_L1
462 #endif
463
464 # if { VERSION < 5.20.0 } /* earlier perls didn't include \v */
465 #  undef isSPACE
466 #  undef isSPACE_A
467 #  undef isSPACE_L1
468 # endif
469
470 __UNDEFINED__ isASCII(c)        ((WIDEST_UTYPE) (c) <= 127)
471 __UNDEFINED__ isCNTRL(c)        ((WIDEST_UTYPE) (c) < ' ' || (c) == 127)
472 __UNDEFINED__ isCNTRL_L1(c)     (isCNTRL(c) || (   (WIDEST_UTYPE) (c) <= 0x9F  \
473                                                 && (WIDEST_UTYPE) (c) >= 0x80))
474 __UNDEFINED__ isLOWER(c)        ((c) >= 'a' && (c) <= 'z')
475 __UNDEFINED__ isUPPER(c)        ((c) <= 'Z' && (c) >= 'A')
476 #endif /* Below are definitions common to EBCDIC and ASCII */
477
478 __UNDEFINED__ isASCII_L1(c)     isASCII(c)
479 __UNDEFINED__ isALNUM(c)        isWORDCHAR(c)
480 __UNDEFINED__ isALNUMC(c)       isALPHANUMERIC(c)
481 __UNDEFINED__ isALNUMC_L1(c)    isALPHANUMERIC_L1(c)
482 __UNDEFINED__ isALPHA(c)        (isUPPER(c) || isLOWER(c))
483 __UNDEFINED__ isALPHA_L1(c)     (isUPPER_L1(c) || isLOWER_L1(c))
484 __UNDEFINED__ isALPHANUMERIC(c) (isALPHA(c) || isDIGIT(c))
485 __UNDEFINED__ isALPHANUMERIC_L1(c) (isALPHA_L1(c) || isDIGIT(c))
486 __UNDEFINED__ isBLANK(c)        ((c) == ' ' || (c) == '\t')
487 __UNDEFINED__ isBLANK_L1(c) (    isBLANK(c)                                    \
488                              || (   (WIDEST_UTYPE) (c) < 256                   \
489                                  && NATIVE_TO_LATIN1((U8) c) == 0xA0))
490 __UNDEFINED__ isDIGIT(c)        ((c) <= '9' && (c) >= '0')
491 __UNDEFINED__ isDIGIT_L1(c)     isDIGIT(c)
492 __UNDEFINED__ isGRAPH(c)        (isWORDCHAR(c) || isPUNCT(c))
493 __UNDEFINED__ isGRAPH_L1(c)     (isPRINT_L1(c) && (c) != ' ')
494 __UNDEFINED__ isIDCONT(c)       isWORDCHAR(c)
495 __UNDEFINED__ isIDCONT_L1(c)    isWORDCHAR_L1(c)
496 __UNDEFINED__ isIDFIRST(c)      (isALPHA(c) || (c) == '_')
497 __UNDEFINED__ isIDFIRST_L1(c)   (isALPHA_L1(c) || NATIVE_TO_LATIN1(c) == '_')
498 __UNDEFINED__ isLOWER_L1(c) (    isLOWER(c)                                    \
499                              || (   (WIDEST_UTYPE) (c) < 256                   \
500                                  && (  (   NATIVE_TO_LATIN1((U8) c) >= 0xDF    \
501                                         && NATIVE_TO_LATIN1((U8) c) != 0xF7)   \
502                                      || NATIVE_TO_LATIN1((U8) c) == 0xAA       \
503                                      || NATIVE_TO_LATIN1((U8) c) == 0xBA       \
504                                      || NATIVE_TO_LATIN1((U8) c) == 0xB5)))
505 __UNDEFINED__ isOCTAL(c)        (((WIDEST_UTYPE)((c)) & ~7) == '0')
506 __UNDEFINED__ isOCTAL_L1(c)     isOCTAL(c)
507 __UNDEFINED__ isPRINT(c)        (isGRAPH(c) || (c) == ' ')
508 __UNDEFINED__ isPRINT_L1(c)     ((WIDEST_UTYPE) (c) < 256 && ! isCNTRL_L1(c))
509 __UNDEFINED__ isPSXSPC(c)       isSPACE(c)
510 __UNDEFINED__ isPSXSPC_L1(c)    isSPACE_L1(c)
511 __UNDEFINED__ isPUNCT(c)    (   (c) == '-' || (c) == '!' || (c) == '"'          \
512                              || (c) == '#' || (c) == '$' || (c) == '%'          \
513                              || (c) == '&' || (c) == '\'' || (c) == '('         \
514                              || (c) == ')' || (c) == '*' || (c) == '+'          \
515                              || (c) == ',' || (c) == '.' || (c) == '/'          \
516                              || (c) == ':' || (c) == ';' || (c) == '<'          \
517                              || (c) == '=' || (c) == '>' || (c) == '?'          \
518                              || (c) == '@' || (c) == '[' || (c) == '\\'         \
519                              || (c) == ']' || (c) == '^' || (c) == '_'          \
520                              || (c) == '`' || (c) == '{' || (c) == '|'          \
521                              || (c) == '}' || (c) == '~')
522 __UNDEFINED__ isPUNCT_L1(c)  (    isPUNCT(c)                                   \
523                               || (   (WIDEST_UTYPE) (c) < 256                  \
524                                   && (   NATIVE_TO_LATIN1((U8) c) == 0xA1      \
525                                       || NATIVE_TO_LATIN1((U8) c) == 0xA7      \
526                                       || NATIVE_TO_LATIN1((U8) c) == 0xAB      \
527                                       || NATIVE_TO_LATIN1((U8) c) == 0xB6      \
528                                       || NATIVE_TO_LATIN1((U8) c) == 0xB7      \
529                                       || NATIVE_TO_LATIN1((U8) c) == 0xBB      \
530                                       || NATIVE_TO_LATIN1((U8) c) == 0xBF)))
531 __UNDEFINED__ isSPACE(c)        (   isBLANK(c) || (c) == '\n' || (c) == '\r'    \
532                                  || (c) == '\v' || (c) == '\f')
533 __UNDEFINED__ isSPACE_L1(c) (    isSPACE(c)                                    \
534                              || (   (WIDEST_UTYPE) (c) < 256                   \
535                                  && (   NATIVE_TO_LATIN1((U8) c) == 0x85       \
536                                      || NATIVE_TO_LATIN1((U8) c) == 0xA0)))
537 __UNDEFINED__ isUPPER_L1(c) (   isUPPER(c)                                     \
538                              || (   (WIDEST_UTYPE) (c) < 256                   \
539                                  && (   NATIVE_TO_LATIN1((U8) c) >= 0xC0       \
540                                      && NATIVE_TO_LATIN1((U8) c) <= 0xDE       \
541                                      && NATIVE_TO_LATIN1((U8) c) != 0xD7)))
542 __UNDEFINED__ isWORDCHAR(c)     (isALPHANUMERIC(c) || (c) == '_')
543 __UNDEFINED__ isWORDCHAR_L1(c)  (isIDFIRST_L1(c) || isDIGIT(c))
544 __UNDEFINED__ isXDIGIT(c)       (   isDIGIT(c)                                  \
545                                  || ((c) >= 'a' && (c) <= 'f')                  \
546                                  || ((c) >= 'A' && (c) <= 'F'))
547 __UNDEFINED__ isXDIGIT_L1(c)    isXDIGIT(c)
548
549 __UNDEFINED__ isALNUM_A         isALNUM
550 __UNDEFINED__ isALNUMC_A        isALNUMC
551 __UNDEFINED__ isALPHA_A         isALPHA
552 __UNDEFINED__ isALPHANUMERIC_A  isALPHANUMERIC
553 __UNDEFINED__ isASCII_A         isASCII
554 __UNDEFINED__ isBLANK_A         isBLANK
555 __UNDEFINED__ isCNTRL_A         isCNTRL
556 __UNDEFINED__ isDIGIT_A         isDIGIT
557 __UNDEFINED__ isGRAPH_A         isGRAPH
558 __UNDEFINED__ isIDCONT_A        isIDCONT
559 __UNDEFINED__ isIDFIRST_A       isIDFIRST
560 __UNDEFINED__ isLOWER_A         isLOWER
561 __UNDEFINED__ isOCTAL_A         isOCTAL
562 __UNDEFINED__ isPRINT_A         isPRINT
563 __UNDEFINED__ isPSXSPC_A        isPSXSPC
564 __UNDEFINED__ isPUNCT_A         isPUNCT
565 __UNDEFINED__ isSPACE_A         isSPACE
566 __UNDEFINED__ isUPPER_A         isUPPER
567 __UNDEFINED__ isWORDCHAR_A      isWORDCHAR
568 __UNDEFINED__ isXDIGIT_A        isXDIGIT
569
570 /* Until we figure out how to support this in older perls... */
571 #if { VERSION >= 5.8.0 }
572
573 __UNDEFINED__ HeUTF8(he)        ((HeKLEN(he) == HEf_SVKEY) ?            \
574                                  SvUTF8(HeKEY_sv(he)) :                 \
575                                  (U32)HeKUTF8(he))
576
577 #endif
578
579 __UNDEFINED__ C_ARRAY_LENGTH(a)         (sizeof(a)/sizeof((a)[0]))
580 __UNDEFINED__ C_ARRAY_END(a)            ((a) + C_ARRAY_LENGTH(a))
581
582 __UNDEFINED__ LIKELY(x) (x)
583 __UNDEFINED__ UNLIKELY(x) (x)
584
585 #ifndef MUTABLE_PTR
586 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
587 #  define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
588 #else
589 #  define MUTABLE_PTR(p) ((void *) (p))
590 #endif
591 #endif
592
593 __UNDEFINED__ MUTABLE_SV(p)   ((SV *)MUTABLE_PTR(p))
594
595 =xsmisc
596
597 typedef XSPROTO(XSPROTO_test_t);
598 typedef XSPROTO_test_t *XSPROTO_test_t_ptr;
599
600 XS(XS_Devel__PPPort_dXSTARG);  /* prototype */
601 XS(XS_Devel__PPPort_dXSTARG)
602 {
603   dXSARGS;
604   dXSTARG;
605   IV iv;
606
607   PERL_UNUSED_VAR(cv);
608   SP -= items;
609   iv = SvIV(ST(0)) + 1;
610   PUSHi(iv);
611   XSRETURN(1);
612 }
613
614 XS(XS_Devel__PPPort_dAXMARK);  /* prototype */
615 XS(XS_Devel__PPPort_dAXMARK)
616 {
617   dSP;
618   dAXMARK;
619   dITEMS;
620   IV iv;
621
622   PERL_UNUSED_VAR(cv);
623   SP -= items;
624   iv = SvIV(ST(0)) - 1;
625   mPUSHi(iv);
626   XSRETURN(1);
627 }
628
629 =xsboot
630
631 {
632   XSPROTO_test_t_ptr p = &XS_Devel__PPPort_dXSTARG;
633   newXS("Devel::PPPort::dXSTARG", *p, file);
634 }
635 newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);
636
637 =xsubs
638
639 int
640 OpSIBLING_tests()
641         PREINIT:
642                 OP *x;
643                 OP *kid;
644                 OP *middlekid;
645                 OP *lastkid;
646                 int count = 0;
647                 int failures = 0;
648                 int i;
649         CODE:
650                 x = newOP(OP_PUSHMARK, 0);
651
652                 /* No siblings yet! */
653                 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
654                         failures++; warn("Op should not have had a sib");
655                 }
656
657
658                 /* Add 2 siblings */
659                 kid = x;
660
661                 for (i = 0; i < 2; i++) {
662                         OP *newsib = newOP(OP_PUSHMARK, 0);
663                         OpMORESIB_set(kid, newsib);
664
665                         kid = OpSIBLING(kid);
666                         lastkid = kid;
667                 }
668                 middlekid = OpSIBLING(x);
669
670                 /* Should now have a sibling */
671                 if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) {
672                         failures++; warn("Op should have had a sib after moresib_set");
673                 }
674
675                 /* Count the siblings */
676                 for (kid = OpSIBLING(x); kid; kid = OpSIBLING(kid)) {
677                         count++;
678                 }
679
680                 if (count != 2) {
681                         failures++; warn("Kid had %d sibs, expected 2", count);
682                 }
683
684                 if (OpHAS_SIBLING(lastkid) || OpSIBLING(lastkid)) {
685                         failures++; warn("Last kid should not have a sib");
686                 }
687
688                 /* Really sets the parent, and says 'no more siblings' */
689                 OpLASTSIB_set(x, lastkid);
690
691                 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
692                         failures++; warn("OpLASTSIB_set failed?");
693                 }
694
695                 /* Restore the kid */
696                 OpMORESIB_set(x, lastkid);
697
698                 /* Try to remove it again */
699                 OpLASTSIB_set(x, NULL);
700
701                 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
702                         failures++; warn("OpLASTSIB_set with NULL failed?");
703                 }
704
705                 /* Try to restore with maybesib_set */
706                 OpMAYBESIB_set(x, lastkid, NULL);
707
708                 if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) {
709                         failures++; warn("Op should have had a sib after maybesibset");
710                 }
711
712                 op_free(lastkid);
713                 op_free(middlekid);
714                 op_free(x);
715                 RETVAL = failures;
716         OUTPUT:
717                 RETVAL
718
719 int
720 SvRXOK(sv)
721         SV *sv
722         CODE:
723                 RETVAL = SvRXOK(sv);
724         OUTPUT:
725                 RETVAL
726
727 int
728 ptrtests()
729         PREINIT:
730                 int var, *p = &var;
731
732         CODE:
733                 RETVAL = 0;
734                 RETVAL += PTR2nat(p) != 0       ?  1 : 0;
735                 RETVAL += PTR2ul(p) != 0UL      ?  2 : 0;
736                 RETVAL += PTR2UV(p) != (UV) 0   ?  4 : 0;
737                 RETVAL += PTR2IV(p) != (IV) 0   ?  8 : 0;
738                 RETVAL += PTR2NV(p) != (NV) 0   ? 16 : 0;
739                 RETVAL += p > NUM2PTR(int *, 0) ? 32 : 0;
740
741         OUTPUT:
742                 RETVAL
743
744 int
745 gv_stashpvn(name, create)
746         char *name
747         I32 create
748         CODE:
749                 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
750         OUTPUT:
751                 RETVAL
752
753 int
754 get_sv(name, create)
755         char *name
756         I32 create
757         CODE:
758                 RETVAL = get_sv(name, create) != NULL;
759         OUTPUT:
760                 RETVAL
761
762 int
763 get_av(name, create)
764         char *name
765         I32 create
766         CODE:
767                 RETVAL = get_av(name, create) != NULL;
768         OUTPUT:
769                 RETVAL
770
771 int
772 get_hv(name, create)
773         char *name
774         I32 create
775         CODE:
776                 RETVAL = get_hv(name, create) != NULL;
777         OUTPUT:
778                 RETVAL
779
780 int
781 get_cv(name, create)
782         char *name
783         I32 create
784         CODE:
785                 RETVAL = get_cv(name, create) != NULL;
786         OUTPUT:
787                 RETVAL
788
789 void
790 xsreturn(two)
791         int two
792         PPCODE:
793                 mXPUSHp("test1", 5);
794                 if (two)
795                   mXPUSHp("test2", 5);
796                 if (two)
797                   XSRETURN(2);
798                 else
799                   XSRETURN(1);
800
801 SV*
802 boolSV(value)
803         int value
804         CODE:
805                 RETVAL = newSVsv(boolSV(value));
806         OUTPUT:
807                 RETVAL
808
809 SV*
810 DEFSV()
811         CODE:
812                 RETVAL = newSVsv(DEFSV);
813         OUTPUT:
814                 RETVAL
815
816 void
817 DEFSV_modify()
818         PPCODE:
819                 XPUSHs(sv_mortalcopy(DEFSV));
820                 ENTER;
821                 SAVE_DEFSV;
822                 DEFSV_set(newSVpvs("DEFSV"));
823                 XPUSHs(sv_mortalcopy(DEFSV));
824                 /* Yes, this leaks the above scalar; 5.005 with threads for some reason */
825                 /* frees it upon LEAVE, thus mortalizing it causes "attempt to free..." */
826                 /* sv_2mortal(DEFSV); */
827                 LEAVE;
828                 XPUSHs(sv_mortalcopy(DEFSV));
829                 XSRETURN(3);
830
831 int
832 ERRSV()
833         CODE:
834                 RETVAL = SvTRUEx(ERRSV);
835         OUTPUT:
836                 RETVAL
837
838 SV*
839 UNDERBAR()
840         CODE:
841                 {
842                   dUNDERBAR;
843                   RETVAL = newSVsv(UNDERBAR);
844                 }
845         OUTPUT:
846                 RETVAL
847
848 void
849 prepush()
850         CODE:
851                 {
852                   dXSTARG;
853                   XSprePUSH;
854                   PUSHi(42);
855                   XSRETURN(1);
856                 }
857
858 int
859 PERL_ABS(a)
860         int a
861
862 void
863 SVf(x)
864         SV *x
865         PPCODE:
866 #if { VERSION >= 5.004 }
867                 x = sv_2mortal(newSVpvf("[%" SVf "]", SVfARG(x)));
868 #endif
869                 XPUSHs(x);
870                 XSRETURN(1);
871
872 void
873 Perl_ppaddr_t(string)
874         char *string
875         PREINIT:
876                 Perl_ppaddr_t lower;
877         PPCODE:
878                 lower = PL_ppaddr[OP_LC];
879                 mXPUSHs(newSVpv(string, 0));
880                 PUTBACK;
881                 ENTER;
882                 (void)*(lower)(aTHXR);
883                 SPAGAIN;
884                 LEAVE;
885                 XSRETURN(1);
886
887 #if { VERSION >= 5.8.0 }
888
889 void
890 check_HeUTF8(utf8_key)
891         SV *utf8_key;
892         PREINIT:
893                 HV *hash;
894                 HE *ent;
895                 STRLEN klen;
896                 char *key;
897         PPCODE:
898                 hash = newHV();
899
900                 key = SvPV(utf8_key, klen);
901                 if (SvUTF8(utf8_key)) klen *= -1;
902                 hv_store(hash, key, klen, newSVpvs("string"), 0);
903                 hv_iterinit(hash);
904                 ent = hv_iternext(hash);
905                 assert(ent);
906                 mXPUSHp((HeUTF8(ent) == 0 ? "norm" : "utf8"), 4);
907                 hv_undef(hash);
908
909
910 #endif
911
912 void
913 check_c_array()
914         PREINIT:
915                 int x[] = { 10, 11, 12, 13 };
916         PPCODE:
917                 mXPUSHi(C_ARRAY_LENGTH(x));  /* 4 */
918                 mXPUSHi(*(C_ARRAY_END(x)-1)); /* 13 */
919
920 bool
921 isBLANK(ord)
922     UV ord
923     CODE:
924         RETVAL = isBLANK(ord);
925     OUTPUT:
926         RETVAL
927
928 bool
929 isBLANK_A(ord)
930     UV ord
931     CODE:
932         RETVAL = isBLANK_A(ord);
933     OUTPUT:
934         RETVAL
935
936 bool
937 isBLANK_L1(ord)
938     UV ord
939     CODE:
940         RETVAL = isBLANK_L1(ord);
941     OUTPUT:
942         RETVAL
943
944 bool
945 isUPPER(ord)
946     UV ord
947     CODE:
948         RETVAL = isUPPER(ord);
949     OUTPUT:
950         RETVAL
951
952 bool
953 isUPPER_A(ord)
954     UV ord
955     CODE:
956         RETVAL = isUPPER_A(ord);
957     OUTPUT:
958         RETVAL
959
960 bool
961 isUPPER_L1(ord)
962     UV ord
963     CODE:
964         RETVAL = isUPPER_L1(ord);
965     OUTPUT:
966         RETVAL
967
968 bool
969 isLOWER(ord)
970     UV ord
971     CODE:
972         RETVAL = isLOWER(ord);
973     OUTPUT:
974         RETVAL
975
976 bool
977 isLOWER_A(ord)
978     UV ord
979     CODE:
980         RETVAL = isLOWER_A(ord);
981     OUTPUT:
982         RETVAL
983
984 bool
985 isLOWER_L1(ord)
986     UV ord
987     CODE:
988         RETVAL = isLOWER_L1(ord);
989     OUTPUT:
990         RETVAL
991
992 bool
993 isALPHA(ord)
994     UV ord
995     CODE:
996         RETVAL = isALPHA(ord);
997     OUTPUT:
998         RETVAL
999
1000 bool
1001 isALPHA_A(ord)
1002     UV ord
1003     CODE:
1004         RETVAL = isALPHA_A(ord);
1005     OUTPUT:
1006         RETVAL
1007
1008 bool
1009 isALPHA_L1(ord)
1010     UV ord
1011     CODE:
1012         RETVAL = isALPHA_L1(ord);
1013     OUTPUT:
1014         RETVAL
1015
1016 bool
1017 isWORDCHAR(ord)
1018     UV ord
1019     CODE:
1020         RETVAL = isWORDCHAR(ord);
1021     OUTPUT:
1022         RETVAL
1023
1024 bool
1025 isWORDCHAR_A(ord)
1026     UV ord
1027     CODE:
1028         RETVAL = isWORDCHAR_A(ord);
1029     OUTPUT:
1030         RETVAL
1031
1032 bool
1033 isWORDCHAR_L1(ord)
1034     UV ord
1035     CODE:
1036         RETVAL = isWORDCHAR_L1(ord);
1037     OUTPUT:
1038         RETVAL
1039
1040 bool
1041 isALPHANUMERIC(ord)
1042     UV ord
1043     CODE:
1044         RETVAL = isALPHANUMERIC(ord);
1045     OUTPUT:
1046         RETVAL
1047
1048 bool
1049 isALPHANUMERIC_A(ord)
1050     UV ord
1051     CODE:
1052         RETVAL = isALPHANUMERIC_A(ord);
1053     OUTPUT:
1054         RETVAL
1055
1056 bool
1057 isALNUM(ord)
1058     UV ord
1059     CODE:
1060         RETVAL = isALNUM(ord);
1061     OUTPUT:
1062         RETVAL
1063
1064 bool
1065 isALNUM_A(ord)
1066     UV ord
1067     CODE:
1068         RETVAL = isALNUM_A(ord);
1069     OUTPUT:
1070         RETVAL
1071
1072 bool
1073 isDIGIT(ord)
1074     UV ord
1075     CODE:
1076         RETVAL = isDIGIT(ord);
1077     OUTPUT:
1078         RETVAL
1079
1080 bool
1081 isDIGIT_A(ord)
1082     UV ord
1083     CODE:
1084         RETVAL = isDIGIT_A(ord);
1085     OUTPUT:
1086         RETVAL
1087
1088 bool
1089 isOCTAL(ord)
1090     UV ord
1091     CODE:
1092         RETVAL = isOCTAL(ord);
1093     OUTPUT:
1094         RETVAL
1095
1096 bool
1097 isOCTAL_A(ord)
1098     UV ord
1099     CODE:
1100         RETVAL = isOCTAL_A(ord);
1101     OUTPUT:
1102         RETVAL
1103
1104 bool
1105 isIDFIRST(ord)
1106     UV ord
1107     CODE:
1108         RETVAL = isIDFIRST(ord);
1109     OUTPUT:
1110         RETVAL
1111
1112 bool
1113 isIDFIRST_A(ord)
1114     UV ord
1115     CODE:
1116         RETVAL = isIDFIRST_A(ord);
1117     OUTPUT:
1118         RETVAL
1119
1120 bool
1121 isIDCONT(ord)
1122     UV ord
1123     CODE:
1124         RETVAL = isIDCONT(ord);
1125     OUTPUT:
1126         RETVAL
1127
1128 bool
1129 isIDCONT_A(ord)
1130     UV ord
1131     CODE:
1132         RETVAL = isIDCONT_A(ord);
1133     OUTPUT:
1134         RETVAL
1135
1136 bool
1137 isSPACE(ord)
1138     UV ord
1139     CODE:
1140         RETVAL = isSPACE(ord);
1141     OUTPUT:
1142         RETVAL
1143
1144 bool
1145 isSPACE_A(ord)
1146     UV ord
1147     CODE:
1148         RETVAL = isSPACE_A(ord);
1149     OUTPUT:
1150         RETVAL
1151
1152 bool
1153 isASCII(ord)
1154     UV ord
1155     CODE:
1156         RETVAL = isASCII(ord);
1157     OUTPUT:
1158         RETVAL
1159
1160 bool
1161 isASCII_A(ord)
1162     UV ord
1163     CODE:
1164         RETVAL = isASCII_A(ord);
1165     OUTPUT:
1166         RETVAL
1167
1168 bool
1169 isCNTRL(ord)
1170     UV ord
1171     CODE:
1172         RETVAL = isCNTRL(ord);
1173     OUTPUT:
1174         RETVAL
1175
1176 bool
1177 isCNTRL_A(ord)
1178     UV ord
1179     CODE:
1180         RETVAL = isCNTRL_A(ord);
1181     OUTPUT:
1182         RETVAL
1183
1184 bool
1185 isPRINT(ord)
1186     UV ord
1187     CODE:
1188         RETVAL = isPRINT(ord);
1189     OUTPUT:
1190         RETVAL
1191
1192 bool
1193 isPRINT_A(ord)
1194     UV ord
1195     CODE:
1196         RETVAL = isPRINT_A(ord);
1197     OUTPUT:
1198         RETVAL
1199
1200 bool
1201 isGRAPH(ord)
1202     UV ord
1203     CODE:
1204         RETVAL = isGRAPH(ord);
1205     OUTPUT:
1206         RETVAL
1207
1208 bool
1209 isGRAPH_A(ord)
1210     UV ord
1211     CODE:
1212         RETVAL = isGRAPH_A(ord);
1213     OUTPUT:
1214         RETVAL
1215
1216 bool
1217 isPUNCT(ord)
1218     UV ord
1219     CODE:
1220         RETVAL = isPUNCT(ord);
1221     OUTPUT:
1222         RETVAL
1223
1224 bool
1225 isPUNCT_A(ord)
1226     UV ord
1227     CODE:
1228         RETVAL = isPUNCT_A(ord);
1229     OUTPUT:
1230         RETVAL
1231
1232 bool
1233 isXDIGIT(ord)
1234     UV ord
1235     CODE:
1236         RETVAL = isXDIGIT(ord);
1237     OUTPUT:
1238         RETVAL
1239
1240 bool
1241 isXDIGIT_A(ord)
1242     UV ord
1243     CODE:
1244         RETVAL = isXDIGIT_A(ord);
1245     OUTPUT:
1246         RETVAL
1247
1248 bool
1249 isPSXSPC(ord)
1250     UV ord
1251     CODE:
1252         RETVAL = isPSXSPC(ord);
1253     OUTPUT:
1254         RETVAL
1255
1256 bool
1257 isPSXSPC_A(ord)
1258     UV ord
1259     CODE:
1260         RETVAL = isPSXSPC_A(ord);
1261     OUTPUT:
1262         RETVAL
1263
1264 bool
1265 isALPHANUMERIC_L1(ord)
1266     UV ord
1267     CODE:
1268         RETVAL = isALPHANUMERIC_L1(ord);
1269     OUTPUT:
1270         RETVAL
1271
1272 bool
1273 isALNUMC_L1(ord)
1274     UV ord
1275     CODE:
1276         RETVAL = isALNUMC_L1(ord);
1277     OUTPUT:
1278         RETVAL
1279
1280 bool
1281 isDIGIT_L1(ord)
1282     UV ord
1283     CODE:
1284         RETVAL = isDIGIT_L1(ord);
1285     OUTPUT:
1286         RETVAL
1287
1288 bool
1289 isOCTAL_L1(ord)
1290     UV ord
1291     CODE:
1292         RETVAL = isOCTAL_L1(ord);
1293     OUTPUT:
1294         RETVAL
1295
1296 bool
1297 isIDFIRST_L1(ord)
1298     UV ord
1299     CODE:
1300         RETVAL = isIDFIRST_L1(ord);
1301     OUTPUT:
1302         RETVAL
1303
1304 bool
1305 isIDCONT_L1(ord)
1306     UV ord
1307     CODE:
1308         RETVAL = isIDCONT_L1(ord);
1309     OUTPUT:
1310         RETVAL
1311
1312 bool
1313 isSPACE_L1(ord)
1314     UV ord
1315     CODE:
1316         RETVAL = isSPACE_L1(ord);
1317     OUTPUT:
1318         RETVAL
1319
1320 bool
1321 isASCII_L1(ord)
1322     UV ord
1323     CODE:
1324         RETVAL = isASCII_L1(ord);
1325     OUTPUT:
1326         RETVAL
1327
1328 bool
1329 isCNTRL_L1(ord)
1330     UV ord
1331     CODE:
1332         RETVAL = isCNTRL_L1(ord);
1333     OUTPUT:
1334         RETVAL
1335
1336 bool
1337 isPRINT_L1(ord)
1338     UV ord
1339     CODE:
1340         RETVAL = isPRINT_L1(ord);
1341     OUTPUT:
1342         RETVAL
1343
1344 bool
1345 isGRAPH_L1(ord)
1346     UV ord
1347     CODE:
1348         RETVAL = isGRAPH_L1(ord);
1349     OUTPUT:
1350         RETVAL
1351
1352 bool
1353 isPUNCT_L1(ord)
1354     UV ord
1355     CODE:
1356         RETVAL = isPUNCT_L1(ord);
1357     OUTPUT:
1358         RETVAL
1359
1360 bool
1361 isXDIGIT_L1(ord)
1362     UV ord
1363     CODE:
1364         RETVAL = isXDIGIT_L1(ord);
1365     OUTPUT:
1366         RETVAL
1367
1368 bool
1369 isPSXSPC_L1(ord)
1370     UV ord
1371     CODE:
1372         RETVAL = isPSXSPC_L1(ord);
1373     OUTPUT:
1374         RETVAL
1375
1376 STRLEN
1377 av_tindex(av)
1378         SV *av
1379         CODE:
1380                 RETVAL = av_tindex((AV*)SvRV(av));
1381         OUTPUT:
1382                 RETVAL
1383
1384 STRLEN
1385 av_top_index(av)
1386         SV *av
1387         CODE:
1388                 RETVAL = av_top_index((AV*)SvRV(av));
1389         OUTPUT:
1390                 RETVAL
1391
1392 =tests plan => 176
1393
1394 use vars qw($my_sv @my_av %my_hv);
1395
1396 ok(&Devel::PPPort::boolSV(1));
1397 ok(!&Devel::PPPort::boolSV(0));
1398
1399 $_ = "Fred";
1400 ok(&Devel::PPPort::DEFSV(), "Fred");
1401 ok(&Devel::PPPort::UNDERBAR(), "Fred");
1402
1403 if ("$]" >= 5.009002 && "$]" < 5.023 && "$]" < 5.023004) {
1404   eval q{
1405     no warnings "deprecated";
1406     no if $^V > v5.17.9, warnings => "experimental::lexical_topic";
1407     my $_ = "Tony";
1408     ok(&Devel::PPPort::DEFSV(), "Fred");
1409     ok(&Devel::PPPort::UNDERBAR(), "Tony");
1410   };
1411 }
1412 else {
1413   ok(1);
1414   ok(1);
1415 }
1416
1417 my @r = &Devel::PPPort::DEFSV_modify();
1418
1419 ok(@r == 3);
1420 ok($r[0], 'Fred');
1421 ok($r[1], 'DEFSV');
1422 ok($r[2], 'Fred');
1423
1424 ok(&Devel::PPPort::DEFSV(), "Fred");
1425
1426 eval { 1 };
1427 ok(!&Devel::PPPort::ERRSV());
1428 eval { cannot_call_this_one() };
1429 ok(&Devel::PPPort::ERRSV());
1430
1431 ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
1432 ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
1433 ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
1434
1435 $my_sv = 1;
1436 ok(&Devel::PPPort::get_sv('my_sv', 0));
1437 ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
1438 ok(&Devel::PPPort::get_sv('not_my_sv', 1));
1439
1440 @my_av = (1);
1441 ok(&Devel::PPPort::get_av('my_av', 0));
1442 ok(!&Devel::PPPort::get_av('not_my_av', 0));
1443 ok(&Devel::PPPort::get_av('not_my_av', 1));
1444
1445 %my_hv = (a=>1);
1446 ok(&Devel::PPPort::get_hv('my_hv', 0));
1447 ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
1448 ok(&Devel::PPPort::get_hv('not_my_hv', 1));
1449
1450 sub my_cv { 1 };
1451 ok(&Devel::PPPort::get_cv('my_cv', 0));
1452 ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
1453 ok(&Devel::PPPort::get_cv('not_my_cv', 1));
1454
1455 ok(Devel::PPPort::dXSTARG(42), 43);
1456 ok(Devel::PPPort::dAXMARK(4711), 4710);
1457
1458 ok(Devel::PPPort::prepush(), 42);
1459
1460 ok(join(':', Devel::PPPort::xsreturn(0)), 'test1');
1461 ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2');
1462
1463 ok(Devel::PPPort::PERL_ABS(42), 42);
1464 ok(Devel::PPPort::PERL_ABS(-13), 13);
1465
1466 ok(Devel::PPPort::SVf(42), "$]" >= 5.004 ? '[42]' : '42');
1467 ok(Devel::PPPort::SVf('abc'), "$]" >= 5.004 ? '[abc]' : 'abc');
1468
1469 ok(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo");
1470
1471 ok(&Devel::PPPort::ptrtests(), 63);
1472
1473 ok(&Devel::PPPort::OpSIBLING_tests(), 0);
1474
1475 if ("$]" >= 5.009000) {
1476   eval q{
1477     ok(&Devel::PPPort::check_HeUTF8("hello"), "norm");
1478     ok(&Devel::PPPort::check_HeUTF8("\N{U+263a}"), "utf8");
1479   };
1480 } else {
1481   ok(1, 1);
1482   ok(1, 1);
1483 }
1484
1485 @r = &Devel::PPPort::check_c_array();
1486 ok($r[0], 4);
1487 ok($r[1], "13");
1488
1489 ok(!Devel::PPPort::SvRXOK(""));
1490 ok(!Devel::PPPort::SvRXOK(bless [], "Regexp"));
1491
1492 if ("$]" < 5.005) {
1493         skip 'no qr// objects in this perl', 0;
1494         skip 'no qr// objects in this perl', 0;
1495 } else {
1496         my $qr = eval 'qr/./';
1497         ok(Devel::PPPort::SvRXOK($qr));
1498         ok(Devel::PPPort::SvRXOK(bless $qr, "Surprise"));
1499 }
1500
1501 ok(  Devel::PPPort::isBLANK(ord(" ")));
1502 ok(! Devel::PPPort::isBLANK(ord("\n")));
1503
1504 ok(  Devel::PPPort::isBLANK_A(ord("\t")));
1505 ok(! Devel::PPPort::isBLANK_A(ord("\r")));
1506
1507 ok(  Devel::PPPort::isBLANK_L1(ord("\t")));
1508 ok(! Devel::PPPort::isBLANK_L1(ord("\r")));
1509
1510 ok(  Devel::PPPort::isUPPER(ord("A")));
1511 ok(! Devel::PPPort::isUPPER(ord("a")));
1512
1513 ok(  Devel::PPPort::isUPPER_A(ord("Z")));
1514
1515 # One of these two is uppercase in EBCDIC; the other in Latin1, but neither are
1516 # ASCII uppercase.
1517 ok(! Devel::PPPort::isUPPER_A(0xDC));
1518 ok(! Devel::PPPort::isUPPER_A(0xFC));
1519
1520 ok(Devel::PPPort::isUPPER_L1(0xDC) || Devel::PPPort::isUPPER_L1(0xFC));
1521 ok(! (Devel::PPPort::isUPPER_L1(0xDC) && Devel::PPPort::isUPPER_L1(0xFC)));
1522
1523 ok(  Devel::PPPort::isLOWER(ord("b")));
1524 ok(! Devel::PPPort::isLOWER(ord("B")));
1525
1526 ok(  Devel::PPPort::isLOWER_A(ord("y")));
1527
1528 # One of these two is lowercase in EBCDIC; the other in Latin1, but neither are
1529 # ASCII lowercase.
1530 ok(! Devel::PPPort::isLOWER_A(0xDC));
1531 ok(! Devel::PPPort::isLOWER_A(0xFC));
1532
1533 ok(Devel::PPPort::isLOWER_L1(0xDC) || Devel::PPPort::isLOWER_L1(0xFC));
1534 ok(! Devel::PPPort::isLOWER_L1(0xDC) && Devel::PPPort::isLOWER_L1(0xFC));
1535
1536 ok(  Devel::PPPort::isALPHA(ord("C")));
1537 ok(! Devel::PPPort::isALPHA(ord("1")));
1538
1539 ok(  Devel::PPPort::isALPHA_A(ord("x")));
1540 ok(! Devel::PPPort::isALPHA_A(0xDC));
1541
1542 ok(  Devel::PPPort::isALPHA_L1(ord("y")));
1543 ok(  Devel::PPPort::isALPHA_L1(0xDC));
1544 ok(! Devel::PPPort::isALPHA_L1(0xB6));
1545
1546 ok(  Devel::PPPort::isWORDCHAR(ord("_")));
1547 ok(! Devel::PPPort::isWORDCHAR(ord("@")));
1548
1549 ok(  Devel::PPPort::isWORDCHAR_A(ord("2")));
1550 ok(! Devel::PPPort::isWORDCHAR_A(0xFC));
1551
1552 ok(  Devel::PPPort::isWORDCHAR_L1(ord("2")));
1553 ok(  Devel::PPPort::isWORDCHAR_L1(0xFC));
1554 ok(! Devel::PPPort::isWORDCHAR_L1(0xB6));
1555
1556 ok(  Devel::PPPort::isALPHANUMERIC(ord("4")));
1557 ok(! Devel::PPPort::isALPHANUMERIC(ord("_")));
1558
1559 ok(  Devel::PPPort::isALPHANUMERIC_A(ord("l")));
1560 ok(! Devel::PPPort::isALPHANUMERIC_A(0xDC));
1561
1562 ok(  Devel::PPPort::isALPHANUMERIC_L1(ord("l")));
1563 ok(  Devel::PPPort::isALPHANUMERIC_L1(0xDC));
1564 ok(! Devel::PPPort::isALPHANUMERIC_L1(0xB6));
1565
1566 ok(  Devel::PPPort::isALNUM(ord("c")));
1567 ok(! Devel::PPPort::isALNUM(ord("}")));
1568
1569 ok(  Devel::PPPort::isALNUM_A(ord("5")));
1570 ok(! Devel::PPPort::isALNUM_A(0xFC));
1571
1572 ok(  Devel::PPPort::isALNUMC_L1(ord("5")));
1573 ok(  Devel::PPPort::isALNUMC_L1(0xFC));
1574 ok(! Devel::PPPort::isALNUMC_L1(0xB6));
1575
1576 ok(  Devel::PPPort::isDIGIT(ord("6")));
1577 ok(! Devel::PPPort::isDIGIT(ord("_")));
1578
1579 ok(  Devel::PPPort::isDIGIT_A(ord("7")));
1580 ok(! Devel::PPPort::isDIGIT_A(0xDC));
1581
1582 ok(  Devel::PPPort::isDIGIT_L1(ord("5")));
1583 ok(! Devel::PPPort::isDIGIT_L1(0xDC));
1584
1585 ok(  Devel::PPPort::isOCTAL(ord("7")));
1586 ok(! Devel::PPPort::isOCTAL(ord("8")));
1587
1588 ok(  Devel::PPPort::isOCTAL_A(ord("0")));
1589 ok(! Devel::PPPort::isOCTAL_A(ord("9")));
1590
1591 ok(  Devel::PPPort::isOCTAL_L1(ord("2")));
1592 ok(! Devel::PPPort::isOCTAL_L1(ord("8")));
1593
1594 ok(  Devel::PPPort::isIDFIRST(ord("D")));
1595 ok(! Devel::PPPort::isIDFIRST(ord("1")));
1596
1597 ok(  Devel::PPPort::isIDFIRST_A(ord("_")));
1598 ok(! Devel::PPPort::isIDFIRST_A(0xFC));
1599
1600 ok(  Devel::PPPort::isIDFIRST_L1(ord("_")));
1601 ok(  Devel::PPPort::isIDFIRST_L1(0xFC));
1602 ok(! Devel::PPPort::isIDFIRST_L1(0xB6));
1603
1604 ok(  Devel::PPPort::isIDCONT(ord("e")));
1605 ok(! Devel::PPPort::isIDCONT(ord("@")));
1606
1607 ok(  Devel::PPPort::isIDCONT_A(ord("2")));
1608 ok(! Devel::PPPort::isIDCONT_A(0xDC));
1609
1610 ok(  Devel::PPPort::isIDCONT_L1(ord("4")));
1611 ok(  Devel::PPPort::isIDCONT_L1(0xDC));
1612 ok(! Devel::PPPort::isIDCONT_L1(0xB6));
1613
1614 ok(  Devel::PPPort::isSPACE(ord(" ")));
1615 ok(! Devel::PPPort::isSPACE(ord("_")));
1616
1617 ok(  Devel::PPPort::isSPACE_A(ord("\cK")));
1618 ok(! Devel::PPPort::isSPACE_A(ord("F")));
1619
1620 ok(  Devel::PPPort::isSPACE_L1(ord("\cK")));
1621 ok(! Devel::PPPort::isSPACE_L1(ord("g")));
1622
1623 # This stresses the edge for ASCII machines, but happens to work on EBCDIC as
1624 # well
1625 ok(  Devel::PPPort::isASCII(0x7F));
1626 ok(! Devel::PPPort::isASCII(0x80));
1627
1628 ok(  Devel::PPPort::isASCII_A(ord("9")));
1629 ok(  Devel::PPPort::isASCII_L1(ord("9")));
1630
1631 # B6 is the PARAGRAPH SIGN in ASCII and EBCDIC
1632 ok(! Devel::PPPort::isASCII_A(0xB6));
1633 ok(! Devel::PPPort::isASCII_L1(0xB6));
1634
1635 ok(  Devel::PPPort::isCNTRL(ord("\e")));
1636 ok(! Devel::PPPort::isCNTRL(ord(" ")));
1637
1638 ok(  Devel::PPPort::isCNTRL_A(ord("\a")));
1639 ok(! Devel::PPPort::isCNTRL_A(0xB6));
1640
1641 ok(  Devel::PPPort::isCNTRL_L1(ord("\a")));
1642 ok(  Devel::PPPort::isCNTRL_L1(ord(" ") - 1));
1643 ok(! Devel::PPPort::isCNTRL_L1(0xB6));
1644 if (ord('A') == 65) {
1645     ok(Devel::PPPort::isCNTRL_L1(0x80));
1646 }
1647 elsif (ord('^') == 106) {
1648     ok(Devel::PPPort::isCNTRL_L1(0x5F));
1649 }
1650 else {
1651     ok(Devel::PPPort::isCNTRL_L1(0xFF));
1652 }
1653
1654 ok(  Devel::PPPort::isPRINT(ord(" ")));
1655 ok(! Devel::PPPort::isPRINT(ord("\n")));
1656
1657 ok(  Devel::PPPort::isPRINT_A(ord("G")));
1658 ok(! Devel::PPPort::isPRINT_A(0xB6));
1659
1660 ok(  Devel::PPPort::isPRINT_L1(ord("~")));
1661 ok(  Devel::PPPort::isPRINT_L1(0xB6));
1662 ok(! Devel::PPPort::isPRINT_L1(ord("\r")));
1663
1664 ok(  Devel::PPPort::isGRAPH(ord("h")));
1665 ok(! Devel::PPPort::isGRAPH(ord(" ")));
1666
1667 ok(  Devel::PPPort::isGRAPH_A(ord("i")));
1668 ok(! Devel::PPPort::isGRAPH_A(0xB6));
1669
1670 ok(  Devel::PPPort::isGRAPH_L1(ord("j")));
1671 ok(  Devel::PPPort::isGRAPH_L1(0xB6));
1672 ok(! Devel::PPPort::isGRAPH_L1(4));
1673
1674 ok(  Devel::PPPort::isPUNCT(ord("#")));
1675 ok(! Devel::PPPort::isPUNCT(ord(" ")));
1676
1677 ok(  Devel::PPPort::isPUNCT_A(ord("*")));
1678 ok(! Devel::PPPort::isPUNCT_A(0xB6));
1679
1680 ok(  Devel::PPPort::isPUNCT_L1(ord("+")));
1681 ok(  Devel::PPPort::isPUNCT_L1(0xB6));
1682
1683 ok(  Devel::PPPort::isXDIGIT(ord("A")));
1684 ok(! Devel::PPPort::isXDIGIT(ord("_")));
1685
1686 ok(  Devel::PPPort::isXDIGIT_A(ord("9")));
1687 ok(! Devel::PPPort::isXDIGIT_A(0xDC));
1688
1689 ok(  Devel::PPPort::isXDIGIT_L1(ord("9")));
1690 ok(! Devel::PPPort::isXDIGIT_L1(0xFF));
1691
1692 ok(  Devel::PPPort::isPSXSPC(ord(" ")));
1693 ok(! Devel::PPPort::isPSXSPC(ord("k")));
1694
1695 ok(  Devel::PPPort::isPSXSPC_A(ord("\cK")));
1696 ok(! Devel::PPPort::isPSXSPC_A(0xFC));
1697
1698 ok(  Devel::PPPort::isPSXSPC_L1(ord("\cK")));
1699 ok(! Devel::PPPort::isPSXSPC_L1(0xFC));
1700
1701 ok(&Devel::PPPort::av_top_index([1,2,3]), 2);
1702 ok(&Devel::PPPort::av_tindex([1,2,3,4]), 3);