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 PERL_UNUSED_DECL
  16 PERL_UNUSED_ARG
  17 PERL_UNUSED_VAR
  18 PERL_UNUSED_CONTEXT
  19 PERL_UNUSED_RESULT
  20 PERL_GCC_BRACE_GROUPS_FORBIDDEN
  21 PERL_USE_GCC_BRACE_GROUPS
  22 PERLIO_FUNCS_DECL
  23 PERLIO_FUNCS_CAST
  24 NVTYPE
  25 INT2PTR
  26 PTRV
  27 NUM2PTR
  28 PERL_HASH
  29 PTR2IV
  30 PTR2UV
  31 PTR2NV
  32 PTR2ul
  33 START_EXTERN_C
  34 END_EXTERN_C
  35 EXTERN_C
  36 STMT_START
  37 STMT_END
  38 UTF8_MAXBYTES
  39 WIDEST_UTYPE
  40 XSRETURN
  41 HeUTF8
  42 C_ARRAY_LENGTH
  43 C_ARRAY_END
  44 SvRX
  45 SvRXOK
  46 cBOOL
  47 OpHAS_SIBLING
  48 OpSIBLING
  49 OpMORESIB_set
  50 OpLASTSIB_set
  51 OpMAYBESIB_set
  52 MUTABLE_PTR
  53 MUTABLE_SV
  54
  55 =implementation
  56
  57 __UNDEFINED__ cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0)
  58 __UNDEFINED__ OpHAS_SIBLING(o)      (cBOOL((o)->op_sibling))
  59 __UNDEFINED__ OpSIBLING(o)          (0 + (o)->op_sibling)
  60 __UNDEFINED__ OpMORESIB_set(o, sib) ((o)->op_sibling = (sib))
  61 __UNDEFINED__ OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL)
  62 __UNDEFINED__ OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib))
  63 __UNDEFINED__ HEf_SVKEY   -2
  64
  65 #ifndef SvRX
  66 #if { NEED SvRX }
  67
  68 void *
  69 SvRX(pTHX_ SV *rv)
  70 {
  71         if (SvROK(rv)) {
  72                 SV *sv = SvRV(rv);
  73                 if (SvMAGICAL(sv)) {
  74                         MAGIC *mg = mg_find(sv, PERL_MAGIC_qr);
  75                         if (mg && mg->mg_obj) {
  76                                 return mg->mg_obj;
  77                         }
  78                 }
  79         }
  80         return 0;
  81 }
  82 #endif
  83 #endif
  84
  85 __UNDEFINED__ SvRXOK(sv) (!!SvRX(sv))
  86
  87 #ifndef PERL_UNUSED_DECL
  88 #  ifdef HASATTRIBUTE
  89 #    if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
  90 #      define PERL_UNUSED_DECL
  91 #    else
  92 #      define PERL_UNUSED_DECL __attribute__((unused))
  93 #    endif
  94 #  else
  95 #    define PERL_UNUSED_DECL
  96 #  endif
  97 #endif
  98
  99 #ifndef PERL_UNUSED_ARG
 100 #  if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
 101 #    include <note.h>
 102 #    define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
 103 #  else
 104 #    define PERL_UNUSED_ARG(x) ((void)x)
 105 #  endif
 106 #endif
 107
 108 #ifndef PERL_UNUSED_VAR
 109 #  define PERL_UNUSED_VAR(x) ((void)x)
 110 #endif
 111
 112 #ifndef PERL_UNUSED_CONTEXT
 113 #  ifdef USE_ITHREADS
 114 #    define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
 115 #  else
 116 #    define PERL_UNUSED_CONTEXT
 117 #  endif
 118 #endif
 119
 120 #ifndef PERL_UNUSED_RESULT
 121 #  if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT)
 122 #    define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END
 123 #  else
 124 #    define PERL_UNUSED_RESULT(v) ((void)(v))
 125 #  endif
 126 #endif
 127
 128 __UNDEFINED__  NOOP          /*EMPTY*/(void)0
 129 __UNDEFINED__  dNOOP         extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL
 130
 131 #ifndef NVTYPE
 132 #  if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
 133 #    define NVTYPE long double
 134 #  else
 135 #    define NVTYPE double
 136 #  endif
 137 typedef NVTYPE NV;
 138 #endif
 139
 140 #ifndef INT2PTR
 141 #  if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
 142 #    define PTRV                  UV
 143 #    define INT2PTR(any,d)        (any)(d)
 144 #  else
 145 #    if PTRSIZE == LONGSIZE
 146 #      define PTRV                unsigned long
 147 #    else
 148 #      define PTRV                unsigned
 149 #    endif
 150 #    define INT2PTR(any,d)        (any)(PTRV)(d)
 151 #  endif
 152 #endif
 153
 154 #ifndef PTR2ul
 155 #  if PTRSIZE == LONGSIZE
 156 #    define PTR2ul(p)     (unsigned long)(p)
 157 #  else
 158 #    define PTR2ul(p)     INT2PTR(unsigned long,p)
 159 #  endif
 160 #endif
 161
 162 __UNDEFINED__  PTR2nat(p)      (PTRV)(p)
 163 __UNDEFINED__  NUM2PTR(any,d)  (any)PTR2nat(d)
 164 __UNDEFINED__  PTR2IV(p)       INT2PTR(IV,p)
 165 __UNDEFINED__  PTR2UV(p)       INT2PTR(UV,p)
 166 __UNDEFINED__  PTR2NV(p)       NUM2PTR(NV,p)
 167
 168 #undef START_EXTERN_C
 169 #undef END_EXTERN_C
 170 #undef EXTERN_C
 171 #ifdef __cplusplus
 172 #  define START_EXTERN_C extern "C" {
 173 #  define END_EXTERN_C }
 174 #  define EXTERN_C extern "C"
 175 #else
 176 #  define START_EXTERN_C
 177 #  define END_EXTERN_C
 178 #  define EXTERN_C extern
 179 #endif
 180
 181 #if defined(PERL_GCC_PEDANTIC)
 182 #  ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
 183 #    define PERL_GCC_BRACE_GROUPS_FORBIDDEN
 184 #  endif
 185 #endif
 186
 187 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
 188 #  ifndef PERL_USE_GCC_BRACE_GROUPS
 189 #    define PERL_USE_GCC_BRACE_GROUPS
 190 #  endif
 191 #endif
 192
 193 #undef STMT_START
 194 #undef STMT_END
 195 #ifdef PERL_USE_GCC_BRACE_GROUPS
 196 #  define STMT_START    (void)( /* gcc supports ``({ STATEMENTS; })'' */
 197 #  define STMT_END      )
 198 #else
 199 #  if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
 200 #    define STMT_START  if (1)
 201 #    define STMT_END    else (void)0
 202 #  else
 203 #    define STMT_START  do
 204 #    define STMT_END    while (0)
 205 #  endif
 206 #endif
 207
 208 __UNDEFINED__  boolSV(b)    ((b) ? &PL_sv_yes : &PL_sv_no)
 209
 210 /* DEFSV appears first in 5.004_56 */
 211 __UNDEFINED__  DEFSV        GvSV(PL_defgv)
 212 __UNDEFINED__  SAVE_DEFSV   SAVESPTR(GvSV(PL_defgv))
 213 __UNDEFINED__  DEFSV_set(sv) (DEFSV = (sv))
 214
 215 /* Older perls (<=5.003) lack AvFILLp */
 216 __UNDEFINED__  AvFILLp      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__  UTF8_MAXBYTES   UTF8_MAXLEN
 269
 270 __UNDEFINED__  CPERLscope(x)   x
 271
 272 __UNDEFINED__  PERL_HASH(hash,str,len) \
 273      STMT_START { \
 274         const char *s_PeRlHaSh = str; \
 275         I32 i_PeRlHaSh = len; \
 276         U32 hash_PeRlHaSh = 0; \
 277         while (i_PeRlHaSh--) \
 278             hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
 279         (hash) = hash_PeRlHaSh; \
 280     } STMT_END
 281
 282 #ifndef PERLIO_FUNCS_DECL
 283 # ifdef PERLIO_FUNCS_CONST
 284 #  define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
 285 #  define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
 286 # else
 287 #  define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
 288 #  define PERLIO_FUNCS_CAST(funcs) (funcs)
 289 # endif
 290 #endif
 291
 292 /* provide these typedefs for older perls */
 293 #if { VERSION < 5.9.3 }
 294
 295 # ifdef ARGSproto
 296 typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto);
 297 # else
 298 typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
 299 # endif
 300
 301 typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
 302
 303 #endif
 304
 305 #ifndef WIDEST_UTYPE
 306 # ifdef QUADKIND
 307 #  ifdef U64TYPE
 308 #   define WIDEST_UTYPE U64TYPE
 309 #  else
 310 #   define WIDEST_UTYPE Quad_t
 311 #  endif
 312 # else
 313 #  define WIDEST_UTYPE U32
 314 # endif
 315 #endif
 316
 317 #ifdef EBCDIC
 318
 319 /* This is the first version where these macros are fully correct.  Relying on
 320  * the C library functions, as earlier releases did, causes problems with
 321  * locales */
 322 # if { VERSION < 5.22.0 }
 323 #  undef isALNUM
 324 #  undef isALNUM_A
 325 #  undef isALNUMC
 326 #  undef isALNUMC_A
 327 #  undef isALPHA
 328 #  undef isALPHA_A
 329 #  undef isALPHANUMERIC
 330 #  undef isALPHANUMERIC_A
 331 #  undef isASCII
 332 #  undef isASCII_A
 333 #  undef isBLANK
 334 #  undef isBLANK_A
 335 #  undef isCNTRL
 336 #  undef isCNTRL_A
 337 #  undef isDIGIT
 338 #  undef isDIGIT_A
 339 #  undef isGRAPH
 340 #  undef isGRAPH_A
 341 #  undef isIDCONT
 342 #  undef isIDCONT_A
 343 #  undef isIDFIRST
 344 #  undef isIDFIRST_A
 345 #  undef isLOWER
 346 #  undef isLOWER_A
 347 #  undef isOCTAL
 348 #  undef isOCTAL_A
 349 #  undef isPRINT
 350 #  undef isPRINT_A
 351 #  undef isPSXSPC
 352 #  undef isPSXSPC_A
 353 #  undef isPUNCT
 354 #  undef isPUNCT_A
 355 #  undef isSPACE
 356 #  undef isSPACE_A
 357 #  undef isUPPER
 358 #  undef isUPPER_A
 359 #  undef isWORDCHAR
 360 #  undef isWORDCHAR_A
 361 #  undef isXDIGIT
 362 #  undef isXDIGIT_A
 363 # endif
 364
 365 __UNDEFINED__ isASCII(c)    (isCNTRL(c) || isPRINT(c))
 366
 367         /* The below is accurate for all EBCDIC code pages supported by
 368          * all the versions of Perl overridden by this */
 369 __UNDEFINED__ isCNTRL(c)    (    (c) == '\0' || (c) == '\a' || (c) == '\b'      \
 370                              ||  (c) == '\f' || (c) == '\n' || (c) == '\r'      \
 371                              ||  (c) == '\t' || (c) == '\v'                     \
 372                              || ((c) <= 3 && (c) >= 1) /* SOH, STX, ETX */      \
 373                              ||  (c) == 7    /* U+7F DEL */                     \
 374                              || ((c) <= 0x13 && (c) >= 0x0E) /* SO, SI */       \
 375                                                       /* DLE, DC[1-3] */        \
 376                              ||  (c) == 0x18 /* U+18 CAN */                     \
 377                              ||  (c) == 0x19 /* U+19 EOM */                     \
 378                              || ((c) <= 0x1F && (c) >= 0x1C) /* [FGRU]S */      \
 379                              ||  (c) == 0x26 /* U+17 ETB */                     \
 380                              ||  (c) == 0x27 /* U+1B ESC */                     \
 381                              ||  (c) == 0x2D /* U+05 ENQ */                     \
 382                              ||  (c) == 0x2E /* U+06 ACK */                     \
 383                              ||  (c) == 0x32 /* U+16 SYN */                     \
 384                              ||  (c) == 0x37 /* U+04 EOT */                     \
 385                              ||  (c) == 0x3C /* U+14 DC4 */                     \
 386                              ||  (c) == 0x3D /* U+15 NAK */                     \
 387                              ||  (c) == 0x3F /* U+1A SUB */                     \
 388                             )
 389 /* The ordering of the tests in this and isUPPER are to exclude most characters
 390  * early */
 391 __UNDEFINED__ isLOWER(c)    (        (c) >= 'a' && (c) <= 'z'                   \
 392                              &&  (   (c) <= 'i'                                 \
 393                                  || ((c) >= 'j' && (c) <= 'r')                  \
 394                                  ||  (c) >= 's'))
 395 __UNDEFINED__ isUPPER(c)    (        (c) >= 'A' && (c) <= 'Z'                   \
 396                              && (    (c) <= 'I'                                 \
 397                                  || ((c) >= 'J' && (c) <= 'R')                  \
 398                                  ||  (c) >= 'S'))
 399
 400 #else   /* Above is EBCDIC; below is ASCII */
 401
 402 # if { VERSION < 5.4.0 }
 403 /* The implementation of these in older perl versions can give wrong results if
 404  * the C program locale is set to other than the C locale */
 405 #  undef isALNUM
 406 #  undef isALNUM_A
 407 #  undef isALPHA
 408 #  undef isALPHA_A
 409 #  undef isDIGIT
 410 #  undef isDIGIT_A
 411 #  undef isIDFIRST
 412 #  undef isIDFIRST_A
 413 #  undef isLOWER
 414 #  undef isLOWER_A
 415 #  undef isUPPER
 416 #  undef isUPPER_A
 417 # endif
 418
 419 # if { VERSION < 5.8.0 }
 420 /* Hint: isCNTRL
 421  * Earlier perls omitted DEL */
 422 #  undef isCNTRL
 423 # endif
 424
 425 # if { VERSION < 5.10.0 }
 426 /* Hint: isPRINT
 427  * The implementation in older perl versions includes all of the
 428  * isSPACE() characters, which is wrong. The version provided by
 429  * Devel::PPPort always overrides a present buggy version.
 430  */
 431 #  undef isPRINT
 432 #  undef isPRINT_A
 433 # endif
 434
 435 # if { VERSION < 5.14.0 }
 436 /* Hint: isASCII
 437  * The implementation in older perl versions always returned true if the
 438  * parameter was a signed char
 439  */
 440 #  undef isASCII
 441 #  undef isASCII_A
 442 # endif
 443
 444 # if { VERSION < 5.20.0 }
 445 /* Hint: isSPACE
 446  * The implementation in older perl versions didn't include \v */
 447 #  undef isSPACE
 448 #  undef isSPACE_A
 449 # endif
 450
 451 __UNDEFINED__ isASCII(c)        ((WIDEST_UTYPE) (c) <= 127)
 452 __UNDEFINED__ isCNTRL(c)        ((WIDEST_UTYPE) (c) < ' ' || (c) == 127)
 453 __UNDEFINED__ isLOWER(c)        ((c) >= 'a' && (c) <= 'z')
 454 __UNDEFINED__ isUPPER(c)        ((c) <= 'Z' && (c) >= 'A')
 455 #endif /* Below are definitions common to EBCDIC and ASCII */
 456
 457 __UNDEFINED__ isALNUM(c)        isWORDCHAR(c)
 458 __UNDEFINED__ isALNUMC(c)       isALPHANUMERIC(c)
 459 __UNDEFINED__ isALPHA(c)        (isUPPER(c) || isLOWER(c))
 460 __UNDEFINED__ isALPHANUMERIC(c) (isALPHA(c) || isDIGIT(c))
 461 __UNDEFINED__ isBLANK(c)        ((c) == ' ' || (c) == '\t')
 462 __UNDEFINED__ isDIGIT(c)        ((c) <= '9' && (c) >= '0')
 463 __UNDEFINED__ isGRAPH(c)        (isWORDCHAR(c) || isPUNCT(c))
 464 __UNDEFINED__ isIDCONT(c)       isWORDCHAR(c)
 465 __UNDEFINED__ isIDFIRST(c)      (isALPHA(c) || (c) == '_')
 466 __UNDEFINED__ isOCTAL(c)        (((WIDEST_UTYPE)((c)) & ~7) == '0')
 467 __UNDEFINED__ isPRINT(c)        (isGRAPH(c) || (c) == ' ')
 468 __UNDEFINED__ isPSXSPC(c)       isSPACE(c)
 469 __UNDEFINED__ isPUNCT(c)    (   (c) == '-' || (c) == '!' || (c) == '"'          \
 470                              || (c) == '#' || (c) == '$' || (c) == '%'          \
 471                              || (c) == '&' || (c) == '\'' || (c) == '('         \
 472                              || (c) == ')' || (c) == '*' || (c) == '+'          \
 473                              || (c) == ',' || (c) == '.' || (c) == '/'          \
 474                              || (c) == ':' || (c) == ';' || (c) == '<'          \
 475                              || (c) == '=' || (c) == '>' || (c) == '?'          \
 476                              || (c) == '@' || (c) == '[' || (c) == '\\'         \
 477                              || (c) == ']' || (c) == '^' || (c) == '_'          \
 478                              || (c) == '`' || (c) == '{' || (c) == '|'          \
 479                              || (c) == '}' || (c) == '~')
 480 __UNDEFINED__ isSPACE(c)        (   isBLANK(c) || (c) == '\n' || (c) == '\r'    \
 481                                  || (c) == '\v' || (c) == '\f')
 482 __UNDEFINED__ isWORDCHAR(c)     (isALPHANUMERIC(c) || (c) == '_')
 483 __UNDEFINED__ isXDIGIT(c)       (   isDIGIT(c)                                  \
 484                                  || ((c) >= 'a' && (c) <= 'f')                  \
 485                                  || ((c) >= 'A' && (c) <= 'F'))
 486
 487 __UNDEFINED__ isALNUM_A         isALNUM
 488 __UNDEFINED__ isALNUMC_A        isALNUMC
 489 __UNDEFINED__ isALPHA_A         isALPHA
 490 __UNDEFINED__ isALPHANUMERIC_A  isALPHANUMERIC
 491 __UNDEFINED__ isASCII_A         isASCII
 492 __UNDEFINED__ isBLANK_A         isBLANK
 493 __UNDEFINED__ isCNTRL_A         isCNTRL
 494 __UNDEFINED__ isDIGIT_A         isDIGIT
 495 __UNDEFINED__ isGRAPH_A         isGRAPH
 496 __UNDEFINED__ isIDCONT_A        isIDCONT
 497 __UNDEFINED__ isIDFIRST_A       isIDFIRST
 498 __UNDEFINED__ isLOWER_A         isLOWER
 499 __UNDEFINED__ isOCTAL_A         isOCTAL
 500 __UNDEFINED__ isPRINT_A         isPRINT
 501 __UNDEFINED__ isPSXSPC_A        isPSXSPC
 502 __UNDEFINED__ isPUNCT_A         isPUNCT
 503 __UNDEFINED__ isSPACE_A         isSPACE
 504 __UNDEFINED__ isUPPER_A         isUPPER
 505 __UNDEFINED__ isWORDCHAR_A      isWORDCHAR
 506 __UNDEFINED__ isXDIGIT_A        isXDIGIT
 507
 508 /* Until we figure out how to support this in older perls... */
 509 #if { VERSION >= 5.8.0 }
 510
 511 __UNDEFINED__ HeUTF8(he)        ((HeKLEN(he) == HEf_SVKEY) ?            \
 512                                  SvUTF8(HeKEY_sv(he)) :                 \
 513                                  (U32)HeKUTF8(he))
 514
 515 #endif
 516
 517 __UNDEFINED__ C_ARRAY_LENGTH(a)         (sizeof(a)/sizeof((a)[0]))
 518 __UNDEFINED__ C_ARRAY_END(a)            ((a) + C_ARRAY_LENGTH(a))
 519
 520 #ifndef MUTABLE_PTR
 521 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
 522 #  define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
 523 #else
 524 #  define MUTABLE_PTR(p) ((void *) (p))
 525 #endif
 526 #endif
 527
 528 __UNDEFINED__ MUTABLE_SV(p)   ((SV *)MUTABLE_PTR(p))
 529
 530 =xsmisc
 531
 532 typedef XSPROTO(XSPROTO_test_t);
 533 typedef XSPROTO_test_t *XSPROTO_test_t_ptr;
 534
 535 XS(XS_Devel__PPPort_dXSTARG);  /* prototype */
 536 XS(XS_Devel__PPPort_dXSTARG)
 537 {
 538   dXSARGS;
 539   dXSTARG;
 540   IV iv;
 541
 542   PERL_UNUSED_VAR(cv);
 543   SP -= items;
 544   iv = SvIV(ST(0)) + 1;
 545   PUSHi(iv);
 546   XSRETURN(1);
 547 }
 548
 549 XS(XS_Devel__PPPort_dAXMARK);  /* prototype */
 550 XS(XS_Devel__PPPort_dAXMARK)
 551 {
 552   dSP;
 553   dAXMARK;
 554   dITEMS;
 555   IV iv;
 556
 557   PERL_UNUSED_VAR(cv);
 558   SP -= items;
 559   iv = SvIV(ST(0)) - 1;
 560   mPUSHi(iv);
 561   XSRETURN(1);
 562 }
 563
 564 =xsinit
 565
 566 #define NEED_SvRX
 567
 568 =xsboot
 569
 570 {
 571   XSPROTO_test_t_ptr p = &XS_Devel__PPPort_dXSTARG;
 572   newXS("Devel::PPPort::dXSTARG", *p, file);
 573 }
 574 newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);
 575
 576 =xsubs
 577
 578 int
 579 OpSIBLING_tests()
 580         PREINIT:
 581                 OP *x;
 582                 OP *kid;
 583                 OP *middlekid;
 584                 OP *lastkid;
 585                 int count = 0;
 586                 int failures = 0;
 587                 int i;
 588         CODE:
 589                 x = newOP(OP_PUSHMARK, 0);
 590
 591                 /* No siblings yet! */
 592                 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
 593                         failures++; warn("Op should not have had a sib");
 594                 }
 595
 596
 597                 /* Add 2 siblings */
 598                 kid = x;
 599
 600                 for (i = 0; i < 2; i++) {
 601                         OP *newsib = newOP(OP_PUSHMARK, 0);
 602                         OpMORESIB_set(kid, newsib);
 603
 604                         kid = OpSIBLING(kid);
 605                         lastkid = kid;
 606                 }
 607                 middlekid = OpSIBLING(x);
 608
 609                 /* Should now have a sibling */
 610                 if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) {
 611                         failures++; warn("Op should have had a sib after moresib_set");
 612                 }
 613
 614                 /* Count the siblings */
 615                 for (kid = OpSIBLING(x); kid; kid = OpSIBLING(kid)) {
 616                         count++;
 617                 }
 618
 619                 if (count != 2) {
 620                         failures++; warn("Kid had %d sibs, expected 2", count);
 621                 }
 622
 623                 if (OpHAS_SIBLING(lastkid) || OpSIBLING(lastkid)) {
 624                         failures++; warn("Last kid should not have a sib");
 625                 }
 626
 627                 /* Really sets the parent, and says 'no more siblings' */
 628                 OpLASTSIB_set(x, lastkid);
 629
 630                 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
 631                         failures++; warn("OpLASTSIB_set failed?");
 632                 }
 633
 634                 /* Restore the kid */
 635                 OpMORESIB_set(x, lastkid);
 636
 637                 /* Try to remove it again */
 638                 OpLASTSIB_set(x, NULL);
 639
 640                 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
 641                         failures++; warn("OpLASTSIB_set with NULL failed?");
 642                 }
 643
 644                 /* Try to restore with maybesib_set */
 645                 OpMAYBESIB_set(x, lastkid, NULL);
 646
 647                 if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) {
 648                         failures++; warn("Op should have had a sib after maybesibset");
 649                 }
 650
 651                 op_free(lastkid);
 652                 op_free(middlekid);
 653                 op_free(x);
 654                 RETVAL = failures;
 655         OUTPUT:
 656                 RETVAL
 657
 658 int
 659 SvRXOK(sv)
 660         SV *sv
 661         CODE:
 662                 RETVAL = SvRXOK(sv);
 663         OUTPUT:
 664                 RETVAL
 665
 666 int
 667 ptrtests()
 668         PREINIT:
 669                 int var, *p = &var;
 670
 671         CODE:
 672                 RETVAL = 0;
 673                 RETVAL += PTR2nat(p) != 0       ?  1 : 0;
 674                 RETVAL += PTR2ul(p) != 0UL      ?  2 : 0;
 675                 RETVAL += PTR2UV(p) != (UV) 0   ?  4 : 0;
 676                 RETVAL += PTR2IV(p) != (IV) 0   ?  8 : 0;
 677                 RETVAL += PTR2NV(p) != (NV) 0   ? 16 : 0;
 678                 RETVAL += p > NUM2PTR(int *, 0) ? 32 : 0;
 679
 680         OUTPUT:
 681                 RETVAL
 682
 683 int
 684 gv_stashpvn(name, create)
 685         char *name
 686         I32 create
 687         CODE:
 688                 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
 689         OUTPUT:
 690                 RETVAL
 691
 692 int
 693 get_sv(name, create)
 694         char *name
 695         I32 create
 696         CODE:
 697                 RETVAL = get_sv(name, create) != NULL;
 698         OUTPUT:
 699                 RETVAL
 700
 701 int
 702 get_av(name, create)
 703         char *name
 704         I32 create
 705         CODE:
 706                 RETVAL = get_av(name, create) != NULL;
 707         OUTPUT:
 708                 RETVAL
 709
 710 int
 711 get_hv(name, create)
 712         char *name
 713         I32 create
 714         CODE:
 715                 RETVAL = get_hv(name, create) != NULL;
 716         OUTPUT:
 717                 RETVAL
 718
 719 int
 720 get_cv(name, create)
 721         char *name
 722         I32 create
 723         CODE:
 724                 RETVAL = get_cv(name, create) != NULL;
 725         OUTPUT:
 726                 RETVAL
 727
 728 void
 729 xsreturn(two)
 730         int two
 731         PPCODE:
 732                 mXPUSHp("test1", 5);
 733                 if (two)
 734                   mXPUSHp("test2", 5);
 735                 if (two)
 736                   XSRETURN(2);
 737                 else
 738                   XSRETURN(1);
 739
 740 SV*
 741 boolSV(value)
 742         int value
 743         CODE:
 744                 RETVAL = newSVsv(boolSV(value));
 745         OUTPUT:
 746                 RETVAL
 747
 748 SV*
 749 DEFSV()
 750         CODE:
 751                 RETVAL = newSVsv(DEFSV);
 752         OUTPUT:
 753                 RETVAL
 754
 755 void
 756 DEFSV_modify()
 757         PPCODE:
 758                 XPUSHs(sv_mortalcopy(DEFSV));
 759                 ENTER;
 760                 SAVE_DEFSV;
 761                 DEFSV_set(newSVpvs("DEFSV"));
 762                 XPUSHs(sv_mortalcopy(DEFSV));
 763                 /* Yes, this leaks the above scalar; 5.005 with threads for some reason */
 764                 /* frees it upon LEAVE, thus mortalizing it causes "attempt to free..." */
 765                 /* sv_2mortal(DEFSV); */
 766                 LEAVE;
 767                 XPUSHs(sv_mortalcopy(DEFSV));
 768                 XSRETURN(3);
 769
 770 int
 771 ERRSV()
 772         CODE:
 773                 RETVAL = SvTRUE(ERRSV);
 774         OUTPUT:
 775                 RETVAL
 776
 777 SV*
 778 UNDERBAR()
 779         CODE:
 780                 {
 781                   dUNDERBAR;
 782                   RETVAL = newSVsv(UNDERBAR);
 783                 }
 784         OUTPUT:
 785                 RETVAL
 786
 787 void
 788 prepush()
 789         CODE:
 790                 {
 791                   dXSTARG;
 792                   XSprePUSH;
 793                   PUSHi(42);
 794                   XSRETURN(1);
 795                 }
 796
 797 int
 798 PERL_ABS(a)
 799         int a
 800
 801 void
 802 SVf(x)
 803         SV *x
 804         PPCODE:
 805 #if { VERSION >= 5.004 }
 806                 x = sv_2mortal(newSVpvf("[%" SVf "]", SVfARG(x)));
 807 #endif
 808                 XPUSHs(x);
 809                 XSRETURN(1);
 810
 811 void
 812 Perl_ppaddr_t(string)
 813         char *string
 814         PREINIT:
 815                 Perl_ppaddr_t lower;
 816         PPCODE:
 817                 lower = PL_ppaddr[OP_LC];
 818                 mXPUSHs(newSVpv(string, 0));
 819                 PUTBACK;
 820                 ENTER;
 821                 (void)*(lower)(aTHXR);
 822                 SPAGAIN;
 823                 LEAVE;
 824                 XSRETURN(1);
 825
 826 #if { VERSION >= 5.8.0 }
 827
 828 void
 829 check_HeUTF8(utf8_key)
 830         SV *utf8_key;
 831         PREINIT:
 832                 HV *hash;
 833                 HE *ent;
 834                 STRLEN klen;
 835                 char *key;
 836         PPCODE:
 837                 hash = newHV();
 838
 839                 key = SvPV(utf8_key, klen);
 840                 if (SvUTF8(utf8_key)) klen *= -1;
 841                 hv_store(hash, key, klen, newSVpvs("string"), 0);
 842                 hv_iterinit(hash);
 843                 ent = hv_iternext(hash);
 844                 assert(ent);
 845                 mXPUSHp((HeUTF8(ent) == 0 ? "norm" : "utf8"), 4);
 846                 hv_undef(hash);
 847
 848
 849 #endif
 850
 851 void
 852 check_c_array()
 853         PREINIT:
 854                 int x[] = { 10, 11, 12, 13 };
 855         PPCODE:
 856                 mXPUSHi(C_ARRAY_LENGTH(x));  /* 4 */
 857                 mXPUSHi(*(C_ARRAY_END(x)-1)); /* 13 */
 858
 859 bool
 860 test_isBLANK(UV ord)
 861     CODE:
 862         RETVAL = isBLANK(ord);
 863     OUTPUT:
 864         RETVAL
 865
 866 bool
 867 test_isBLANK_A(UV ord)
 868     CODE:
 869         RETVAL = isBLANK_A(ord);
 870     OUTPUT:
 871         RETVAL
 872
 873 bool
 874 test_isUPPER(UV ord)
 875     CODE:
 876         RETVAL = isUPPER(ord);
 877     OUTPUT:
 878         RETVAL
 879
 880 bool
 881 test_isUPPER_A(UV ord)
 882     CODE:
 883         RETVAL = isUPPER_A(ord);
 884     OUTPUT:
 885         RETVAL
 886
 887 bool
 888 test_isLOWER(UV ord)
 889     CODE:
 890         RETVAL = isLOWER(ord);
 891     OUTPUT:
 892         RETVAL
 893
 894 bool
 895 test_isLOWER_A(UV ord)
 896     CODE:
 897         RETVAL = isLOWER_A(ord);
 898     OUTPUT:
 899         RETVAL
 900
 901 bool
 902 test_isALPHA(UV ord)
 903     CODE:
 904         RETVAL = isALPHA(ord);
 905     OUTPUT:
 906         RETVAL
 907
 908 bool
 909 test_isALPHA_A(UV ord)
 910     CODE:
 911         RETVAL = isALPHA_A(ord);
 912     OUTPUT:
 913         RETVAL
 914
 915 bool
 916 test_isWORDCHAR(UV ord)
 917     CODE:
 918         RETVAL = isWORDCHAR(ord);
 919     OUTPUT:
 920         RETVAL
 921
 922 bool
 923 test_isWORDCHAR_A(UV ord)
 924     CODE:
 925         RETVAL = isWORDCHAR_A(ord);
 926     OUTPUT:
 927         RETVAL
 928
 929 bool
 930 test_isALPHANUMERIC(UV ord)
 931     CODE:
 932         RETVAL = isALPHANUMERIC(ord);
 933     OUTPUT:
 934         RETVAL
 935
 936 bool
 937 test_isALPHANUMERIC_A(UV ord)
 938     CODE:
 939         RETVAL = isALPHANUMERIC_A(ord);
 940     OUTPUT:
 941         RETVAL
 942
 943 bool
 944 test_isALNUM(UV ord)
 945     CODE:
 946         RETVAL = isALNUM(ord);
 947     OUTPUT:
 948         RETVAL
 949
 950 bool
 951 test_isALNUM_A(UV ord)
 952     CODE:
 953         RETVAL = isALNUM_A(ord);
 954     OUTPUT:
 955         RETVAL
 956
 957 bool
 958 test_isDIGIT(UV ord)
 959     CODE:
 960         RETVAL = isDIGIT(ord);
 961     OUTPUT:
 962         RETVAL
 963
 964 bool
 965 test_isDIGIT_A(UV ord)
 966     CODE:
 967         RETVAL = isDIGIT_A(ord);
 968     OUTPUT:
 969         RETVAL
 970
 971 bool
 972 test_isOCTAL(UV ord)
 973     CODE:
 974         RETVAL = isOCTAL(ord);
 975     OUTPUT:
 976         RETVAL
 977
 978 bool
 979 test_isOCTAL_A(UV ord)
 980     CODE:
 981         RETVAL = isOCTAL_A(ord);
 982     OUTPUT:
 983         RETVAL
 984
 985 bool
 986 test_isIDFIRST(UV ord)
 987     CODE:
 988         RETVAL = isIDFIRST(ord);
 989     OUTPUT:
 990         RETVAL
 991
 992 bool
 993 test_isIDFIRST_A(UV ord)
 994     CODE:
 995         RETVAL = isIDFIRST_A(ord);
 996     OUTPUT:
 997         RETVAL
 998
 999 bool
