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