1000 test_isIDCONT(UV ord)
1001     CODE:
1002         RETVAL = isIDCONT(ord);
1003     OUTPUT:
1004         RETVAL
1005
1006 bool
1007 test_isIDCONT_A(UV ord)
1008     CODE:
1009         RETVAL = isIDCONT_A(ord);
1010     OUTPUT:
1011         RETVAL
1012
1013 bool
1014 test_isSPACE(UV ord)
1015     CODE:
1016         RETVAL = isSPACE(ord);
1017     OUTPUT:
1018         RETVAL
1019
1020 bool
1021 test_isSPACE_A(UV ord)
1022     CODE:
1023         RETVAL = isSPACE_A(ord);
1024     OUTPUT:
1025         RETVAL
1026
1027 bool
1028 test_isASCII(UV ord)
1029     CODE:
1030         RETVAL = isASCII(ord);
1031     OUTPUT:
1032         RETVAL
1033
1034 bool
1035 test_isASCII_A(UV ord)
1036     CODE:
1037         RETVAL = isASCII_A(ord);
1038     OUTPUT:
1039         RETVAL
1040
1041 bool
1042 test_isCNTRL(UV ord)
1043     CODE:
1044         RETVAL = isCNTRL(ord);
1045     OUTPUT:
1046         RETVAL
1047
1048 bool
1049 test_isCNTRL_A(UV ord)
1050     CODE:
1051         RETVAL = isCNTRL_A(ord);
1052     OUTPUT:
1053         RETVAL
1054
1055 bool
1056 test_isPRINT(UV ord)
1057     CODE:
1058         RETVAL = isPRINT(ord);
1059     OUTPUT:
1060         RETVAL
1061
1062 bool
1063 test_isPRINT_A(UV ord)
1064     CODE:
1065         RETVAL = isPRINT_A(ord);
1066     OUTPUT:
1067         RETVAL
1068
1069 bool
1070 test_isGRAPH(UV ord)
1071     CODE:
1072         RETVAL = isGRAPH(ord);
1073     OUTPUT:
1074         RETVAL
1075
1076 bool
1077 test_isGRAPH_A(UV ord)
1078     CODE:
1079         RETVAL = isGRAPH_A(ord);
1080     OUTPUT:
1081         RETVAL
1082
1083 bool
1084 test_isPUNCT(UV ord)
1085     CODE:
1086         RETVAL = isPUNCT(ord);
1087     OUTPUT:
1088         RETVAL
1089
1090 bool
1091 test_isPUNCT_A(UV ord)
1092     CODE:
1093         RETVAL = isPUNCT_A(ord);
1094     OUTPUT:
1095         RETVAL
1096
1097 bool
1098 test_isXDIGIT(UV ord)
1099     CODE:
1100         RETVAL = isXDIGIT(ord);
1101     OUTPUT:
1102         RETVAL
1103
1104 bool
1105 test_isXDIGIT_A(UV ord)
1106     CODE:
1107         RETVAL = isXDIGIT_A(ord);
1108     OUTPUT:
1109         RETVAL
1110
1111 bool
1112 test_isPSXSPC(UV ord)
1113     CODE:
1114         RETVAL = isPSXSPC(ord);
1115     OUTPUT:
1116         RETVAL
1117
1118 bool
1119 test_isPSXSPC_A(UV ord)
1120     CODE:
1121         RETVAL = isPSXSPC_A(ord);
1122     OUTPUT:
1123         RETVAL
1124
1125 =tests plan => 126
1126
1127 use vars qw($my_sv @my_av %my_hv);
1128
1129 ok(&Devel::PPPort::boolSV(1));
1130 ok(!&Devel::PPPort::boolSV(0));
1131
1132 $_ = "Fred";
1133 ok(&Devel::PPPort::DEFSV(), "Fred");
1134 ok(&Devel::PPPort::UNDERBAR(), "Fred");
1135
1136 if ("$]" >= 5.009002 && "$]" < 5.023 && "$]" < 5.023004) {
1137   eval q{
1138     no warnings "deprecated";
1139     no if $^V > v5.17.9, warnings => "experimental::lexical_topic";
1140     my $_ = "Tony";
1141     ok(&Devel::PPPort::DEFSV(), "Fred");
1142     ok(&Devel::PPPort::UNDERBAR(), "Tony");
1143   };
1144 }
1145 else {
1146   ok(1);
1147   ok(1);
1148 }
1149
1150 my @r = &Devel::PPPort::DEFSV_modify();
1151
1152 ok(@r == 3);
1153 ok($r[0], 'Fred');
1154 ok($r[1], 'DEFSV');
1155 ok($r[2], 'Fred');
1156
1157 ok(&Devel::PPPort::DEFSV(), "Fred");
1158
1159 eval { 1 };
1160 ok(!&Devel::PPPort::ERRSV());
1161 eval { cannot_call_this_one() };
1162 ok(&Devel::PPPort::ERRSV());
1163
1164 ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
1165 ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
1166 ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
1167
1168 $my_sv = 1;
1169 ok(&Devel::PPPort::get_sv('my_sv', 0));
1170 ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
1171 ok(&Devel::PPPort::get_sv('not_my_sv', 1));
1172
1173 @my_av = (1);
1174 ok(&Devel::PPPort::get_av('my_av', 0));
1175 ok(!&Devel::PPPort::get_av('not_my_av', 0));
1176 ok(&Devel::PPPort::get_av('not_my_av', 1));
1177
1178 %my_hv = (a=>1);
1179 ok(&Devel::PPPort::get_hv('my_hv', 0));
1180 ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
1181 ok(&Devel::PPPort::get_hv('not_my_hv', 1));
1182
1183 sub my_cv { 1 };
1184 ok(&Devel::PPPort::get_cv('my_cv', 0));
1185 ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
1186 ok(&Devel::PPPort::get_cv('not_my_cv', 1));
1187
1188 ok(Devel::PPPort::dXSTARG(42), 43);
1189 ok(Devel::PPPort::dAXMARK(4711), 4710);
1190
1191 ok(Devel::PPPort::prepush(), 42);
1192
1193 ok(join(':', Devel::PPPort::xsreturn(0)), 'test1');
1194 ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2');
1195
1196 ok(Devel::PPPort::PERL_ABS(42), 42);
1197 ok(Devel::PPPort::PERL_ABS(-13), 13);
1198
1199 ok(Devel::PPPort::SVf(42), "$]" >= 5.004 ? '[42]' : '42');
1200 ok(Devel::PPPort::SVf('abc'), "$]" >= 5.004 ? '[abc]' : 'abc');
1201
1202 ok(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo");
1203
1204 ok(&Devel::PPPort::ptrtests(), 63);
1205
1206 ok(&Devel::PPPort::OpSIBLING_tests(), 0);
1207
1208 if ("$]" >= 5.009000) {
1209   eval q{
1210     ok(&Devel::PPPort::check_HeUTF8("hello"), "norm");
1211     ok(&Devel::PPPort::check_HeUTF8("\N{U+263a}"), "utf8");
1212   };
1213 } else {
1214   ok(1, 1);
1215   ok(1, 1);
1216 }
1217
1218 @r = &Devel::PPPort::check_c_array();
1219 ok($r[0], 4);
1220 ok($r[1], "13");
1221
1222 ok(!Devel::PPPort::SvRXOK(""));
1223 ok(!Devel::PPPort::SvRXOK(bless [], "Regexp"));
1224
1225 if ("$]" < 5.005) {
1226         skip 'no qr// objects in this perl', 0;
1227         skip 'no qr// objects in this perl', 0;
1228 } else {
1229         my $qr = eval 'qr/./';
1230         ok(Devel::PPPort::SvRXOK($qr));
1231         ok(Devel::PPPort::SvRXOK(bless $qr, "Surprise"));
1232 }
1233
1234 ok(  Devel::PPPort::test_isBLANK(ord(" ")));
1235 ok(! Devel::PPPort::test_isBLANK(ord("\n")));
1236
1237 ok(  Devel::PPPort::test_isBLANK_A(ord("\t")));
1238 ok(! Devel::PPPort::test_isBLANK_A(ord("\r")));
1239
1240 ok(  Devel::PPPort::test_isUPPER(ord("A")));
1241 ok(! Devel::PPPort::test_isUPPER(ord("a")));
1242
1243 ok(  Devel::PPPort::test_isUPPER_A(ord("Z")));
1244
1245 # One of these two is uppercase in EBCDIC; the other in Latin1, but neither are
1246 # ASCII uppercase.
1247 ok(! Devel::PPPort::test_isUPPER_A(ord(0xDC)));
1248 ok(! Devel::PPPort::test_isUPPER_A(ord(0xFC)));
1249
1250 ok(  Devel::PPPort::test_isLOWER(ord("b")));
1251 ok(! Devel::PPPort::test_isLOWER(ord("B")));
1252
1253 ok(  Devel::PPPort::test_isLOWER_A(ord("y")));
1254
1255 # One of these two is lowercase in EBCDIC; the other in Latin1, but neither are
1256 # ASCII lowercase.
1257 ok(! Devel::PPPort::test_isLOWER_A(ord(0xDC)));
1258 ok(! Devel::PPPort::test_isLOWER_A(ord(0xFC)));
1259
1260 ok(  Devel::PPPort::test_isALPHA(ord("C")));
1261 ok(! Devel::PPPort::test_isALPHA(ord("1")));
1262
1263 ok(  Devel::PPPort::test_isALPHA_A(ord("x")));
1264 ok(! Devel::PPPort::test_isALPHA_A(0xDC));
1265
1266 ok(  Devel::PPPort::test_isWORDCHAR(ord("_")));
1267 ok(! Devel::PPPort::test_isWORDCHAR(ord("@")));
1268
1269 ok(  Devel::PPPort::test_isWORDCHAR_A(ord("2")));
1270 ok(! Devel::PPPort::test_isWORDCHAR_A(0xFC));
1271
1272 ok(  Devel::PPPort::test_isALPHANUMERIC(ord("4")));
1273 ok(! Devel::PPPort::test_isALPHANUMERIC(ord("_")));
1274
1275 ok(  Devel::PPPort::test_isALPHANUMERIC_A(ord("l")));
1276 ok(! Devel::PPPort::test_isALPHANUMERIC_A(0xDC));
1277
1278 ok(  Devel::PPPort::test_isALNUM(ord("c")));
1279 ok(! Devel::PPPort::test_isALNUM(ord("}")));
1280
1281 ok(  Devel::PPPort::test_isALNUM_A(ord("5")));
1282 ok(! Devel::PPPort::test_isALNUM_A(0xFC));
1283
1284 ok(  Devel::PPPort::test_isDIGIT(ord("6")));
1285 ok(! Devel::PPPort::test_isDIGIT(ord("_")));
1286
1287 ok(  Devel::PPPort::test_isDIGIT_A(ord("7")));
1288 ok(! Devel::PPPort::test_isDIGIT_A(0xDC));
1289
1290 ok(  Devel::PPPort::test_isOCTAL(ord("7")));
1291 ok(! Devel::PPPort::test_isOCTAL(ord("8")));
1292
1293 ok(  Devel::PPPort::test_isOCTAL_A(ord("0")));
1294 ok(! Devel::PPPort::test_isOCTAL_A(ord("9")));
1295
1296 ok(  Devel::PPPort::test_isIDFIRST(ord("D")));
1297 ok(! Devel::PPPort::test_isIDFIRST(ord("1")));
1298
1299 ok(  Devel::PPPort::test_isIDFIRST_A(ord("_")));
1300 ok(! Devel::PPPort::test_isIDFIRST_A(0xFC));
1301
1302 ok(  Devel::PPPort::test_isIDCONT(ord("e")));
1303 ok(! Devel::PPPort::test_isIDCONT(ord("@")));
1304
1305 ok(  Devel::PPPort::test_isIDCONT_A(ord("2")));
1306 ok(! Devel::PPPort::test_isIDCONT_A(0xDC));
1307
1308 ok(  Devel::PPPort::test_isSPACE(ord(" ")));
1309 ok(! Devel::PPPort::test_isSPACE(ord("_")));
1310
1311 ok(  Devel::PPPort::test_isSPACE_A(ord("\cK")));
1312 ok(! Devel::PPPort::test_isSPACE_A(ord("F")));
1313
1314 # This stresses the edge for ASCII machines, but happens to work on EBCDIC as
1315 # well
1316 ok(  Devel::PPPort::test_isASCII(0x7F));
1317 ok(! Devel::PPPort::test_isASCII(0x80));
1318
1319 ok(  Devel::PPPort::test_isASCII_A(ord("9")));
1320
1321 # B6 is the PARAGRAPH SIGN in ASCII and EBCDIC
1322 ok(! Devel::PPPort::test_isASCII_A(0xB6));
1323
1324 ok(  Devel::PPPort::test_isCNTRL(ord("\e")));
1325 ok(! Devel::PPPort::test_isCNTRL(ord(" ")));
1326
1327 ok(  Devel::PPPort::test_isCNTRL_A(ord("\a")));
1328 ok(! Devel::PPPort::test_isCNTRL_A(0xB6));
1329
1330 ok(  Devel::PPPort::test_isPRINT(ord(" ")));
1331 ok(! Devel::PPPort::test_isPRINT(ord("\n")));
1332
1333 ok(  Devel::PPPort::test_isPRINT_A(ord("G")));
1334 ok(! Devel::PPPort::test_isPRINT_A(0xB6));
1335
1336 ok(  Devel::PPPort::test_isGRAPH(ord("h")));
1337 ok(! Devel::PPPort::test_isGRAPH(ord(" ")));
1338
1339 ok(  Devel::PPPort::test_isGRAPH_A(ord("i")));
1340 ok(! Devel::PPPort::test_isGRAPH_A(0xB6));
1341
1342 ok(  Devel::PPPort::test_isPUNCT(ord("#")));
1343 ok(! Devel::PPPort::test_isPUNCT(ord(" ")));
1344
1345 ok(  Devel::PPPort::test_isPUNCT_A(ord("*")));
1346 ok(! Devel::PPPort::test_isPUNCT_A(0xB6));
1347
1348 ok(  Devel::PPPort::test_isXDIGIT(ord("A")));
1349 ok(! Devel::PPPort::test_isXDIGIT(ord("_")));
1350
1351 ok(  Devel::PPPort::test_isXDIGIT_A(ord("9")));
1352 ok(! Devel::PPPort::test_isXDIGIT_A(0xDC));
1353
1354 ok(  Devel::PPPort::test_isPSXSPC(ord(" ")));
1355 ok(! Devel::PPPort::test_isPSXSPC(ord("k")));
1356
1357 ok(  Devel::PPPort::test_isPSXSPC_A(ord("\cK")));
1358 ok(! Devel::PPPort::test_isPSXSPC_A(0xFC));