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__ 15END_EXTERN_C 16EXTERN_C 17INT2PTR 18MUTABLE_PTR 19NVTYPE 20PERLIO_FUNCS_CAST 21PERLIO_FUNCS_DECL 22PERL_STATIC_INLINE 23PERL_UNUSED_ARG 24PERL_UNUSED_CONTEXT 25PERL_UNUSED_DECL 26PERL_UNUSED_RESULT 27PERL_UNUSED_VAR 28PERL_USE_GCC_BRACE_GROUPS 29PTR2ul 30PTRV 31START_EXTERN_C 32STMT_END 33STMT_START 34SvRX 35WIDEST_UTYPE 36XSRETURN 37NOT_REACHED 38ASSUME 39 40=implementation 41 42#if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L 43__UNDEFINED__ PERL_STATIC_INLINE static inline 44#else 45__UNDEFINED__ PERL_STATIC_INLINE static 46#endif 47 48__UNDEFINED__ cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0) 49__UNDEFINED__ OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) 50__UNDEFINED__ OpSIBLING(o) (0 + (o)->op_sibling) 51__UNDEFINED__ OpMORESIB_set(o, sib) ((o)->op_sibling = (sib)) 52__UNDEFINED__ OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL) 53__UNDEFINED__ OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib)) 54__UNDEFINED__ HEf_SVKEY -2 55 56#if defined(DEBUGGING) && !defined(__COVERITY__) 57__UNDEFINED__ __ASSERT_(statement) assert(statement), 58#else 59__UNDEFINED__ __ASSERT_(statement) 60#endif 61 62__UNDEF_NOT_PROVIDED__ __has_builtin(x) 0 63 64#if __has_builtin(__builtin_unreachable) 65# define D_PPP_HAS_BUILTIN_UNREACHABLE 66#elif (defined(__GNUC__) && ( __GNUC__ > 4 \ 67 || __GNUC__ == 4 && __GNUC_MINOR__ >= 5)) 68# define D_PPP_HAS_BUILTIN_UNREACHABLE 69#endif 70 71#ifndef ASSUME 72# ifdef DEBUGGING 73# define ASSUME(x) assert(x) 74# elif defined(_MSC_VER) 75# define ASSUME(x) __assume(x) 76# elif defined(__ARMCC_VERSION) 77# define ASSUME(x) __promise(x) 78# elif defined(D_PPP_HAS_BUILTIN_UNREACHABLE) 79# define ASSUME(x) ((x) ? (void) 0 : __builtin_unreachable()) 80# else 81# define ASSUME(x) assert(x) 82# endif 83#endif 84 85#ifndef NOT_REACHED 86# ifdef D_PPP_HAS_BUILTIN_UNREACHABLE 87# define NOT_REACHED \ 88 STMT_START { \ 89 ASSUME(!"UNREACHABLE"); __builtin_unreachable(); \ 90 } STMT_END 91# elif ! defined(__GNUC__) && (defined(__sun) || defined(__hpux)) 92# define NOT_REACHED 93# else 94# define NOT_REACHED ASSUME(!"UNREACHABLE") 95# endif 96#endif 97 98#ifndef WIDEST_UTYPE 99# ifdef QUADKIND 100# ifdef U64TYPE 101# define WIDEST_UTYPE U64TYPE 102# else 103# define WIDEST_UTYPE unsigned Quad_t 104# endif 105# else 106# define WIDEST_UTYPE U32 107# endif 108#endif 109 110/* These could become provided if/when they become part of the public API */ 111__UNDEF_NOT_PROVIDED__ withinCOUNT(c, l, n) \ 112 (((WIDEST_UTYPE) (((c)) - ((l) | 0))) <= (((WIDEST_UTYPE) ((n) | 0)))) 113__UNDEF_NOT_PROVIDED__ inRANGE(c, l, u) \ 114 ( (sizeof(c) == sizeof(U8)) ? withinCOUNT(((U8) (c)), (l), ((u) - (l))) \ 115 : (sizeof(c) == sizeof(U32)) ? withinCOUNT(((U32) (c)), (l), ((u) - (l))) \ 116 : (withinCOUNT(((WIDEST_UTYPE) (c)), (l), ((u) - (l))))) 117 118/* The '| 0' part ensures a compiler error if c is not integer (like e.g., a 119 * pointer) */ 120#undef FITS_IN_8_BITS /* handy.h version uses a core-only constant */ 121__UNDEF_NOT_PROVIDED__ FITS_IN_8_BITS(c) ( (sizeof(c) == 1) \ 122 || !(((WIDEST_UTYPE)((c) | 0)) & ~0xFF)) 123 124/* Create the macro for "is'macro'_utf8_safe(s, e)". For code points below 125 * 256, it calls the equivalent _L1 macro by converting the UTF-8 to code 126 * point. That is so that it can automatically get the bug fixes done in this 127 * file. */ 128#define D_PPP_IS_GENERIC_UTF8_SAFE(s, e, macro) \ 129 (((e) - (s)) <= 0 \ 130 ? 0 \ 131 : UTF8_IS_INVARIANT((s)[0]) \ 132 ? is ## macro ## _L1((s)[0]) \ 133 : (((e) - (s)) < UTF8SKIP(s)) \ 134 ? 0 \ 135 : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \ 136 /* The cast in the line below is only to silence warnings */ \ 137 ? is ## macro ## _L1((WIDEST_UTYPE) LATIN1_TO_NATIVE( \ 138 UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \ 139 & UTF_START_MASK(2), \ 140 (s)[1]))) \ 141 : is ## macro ## _utf8(s)) 142 143/* Create the macro for "is'macro'_LC_utf8_safe(s, e)". For code points below 144 * 256, it calls the equivalent _L1 macro by converting the UTF-8 to code 145 * point. That is so that it can automatically get the bug fixes done in this 146 * file. */ 147#define D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, macro) \ 148 (((e) - (s)) <= 0 \ 149 ? 0 \ 150 : UTF8_IS_INVARIANT((s)[0]) \ 151 ? is ## macro ## _LC((s)[0]) \ 152 : (((e) - (s)) < UTF8SKIP(s)) \ 153 ? 0 \ 154 : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \ 155 /* The cast in the line below is only to silence warnings */ \ 156 ? is ## macro ## _LC((WIDEST_UTYPE) LATIN1_TO_NATIVE( \ 157 UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \ 158 & UTF_START_MASK(2), \ 159 (s)[1]))) \ 160 : is ## macro ## _utf8(s)) 161 162/* A few of the early functions are broken. For these and the non-LC case, 163 * machine generated code is substituted. But that code doesn't work for 164 * locales. This is just like the above macro, but at the end, we call the 165 * macro we've generated for the above 255 case, which is correct since locale 166 * isn't involved. This will generate extra code to handle the 0-255 inputs, 167 * but hopefully it will be optimized out by the C compiler. But just in case 168 * it isn't, this macro is only used on the few versions that are broken */ 169 170#define D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, macro) \ 171 (((e) - (s)) <= 0 \ 172 ? 0 \ 173 : UTF8_IS_INVARIANT((s)[0]) \ 174 ? is ## macro ## _LC((s)[0]) \ 175 : (((e) - (s)) < UTF8SKIP(s)) \ 176 ? 0 \ 177 : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \ 178 /* The cast in the line below is only to silence warnings */ \ 179 ? is ## macro ## _LC((WIDEST_UTYPE) LATIN1_TO_NATIVE( \ 180 UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \ 181 & UTF_START_MASK(2), \ 182 (s)[1]))) \ 183 : is ## macro ## _utf8_safe(s, e)) 184 185__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) 186__UNDEFINED__ SvRXOK(sv) (!!SvRX(sv)) 187 188#ifndef PERL_UNUSED_DECL 189# ifdef HASATTRIBUTE 190# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) 191# define PERL_UNUSED_DECL 192# else 193# define PERL_UNUSED_DECL __attribute__((unused)) 194# endif 195# else 196# define PERL_UNUSED_DECL 197# endif 198#endif 199 200#ifndef PERL_UNUSED_ARG 201# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ 202# include <note.h> 203# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) 204# else 205# define PERL_UNUSED_ARG(x) ((void)x) 206# endif 207#endif 208 209#ifndef PERL_UNUSED_VAR 210# define PERL_UNUSED_VAR(x) ((void)x) 211#endif 212 213#ifndef PERL_UNUSED_CONTEXT 214# ifdef USE_ITHREADS 215# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) 216# else 217# define PERL_UNUSED_CONTEXT 218# endif 219#endif 220 221#ifndef PERL_UNUSED_RESULT 222# if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT) 223# define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END 224# else 225# define PERL_UNUSED_RESULT(v) ((void)(v)) 226# endif 227#endif 228 229__UNDEFINED__ NOOP /*EMPTY*/(void)0 230 231#if { VERSION < 5.6.1 } && { VERSION < 5.27.7 } 232#undef dNOOP 233__UNDEFINED__ dNOOP struct Perl___notused_struct 234#endif 235 236#ifndef NVTYPE 237# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) 238# define NVTYPE long double 239# else 240# define NVTYPE double 241# endif 242typedef NVTYPE NV; 243#endif 244 245#ifndef INT2PTR 246# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) 247# define PTRV UV 248# define INT2PTR(any,d) (any)(d) 249# else 250# if PTRSIZE == LONGSIZE 251# define PTRV unsigned long 252# else 253# define PTRV unsigned 254# endif 255# define INT2PTR(any,d) (any)(PTRV)(d) 256# endif 257#endif 258 259#ifndef PTR2ul 260# if PTRSIZE == LONGSIZE 261# define PTR2ul(p) (unsigned long)(p) 262# else 263# define PTR2ul(p) INT2PTR(unsigned long,p) 264# endif 265#endif 266 267__UNDEFINED__ PTR2nat(p) (PTRV)(p) 268__UNDEFINED__ NUM2PTR(any,d) (any)PTR2nat(d) 269__UNDEFINED__ PTR2IV(p) INT2PTR(IV,p) 270__UNDEFINED__ PTR2UV(p) INT2PTR(UV,p) 271__UNDEFINED__ PTR2NV(p) NUM2PTR(NV,p) 272 273#undef START_EXTERN_C 274#undef END_EXTERN_C 275#undef EXTERN_C 276#ifdef __cplusplus 277# define START_EXTERN_C extern "C" { 278# define END_EXTERN_C } 279# define EXTERN_C extern "C" 280#else 281# define START_EXTERN_C 282# define END_EXTERN_C 283# define EXTERN_C extern 284#endif 285 286#if { VERSION < 5.004 } || defined(PERL_GCC_PEDANTIC) 287# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN 288__UNDEF_NOT_PROVIDED__ PERL_GCC_BRACE_GROUPS_FORBIDDEN 289# endif 290#endif 291 292#if ! defined(__GNUC__) || defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) || defined(__cplusplus) 293# undef PERL_USE_GCC_BRACE_GROUPS 294#else 295# ifndef PERL_USE_GCC_BRACE_GROUPS 296# define PERL_USE_GCC_BRACE_GROUPS 297# endif 298#endif 299 300#undef STMT_START 301#undef STMT_END 302#if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) 303# define STMT_START if (1) 304# define STMT_END else (void)0 305#else 306# define STMT_START do 307# define STMT_END while (0) 308#endif 309 310__UNDEFINED__ boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) 311 312/* DEFSV appears first in 5.004_56 */ 313__UNDEFINED__ DEFSV GvSV(PL_defgv) 314__UNDEFINED__ SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) 315__UNDEFINED__ DEFSV_set(sv) (DEFSV = (sv)) 316 317/* Older perls (<=5.003) lack AvFILLp */ 318__UNDEFINED__ AvFILLp AvFILL 319 320__UNDEFINED__ av_tindex AvFILL 321__UNDEFINED__ av_top_index AvFILL 322__UNDEFINED__ av_count(av) (AvFILL(av)+1) 323 324__UNDEFINED__ ERRSV get_sv("@",FALSE) 325 326/* Hint: gv_stashpvn 327 * This function's backport doesn't support the length parameter, but 328 * rather ignores it. Portability can only be ensured if the length 329 * parameter is used for speed reasons, but the length can always be 330 * correctly computed from the string argument. 331 */ 332 333__UNDEFINED__ gv_stashpvn(str,len,create) gv_stashpv(str,create) 334 335/* Replace: 1 */ 336__UNDEFINED__ get_cv perl_get_cv 337__UNDEFINED__ get_sv perl_get_sv 338__UNDEFINED__ get_av perl_get_av 339__UNDEFINED__ get_hv perl_get_hv 340/* Replace: 0 */ 341 342__UNDEFINED__ dUNDERBAR dNOOP 343__UNDEFINED__ UNDERBAR DEFSV 344 345__UNDEFINED__ dAX I32 ax = MARK - PL_stack_base + 1 346__UNDEFINED__ dITEMS I32 items = SP - MARK 347 348__UNDEFINED__ dXSTARG SV * targ = sv_newmortal() 349 350__UNDEFINED__ dAXMARK I32 ax = POPMARK; \ 351 SV ** const mark = PL_stack_base + ax++ 352 353 354__UNDEFINED__ XSprePUSH (sp = PL_stack_base + ax - 1) 355 356#if { VERSION < 5.005 } 357# undef XSRETURN 358# define XSRETURN(off) \ 359 STMT_START { \ 360 PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ 361 return; \ 362 } STMT_END 363#endif 364 365__UNDEFINED__ XSPROTO(name) void name(pTHX_ CV* cv) 366__UNDEFINED__ SVfARG(p) ((void*)(p)) 367 368__UNDEFINED__ PERL_ABS(x) ((x) < 0 ? -(x) : (x)) 369 370__UNDEFINED__ dVAR dNOOP 371 372__UNDEFINED__ SVf "_" 373 374__UNDEFINED__ CPERLscope(x) x 375 376__UNDEFINED__ PERL_HASH(hash,str,len) \ 377 STMT_START { \ 378 const char *s_PeRlHaSh = str; \ 379 I32 i_PeRlHaSh = len; \ 380 U32 hash_PeRlHaSh = 0; \ 381 while (i_PeRlHaSh--) \ 382 hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ 383 (hash) = hash_PeRlHaSh; \ 384 } STMT_END 385 386#ifndef PERLIO_FUNCS_DECL 387# ifdef PERLIO_FUNCS_CONST 388# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs 389# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) 390# else 391# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs 392# define PERLIO_FUNCS_CAST(funcs) (funcs) 393# endif 394#endif 395 396/* provide these typedefs for older perls */ 397#if { VERSION < 5.9.3 } 398 399# ifdef ARGSproto 400typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); 401# else 402typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); 403# endif 404 405typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); 406 407#endif 408 409/* On versions without NATIVE_TO_ASCII, only ASCII is supported */ 410#if defined(EBCDIC) && defined(NATIVE_TO_ASCI) 411__UNDEFINED__ NATIVE_TO_LATIN1(c) NATIVE_TO_ASCII(c) 412__UNDEFINED__ LATIN1_TO_NATIVE(c) ASCII_TO_NATIVE(c) 413__UNDEFINED__ NATIVE_TO_UNI(c) ((c) > 255 ? (c) : NATIVE_TO_LATIN1(c)) 414__UNDEFINED__ UNI_TO_NATIVE(c) ((c) > 255 ? (c) : LATIN1_TO_NATIVE(c)) 415#else 416__UNDEFINED__ NATIVE_TO_LATIN1(c) (c) 417__UNDEFINED__ LATIN1_TO_NATIVE(c) (c) 418__UNDEFINED__ NATIVE_TO_UNI(c) (c) 419__UNDEFINED__ UNI_TO_NATIVE(c) (c) 420#endif 421 422/* Warning: LATIN1_TO_NATIVE, NATIVE_TO_LATIN1 NATIVE_TO_UNI UNI_TO_NATIVE 423 EBCDIC is not supported on versions earlier than 5.7.1 424 */ 425 426/* The meaning of this changed; use the modern version */ 427#undef isPSXSPC 428#undef isPSXSPC_A 429#undef isPSXSPC_L1 430 431/* Hint: isPSXSPC, isPSXSPC_A, isPSXSPC_L1, isPSXSPC_utf8_safe 432 This is equivalent to the corresponding isSPACE-type macro. On perls 433 before 5.18, this matched a vertical tab and SPACE didn't. But the 434 ppport.h SPACE version does match VT in all perl releases. Since VT's are 435 extremely rarely found in real-life files, this difference effectively 436 doesn't matter */ 437 438/* Hint: isSPACE, isSPACE_A, isSPACE_L1, isSPACE_utf8_safe 439 Until Perl 5.18, this did not match the vertical tab (VT). The ppport.h 440 version does match it in all perl releases. Since VT's are extremely rarely 441 found in real-life files, this difference effectively doesn't matter */ 442 443#ifdef EBCDIC 444 445/* This is the first version where these macros are fully correct on EBCDIC 446 * platforms. Relying on the C library functions, as earlier releases did, 447 * causes problems with locales */ 448# if { VERSION < 5.22.0 } 449# undef isALNUM 450# undef isALNUM_A 451# undef isALNUM_L1 452# undef isALNUMC 453# undef isALNUMC_A 454# undef isALNUMC_L1 455# undef isALPHA 456# undef isALPHA_A 457# undef isALPHA_L1 458# undef isALPHANUMERIC 459# undef isALPHANUMERIC_A 460# undef isALPHANUMERIC_L1 461# undef isASCII 462# undef isASCII_A 463# undef isASCII_L1 464# undef isBLANK 465# undef isBLANK_A 466# undef isBLANK_L1 467# undef isCNTRL 468# undef isCNTRL_A 469# undef isCNTRL_L1 470# undef isDIGIT 471# undef isDIGIT_A 472# undef isDIGIT_L1 473# undef isGRAPH 474# undef isGRAPH_A 475# undef isGRAPH_L1 476# undef isIDCONT 477# undef isIDCONT_A 478# undef isIDCONT_L1 479# undef isIDFIRST 480# undef isIDFIRST_A 481# undef isIDFIRST_L1 482# undef isLOWER 483# undef isLOWER_A 484# undef isLOWER_L1 485# undef isOCTAL 486# undef isOCTAL_A 487# undef isOCTAL_L1 488# undef isPRINT 489# undef isPRINT_A 490# undef isPRINT_L1 491# undef isPUNCT 492# undef isPUNCT_A 493# undef isPUNCT_L1 494# undef isSPACE 495# undef isSPACE_A 496# undef isSPACE_L1 497# undef isUPPER 498# undef isUPPER_A 499# undef isUPPER_L1 500# undef isWORDCHAR 501# undef isWORDCHAR_A 502# undef isWORDCHAR_L1 503# undef isXDIGIT 504# undef isXDIGIT_A 505# undef isXDIGIT_L1 506# endif 507 508__UNDEFINED__ isASCII(c) (isCNTRL(c) || isPRINT(c)) 509 510 /* The below is accurate for all EBCDIC code pages supported by 511 * all the versions of Perl overridden by this */ 512__UNDEFINED__ isCNTRL(c) ( (c) == '\0' || (c) == '\a' || (c) == '\b' \ 513 || (c) == '\f' || (c) == '\n' || (c) == '\r' \ 514 || (c) == '\t' || (c) == '\v' \ 515 || ((c) <= 3 && (c) >= 1) /* SOH, STX, ETX */ \ 516 || (c) == 7 /* U+7F DEL */ \ 517 || ((c) <= 0x13 && (c) >= 0x0E) /* SO, SI */ \ 518 /* DLE, DC[1-3] */ \ 519 || (c) == 0x18 /* U+18 CAN */ \ 520 || (c) == 0x19 /* U+19 EOM */ \ 521 || ((c) <= 0x1F && (c) >= 0x1C) /* [FGRU]S */ \ 522 || (c) == 0x26 /* U+17 ETB */ \ 523 || (c) == 0x27 /* U+1B ESC */ \ 524 || (c) == 0x2D /* U+05 ENQ */ \ 525 || (c) == 0x2E /* U+06 ACK */ \ 526 || (c) == 0x32 /* U+16 SYN */ \ 527 || (c) == 0x37 /* U+04 EOT */ \ 528 || (c) == 0x3C /* U+14 DC4 */ \ 529 || (c) == 0x3D /* U+15 NAK */ \ 530 || (c) == 0x3F /* U+1A SUB */ \ 531 ) 532 533#if '^' == 106 /* EBCDIC POSIX-BC */ 534# define D_PPP_OUTLIER_CONTROL 0x5F 535#else /* EBCDIC 1047 037 */ 536# define D_PPP_OUTLIER_CONTROL 0xFF 537#endif 538 539/* The controls are everything below blank, plus one outlier */ 540__UNDEFINED__ isCNTRL_L1(c) ((WIDEST_UTYPE) (c) < ' ' \ 541 || (WIDEST_UTYPE) (c) == D_PPP_OUTLIER_CONTROL) 542/* The ordering of the tests in this and isUPPER are to exclude most characters 543 * early */ 544__UNDEFINED__ isLOWER(c) ( (c) >= 'a' && (c) <= 'z' \ 545 && ( (c) <= 'i' \ 546 || ((c) >= 'j' && (c) <= 'r') \ 547 || (c) >= 's')) 548__UNDEFINED__ isUPPER(c) ( (c) >= 'A' && (c) <= 'Z' \ 549 && ( (c) <= 'I' \ 550 || ((c) >= 'J' && (c) <= 'R') \ 551 || (c) >= 'S')) 552 553#else /* Above is EBCDIC; below is ASCII */ 554 555# if { VERSION < 5.4.0 } 556/* The implementation of these in older perl versions can give wrong results if 557 * the C program locale is set to other than the C locale */ 558# undef isALNUM 559# undef isALNUM_A 560# undef isALPHA 561# undef isALPHA_A 562# undef isDIGIT 563# undef isDIGIT_A 564# undef isIDFIRST 565# undef isIDFIRST_A 566# undef isLOWER 567# undef isLOWER_A 568# undef isUPPER 569# undef isUPPER_A 570# endif 571 572# if { VERSION == 5.7.0 } /* this perl made space GRAPH */ 573# undef isGRAPH 574# endif 575 576# if { VERSION < 5.8.0 } /* earlier perls omitted DEL */ 577# undef isCNTRL 578# endif 579 580# if { VERSION < 5.10.0 } 581/* earlier perls included all of the isSPACE() characters, which is wrong. The 582 * version provided by Devel::PPPort always overrides an existing buggy 583 * version. */ 584# undef isPRINT 585# undef isPRINT_A 586# endif 587 588# if { VERSION < 5.14.0 } 589/* earlier perls always returned true if the parameter was a signed char */ 590# undef isASCII 591# undef isASCII_A 592# endif 593 594# if { VERSION < 5.17.8 } /* earlier perls didn't include PILCROW, SECTION SIGN */ 595# undef isPUNCT_L1 596# endif 597 598# if { VERSION < 5.13.7 } /* khw didn't investigate why this failed */ 599# undef isALNUMC_L1 600#endif 601 602# if { VERSION < 5.20.0 } /* earlier perls didn't include \v */ 603# undef isSPACE 604# undef isSPACE_A 605# undef isSPACE_L1 606 607# endif 608 609__UNDEFINED__ isASCII(c) ((WIDEST_UTYPE) (c) <= 127) 610__UNDEFINED__ isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) 611__UNDEFINED__ isCNTRL_L1(c) ( (WIDEST_UTYPE) (c) < ' ' \ 612 || inRANGE((c), 0x7F, 0x9F)) 613__UNDEFINED__ isLOWER(c) inRANGE((c), 'a', 'z') 614__UNDEFINED__ isUPPER(c) inRANGE((c), 'A', 'Z') 615 616#endif /* Below are definitions common to EBCDIC and ASCII */ 617 618__UNDEFINED__ isASCII_L1(c) isASCII(c) 619__UNDEFINED__ isASCII_LC(c) isASCII(c) 620__UNDEFINED__ isALNUM(c) isWORDCHAR(c) 621__UNDEFINED__ isALNUMC(c) isALPHANUMERIC(c) 622__UNDEFINED__ isALNUMC_L1(c) isALPHANUMERIC_L1(c) 623__UNDEFINED__ isALPHA(c) (isUPPER(c) || isLOWER(c)) 624__UNDEFINED__ isALPHA_L1(c) (isUPPER_L1(c) || isLOWER_L1(c)) 625__UNDEFINED__ isALPHANUMERIC(c) (isALPHA(c) || isDIGIT(c)) 626__UNDEFINED__ isALPHANUMERIC_L1(c) (isALPHA_L1(c) || isDIGIT(c)) 627__UNDEFINED__ isALPHANUMERIC_LC(c) (isALPHA_LC(c) || isDIGIT_LC(c)) 628__UNDEFINED__ isBLANK(c) ((c) == ' ' || (c) == '\t') 629__UNDEFINED__ isBLANK_L1(c) ( isBLANK(c) \ 630 || ( FITS_IN_8_BITS(c) \ 631 && NATIVE_TO_LATIN1((U8) c) == 0xA0)) 632__UNDEFINED__ isBLANK_LC(c) isBLANK(c) 633__UNDEFINED__ isDIGIT(c) inRANGE(c, '0', '9') 634__UNDEFINED__ isDIGIT_L1(c) isDIGIT(c) 635__UNDEFINED__ isGRAPH(c) (isWORDCHAR(c) || isPUNCT(c)) 636__UNDEFINED__ isGRAPH_L1(c) ( isPRINT_L1(c) \ 637 && (c) != ' ' \ 638 && NATIVE_TO_LATIN1((U8) c) != 0xA0) 639__UNDEFINED__ isIDCONT(c) isWORDCHAR(c) 640__UNDEFINED__ isIDCONT_L1(c) isWORDCHAR_L1(c) 641__UNDEFINED__ isIDCONT_LC(c) isWORDCHAR_LC(c) 642__UNDEFINED__ isIDFIRST(c) (isALPHA(c) || (c) == '_') 643__UNDEFINED__ isIDFIRST_L1(c) (isALPHA_L1(c) || (U8) (c) == '_') 644__UNDEFINED__ isIDFIRST_LC(c) (isALPHA_LC(c) || (U8) (c) == '_') 645__UNDEFINED__ isLOWER_L1(c) ( isLOWER(c) \ 646 || ( FITS_IN_8_BITS(c) \ 647 && ( ( NATIVE_TO_LATIN1((U8) c) >= 0xDF \ 648 && NATIVE_TO_LATIN1((U8) c) != 0xF7) \ 649 || NATIVE_TO_LATIN1((U8) c) == 0xAA \ 650 || NATIVE_TO_LATIN1((U8) c) == 0xBA \ 651 || NATIVE_TO_LATIN1((U8) c) == 0xB5))) 652__UNDEFINED__ isOCTAL(c) (((WIDEST_UTYPE)((c)) & ~7) == '0') 653__UNDEFINED__ isOCTAL_L1(c) isOCTAL(c) 654__UNDEFINED__ isPRINT(c) (isGRAPH(c) || (c) == ' ') 655__UNDEFINED__ isPRINT_L1(c) (FITS_IN_8_BITS(c) && ! isCNTRL_L1(c)) 656__UNDEFINED__ isPSXSPC(c) isSPACE(c) 657__UNDEFINED__ isPSXSPC_L1(c) isSPACE_L1(c) 658__UNDEFINED__ isPUNCT(c) ( (c) == '-' || (c) == '!' || (c) == '"' \ 659 || (c) == '#' || (c) == '$' || (c) == '%' \ 660 || (c) == '&' || (c) == '\'' || (c) == '(' \ 661 || (c) == ')' || (c) == '*' || (c) == '+' \ 662 || (c) == ',' || (c) == '.' || (c) == '/' \ 663 || (c) == ':' || (c) == ';' || (c) == '<' \ 664 || (c) == '=' || (c) == '>' || (c) == '?' \ 665 || (c) == '@' || (c) == '[' || (c) == '\\' \ 666 || (c) == ']' || (c) == '^' || (c) == '_' \ 667 || (c) == '`' || (c) == '{' || (c) == '|' \ 668 || (c) == '}' || (c) == '~') 669__UNDEFINED__ isPUNCT_L1(c) ( isPUNCT(c) \ 670 || ( FITS_IN_8_BITS(c) \ 671 && ( NATIVE_TO_LATIN1((U8) c) == 0xA1 \ 672 || NATIVE_TO_LATIN1((U8) c) == 0xA7 \ 673 || NATIVE_TO_LATIN1((U8) c) == 0xAB \ 674 || NATIVE_TO_LATIN1((U8) c) == 0xB6 \ 675 || NATIVE_TO_LATIN1((U8) c) == 0xB7 \ 676 || NATIVE_TO_LATIN1((U8) c) == 0xBB \ 677 || NATIVE_TO_LATIN1((U8) c) == 0xBF))) 678__UNDEFINED__ isSPACE(c) ( isBLANK(c) || (c) == '\n' || (c) == '\r' \ 679 || (c) == '\v' || (c) == '\f') 680__UNDEFINED__ isSPACE_L1(c) ( isSPACE(c) \ 681 || (FITS_IN_8_BITS(c) \ 682 && ( NATIVE_TO_LATIN1((U8) c) == 0x85 \ 683 || NATIVE_TO_LATIN1((U8) c) == 0xA0))) 684__UNDEFINED__ isUPPER_L1(c) ( isUPPER(c) \ 685 || (FITS_IN_8_BITS(c) \ 686 && ( NATIVE_TO_LATIN1((U8) c) >= 0xC0 \ 687 && NATIVE_TO_LATIN1((U8) c) <= 0xDE \ 688 && NATIVE_TO_LATIN1((U8) c) != 0xD7))) 689__UNDEFINED__ isWORDCHAR(c) (isALPHANUMERIC(c) || (c) == '_') 690__UNDEFINED__ isWORDCHAR_L1(c) (isIDFIRST_L1(c) || isDIGIT(c)) 691__UNDEFINED__ isWORDCHAR_LC(c) (isIDFIRST_LC(c) || isDIGIT_LC(c)) 692__UNDEFINED__ isXDIGIT(c) ( isDIGIT(c) \ 693 || inRANGE((c), 'a', 'f') \ 694 || inRANGE((c), 'A', 'F')) 695__UNDEFINED__ isXDIGIT_L1(c) isXDIGIT(c) 696__UNDEFINED__ isXDIGIT_LC(c) isxdigit(c) 697 698__UNDEFINED__ isALNUM_A(c) isALNUM(c) 699__UNDEFINED__ isALNUMC_A(c) isALNUMC(c) 700__UNDEFINED__ isALPHA_A(c) isALPHA(c) 701__UNDEFINED__ isALPHANUMERIC_A(c) isALPHANUMERIC(c) 702__UNDEFINED__ isASCII_A(c) isASCII(c) 703__UNDEFINED__ isBLANK_A(c) isBLANK(c) 704__UNDEFINED__ isCNTRL_A(c) isCNTRL(c) 705__UNDEFINED__ isDIGIT_A(c) isDIGIT(c) 706__UNDEFINED__ isGRAPH_A(c) isGRAPH(c) 707__UNDEFINED__ isIDCONT_A(c) isIDCONT(c) 708__UNDEFINED__ isIDFIRST_A(c) isIDFIRST(c) 709__UNDEFINED__ isLOWER_A(c) isLOWER(c) 710__UNDEFINED__ isOCTAL_A(c) isOCTAL(c) 711__UNDEFINED__ isPRINT_A(c) isPRINT(c) 712__UNDEFINED__ isPSXSPC_A(c) isPSXSPC(c) 713__UNDEFINED__ isPUNCT_A(c) isPUNCT(c) 714__UNDEFINED__ isSPACE_A(c) isSPACE(c) 715__UNDEFINED__ isUPPER_A(c) isUPPER(c) 716__UNDEFINED__ isWORDCHAR_A(c) isWORDCHAR(c) 717__UNDEFINED__ isXDIGIT_A(c) isXDIGIT(c) 718 719__UNDEFINED__ isASCII_utf8_safe(s,e) (((e) - (s)) <= 0 ? 0 : isASCII(*(s))) 720__UNDEFINED__ isASCII_uvchr(c) (FITS_IN_8_BITS(c) ? isASCII_L1(c) : 0) 721 722#if { VERSION >= 5.006 } 723# ifdef isALPHA_uni /* If one defined, all are; this is just an exemplar */ 724# define D_PPP_is_ctype(upper, lower, c) \ 725 (FITS_IN_8_BITS(c) \ 726 ? is ## upper ## _L1(c) \ 727 : is ## upper ## _uni((UV) (c))) /* _uni is old synonym */ 728# else 729# define D_PPP_is_ctype(upper, lower, c) \ 730 (FITS_IN_8_BITS(c) \ 731 ? is ## upper ## _L1(c) \ 732 : is_uni_ ## lower((UV) (c))) /* is_uni_ is even older */ 733# endif 734 735__UNDEFINED__ isALPHA_uvchr(c) D_PPP_is_ctype(ALPHA, alpha, c) 736__UNDEFINED__ isALPHANUMERIC_uvchr(c) (isALPHA_uvchr(c) || isDIGIT_uvchr(c)) 737# ifdef is_uni_blank 738__UNDEFINED__ isBLANK_uvchr(c) D_PPP_is_ctype(BLANK, blank, c) 739# else 740__UNDEFINED__ isBLANK_uvchr(c) (FITS_IN_8_BITS(c) \ 741 ? isBLANK_L1(c) \ 742 : ( (UV) (c) == 0x1680 /* Unicode 3.0 */ \ 743 || inRANGE((UV) (c), 0x2000, 0x200A) \ 744 || (UV) (c) == 0x202F /* Unicode 3.0 */\ 745 || (UV) (c) == 0x205F /* Unicode 3.2 */\ 746 || (UV) (c) == 0x3000)) 747# endif 748__UNDEFINED__ isCNTRL_uvchr(c) D_PPP_is_ctype(CNTRL, cntrl, c) 749__UNDEFINED__ isDIGIT_uvchr(c) D_PPP_is_ctype(DIGIT, digit, c) 750__UNDEFINED__ isGRAPH_uvchr(c) D_PPP_is_ctype(GRAPH, graph, c) 751__UNDEFINED__ isIDCONT_uvchr(c) isWORDCHAR_uvchr(c) 752__UNDEFINED__ isIDFIRST_uvchr(c) D_PPP_is_ctype(IDFIRST, idfirst, c) 753__UNDEFINED__ isLOWER_uvchr(c) D_PPP_is_ctype(LOWER, lower, c) 754__UNDEFINED__ isPRINT_uvchr(c) D_PPP_is_ctype(PRINT, print, c) 755__UNDEFINED__ isPSXSPC_uvchr(c) isSPACE_uvchr(c) 756__UNDEFINED__ isPUNCT_uvchr(c) D_PPP_is_ctype(PUNCT, punct, c) 757__UNDEFINED__ isSPACE_uvchr(c) D_PPP_is_ctype(SPACE, space, c) 758__UNDEFINED__ isUPPER_uvchr(c) D_PPP_is_ctype(UPPER, upper, c) 759__UNDEFINED__ isXDIGIT_uvchr(c) D_PPP_is_ctype(XDIGIT, xdigit, c) 760__UNDEFINED__ isWORDCHAR_uvchr(c) (FITS_IN_8_BITS(c) \ 761 ? isWORDCHAR_L1(c) : isALPHANUMERIC_uvchr(c)) 762 763__UNDEFINED__ isALPHA_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, ALPHA) 764# ifdef isALPHANUMERIC_utf8 765__UNDEFINED__ isALPHANUMERIC_utf8_safe(s,e) \ 766 D_PPP_IS_GENERIC_UTF8_SAFE(s, e, ALPHANUMERIC) 767# else 768__UNDEFINED__ isALPHANUMERIC_utf8_safe(s,e) \ 769 (isALPHA_utf8_safe(s,e) || isDIGIT_utf8_safe(s,e)) 770# endif 771 772/* This was broken before 5.18, and just use this instead of worrying about 773 * which releases the official works on */ 774# if 'A' == 65 775__UNDEFINED__ isBLANK_utf8_safe(s,e) \ 776( ( LIKELY((e) > (s)) ) ? /* Machine generated */ \ 777 ( ( 0x09 == ((const U8*)s)[0] || 0x20 == ((const U8*)s)[0] ) ? 1 \ 778 : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \ 779 ( ( 0xC2 == ((const U8*)s)[0] ) ? \ 780 ( ( 0xA0 == ((const U8*)s)[1] ) ? 2 : 0 ) \ 781 : ( 0xE1 == ((const U8*)s)[0] ) ? \ 782 ( ( ( 0x9A == ((const U8*)s)[1] ) && ( 0x80 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ 783 : ( 0xE2 == ((const U8*)s)[0] ) ? \ 784 ( ( 0x80 == ((const U8*)s)[1] ) ? \ 785 ( ( inRANGE(((const U8*)s)[2], 0x80, 0x8A ) || 0xAF == ((const U8*)s)[2] ) ? 3 : 0 )\ 786 : ( ( 0x81 == ((const U8*)s)[1] ) && ( 0x9F == ((const U8*)s)[2] ) ) ? 3 : 0 )\ 787 : ( ( ( 0xE3 == ((const U8*)s)[0] ) && ( 0x80 == ((const U8*)s)[1] ) ) && ( 0x80 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ 788 : 0 ) \ 789 : 0 ) 790 791# elif 'A' == 193 && '^' == 95 /* EBCDIC 1047 */ 792 793__UNDEFINED__ isBLANK_utf8_safe(s,e) \ 794( ( LIKELY((e) > (s)) ) ? \ 795 ( ( 0x05 == ((const U8*)s)[0] || 0x40 == ((const U8*)s)[0] ) ? 1 \ 796 : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \ 797 ( ( 0x80 == ((const U8*)s)[0] ) ? \ 798 ( ( 0x41 == ((const U8*)s)[1] ) ? 2 : 0 ) \ 799 : ( 0xBC == ((const U8*)s)[0] ) ? \ 800 ( ( ( 0x63 == ((const U8*)s)[1] ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ 801 : ( 0xCA == ((const U8*)s)[0] ) ? \ 802 ( ( 0x41 == ((const U8*)s)[1] ) ? \ 803 ( ( inRANGE(((const U8*)s)[2], 0x41, 0x4A ) || 0x51 == ((const U8*)s)[2] ) ? 3 : 0 )\ 804 : ( 0x42 == ((const U8*)s)[1] ) ? \ 805 ( ( 0x56 == ((const U8*)s)[2] ) ? 3 : 0 ) \ 806 : ( ( 0x43 == ((const U8*)s)[1] ) && ( 0x73 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ 807 : ( ( ( 0xCE == ((const U8*)s)[0] ) && ( 0x41 == ((const U8*)s)[1] ) ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ 808 : 0 ) \ 809: 0 ) 810 811# elif 'A' == 193 && '^' == 176 /* EBCDIC 037 */ 812 813__UNDEFINED__ isBLANK_utf8_safe(s,e) \ 814( ( LIKELY((e) > (s)) ) ? \ 815 ( ( 0x05 == ((const U8*)s)[0] || 0x40 == ((const U8*)s)[0] ) ? 1 \ 816 : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \ 817 ( ( 0x78 == ((const U8*)s)[0] ) ? \ 818 ( ( 0x41 == ((const U8*)s)[1] ) ? 2 : 0 ) \ 819 : ( 0xBD == ((const U8*)s)[0] ) ? \ 820 ( ( ( 0x62 == ((const U8*)s)[1] ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ 821 : ( 0xCA == ((const U8*)s)[0] ) ? \ 822 ( ( 0x41 == ((const U8*)s)[1] ) ? \ 823 ( ( inRANGE(((const U8*)s)[2], 0x41, 0x4A ) || 0x51 == ((const U8*)s)[2] ) ? 3 : 0 )\ 824 : ( 0x42 == ((const U8*)s)[1] ) ? \ 825 ( ( 0x56 == ((const U8*)s)[2] ) ? 3 : 0 ) \ 826 : ( ( 0x43 == ((const U8*)s)[1] ) && ( 0x72 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ 827 : ( ( ( 0xCE == ((const U8*)s)[0] ) && ( 0x41 == ((const U8*)s)[1] ) ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ 828 : 0 ) \ 829: 0 ) 830 831# else 832# error Unknown character set 833# endif 834 835__UNDEFINED__ isCNTRL_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, CNTRL) 836__UNDEFINED__ isDIGIT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, DIGIT) 837__UNDEFINED__ isGRAPH_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, GRAPH) 838# ifdef isIDCONT_utf8 839__UNDEFINED__ isIDCONT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, IDCONT) 840# else 841__UNDEFINED__ isIDCONT_utf8_safe(s,e) isWORDCHAR_utf8_safe(s,e) 842# endif 843 844__UNDEFINED__ isIDFIRST_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, IDFIRST) 845__UNDEFINED__ isLOWER_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, LOWER) 846__UNDEFINED__ isPRINT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, PRINT) 847 848# undef isPSXSPC_utf8_safe /* Use the modern definition */ 849__UNDEFINED__ isPSXSPC_utf8_safe(s,e) isSPACE_utf8_safe(s,e) 850 851__UNDEFINED__ isPUNCT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, PUNCT) 852__UNDEFINED__ isSPACE_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, SPACE) 853__UNDEFINED__ isUPPER_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, UPPER) 854 855# ifdef isWORDCHAR_utf8 856__UNDEFINED__ isWORDCHAR_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, WORDCHAR) 857# else 858__UNDEFINED__ isWORDCHAR_utf8_safe(s,e) \ 859 (isALPHANUMERIC_utf8_safe(s,e) || (*(s)) == '_') 860# endif 861 862/* This was broken before 5.12, and just use this instead of worrying about 863 * which releases the official works on */ 864# if 'A' == 65 865__UNDEFINED__ isXDIGIT_utf8_safe(s,e) \ 866( ( LIKELY((e) > (s)) ) ? \ 867 ( ( inRANGE(((const U8*)s)[0], 0x30, 0x39 ) || inRANGE(((const U8*)s)[0], 0x41, 0x46 ) || inRANGE(((const U8*)s)[0], 0x61, 0x66 ) ) ? 1\ 868 : ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xEF == ((const U8*)s)[0] ) ) ? ( ( 0xBC == ((const U8*)s)[1] ) ?\ 869 ( ( inRANGE(((const U8*)s)[2], 0x90, 0x99 ) || inRANGE(((const U8*)s)[2], 0xA1, 0xA6 ) ) ? 3 : 0 )\ 870 : ( ( 0xBD == ((const U8*)s)[1] ) && ( inRANGE(((const U8*)s)[2], 0x81, 0x86 ) ) ) ? 3 : 0 ) : 0 )\ 871: 0 ) 872 873# elif 'A' == 193 && '^' == 95 /* EBCDIC 1047 */ 874 875__UNDEFINED__ isXDIGIT_utf8_safe(s,e) \ 876( ( LIKELY((e) > (s)) ) ? \ 877 ( ( inRANGE(((const U8*)s)[0], 0x81, 0x86 ) || inRANGE(((const U8*)s)[0], 0xC1, 0xC6 ) || inRANGE(((const U8*)s)[0], 0xF0, 0xF9 ) ) ? 1\ 878 : ( ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xDD == ((const U8*)s)[0] ) ) && ( 0x73 == ((const U8*)s)[1] ) ) ? ( ( 0x67 == ((const U8*)s)[2] ) ?\ 879 ( ( inRANGE(((const U8*)s)[3], 0x57, 0x59 ) || inRANGE(((const U8*)s)[3], 0x62, 0x68 ) ) ? 4 : 0 )\ 880 : ( ( inRANGE(((const U8*)s)[2], 0x68, 0x69 ) ) && ( inRANGE(((const U8*)s)[3], 0x42, 0x47 ) ) ) ? 4 : 0 ) : 0 )\ 881: 0 ) 882 883# elif 'A' == 193 && '^' == 176 /* EBCDIC 037 */ 884 885__UNDEFINED__ isXDIGIT_utf8_safe(s,e) \ 886( ( LIKELY((e) > (s)) ) ? \ 887 ( ( inRANGE(((const U8*)s)[0], 0x81, 0x86 ) || inRANGE(((const U8*)s)[0], 0xC1, 0xC6 ) || inRANGE(((const U8*)s)[0], 0xF0, 0xF9 ) ) ? 1\ 888 : ( ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xDD == ((const U8*)s)[0] ) ) && ( 0x72 == ((const U8*)s)[1] ) ) ? ( ( 0x66 == ((const U8*)s)[2] ) ?\ 889 ( ( inRANGE(((const U8*)s)[3], 0x57, 0x59 ) || 0x5F == ((const U8*)s)[3] || inRANGE(((const U8*)s)[3], 0x62, 0x67 ) ) ? 4 : 0 )\ 890 : ( ( inRANGE(((const U8*)s)[2], 0x67, 0x68 ) ) && ( inRANGE(((const U8*)s)[3], 0x42, 0x47 ) ) ) ? 4 : 0 ) : 0 )\ 891: 0 ) 892 893# else 894# error Unknown character set 895# endif 896 897__UNDEFINED__ isALPHA_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, ALPHA) 898# ifdef isALPHANUMERIC_utf8 899__UNDEFINED__ isALPHANUMERIC_LC_utf8_safe(s,e) \ 900 D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, ALPHANUMERIC) 901# else 902__UNDEFINED__ isALPHANUMERIC_LC_utf8_safe(s,e) \ 903 (isALPHA_LC_utf8_safe(s,e) || isDIGIT_LC_utf8_safe(s,e)) 904# endif 905 906__UNDEFINED__ isBLANK_LC_utf8_safe(s,e) \ 907 D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, BLANK) 908__UNDEFINED__ isCNTRL_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, CNTRL) 909__UNDEFINED__ isDIGIT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, DIGIT) 910__UNDEFINED__ isGRAPH_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, GRAPH) 911# ifdef isIDCONT_utf8 912__UNDEFINED__ isIDCONT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, IDCONT) 913# else 914__UNDEFINED__ isIDCONT_LC_utf8_safe(s,e) isWORDCHAR_LC_utf8_safe(s,e) 915# endif 916 917__UNDEFINED__ isIDFIRST_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, IDFIRST) 918__UNDEFINED__ isLOWER_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, LOWER) 919__UNDEFINED__ isPRINT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, PRINT) 920 921# undef isPSXSPC_LC_utf8_safe /* Use the modern definition */ 922__UNDEFINED__ isPSXSPC_LC_utf8_safe(s,e) isSPACE_LC_utf8_safe(s,e) 923 924__UNDEFINED__ isPUNCT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, PUNCT) 925__UNDEFINED__ isSPACE_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, SPACE) 926__UNDEFINED__ isUPPER_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, UPPER) 927 928# ifdef isWORDCHAR_utf8 929__UNDEFINED__ isWORDCHAR_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, WORDCHAR) 930# else 931__UNDEFINED__ isWORDCHAR_LC_utf8_safe(s,e) \ 932 (isALPHANUMERIC_LC_utf8_safe(s,e) || (*(s)) == '_') 933# endif 934 935__UNDEFINED__ isXDIGIT_LC_utf8_safe(s,e) \ 936 D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, XDIGIT) 937 938/* Warning: isALPHANUMERIC_utf8_safe, isALPHA_utf8_safe, isASCII_utf8_safe, 939 * isBLANK_utf8_safe, isCNTRL_utf8_safe, isDIGIT_utf8_safe, isGRAPH_utf8_safe, 940 * isIDCONT_utf8_safe, isIDFIRST_utf8_safe, isLOWER_utf8_safe, 941 * isPRINT_utf8_safe, isPSXSPC_utf8_safe, isPUNCT_utf8_safe, isSPACE_utf8_safe, 942 * isUPPER_utf8_safe, isWORDCHAR_utf8_safe, isWORDCHAR_utf8_safe, 943 * isXDIGIT_utf8_safe, 944 * isALPHANUMERIC_LC_utf8_safe, isALPHA_LC_utf8_safe, isASCII_LC_utf8_safe, 945 * isBLANK_LC_utf8_safe, isCNTRL_LC_utf8_safe, isDIGIT_LC_utf8_safe, 946 * isGRAPH_LC_utf8_safe, isIDCONT_LC_utf8_safe, isIDFIRST_LC_utf8_safe, 947 * isLOWER_LC_utf8_safe, isPRINT_LC_utf8_safe, isPSXSPC_LC_utf8_safe, 948 * isPUNCT_LC_utf8_safe, isSPACE_LC_utf8_safe, isUPPER_LC_utf8_safe, 949 * isWORDCHAR_LC_utf8_safe, isWORDCHAR_LC_utf8_safe, isXDIGIT_LC_utf8_safe, 950 * isALPHANUMERIC_uvchr, isALPHA_uvchr, isASCII_uvchr, isBLANK_uvchr, 951 * isCNTRL_uvchr, isDIGIT_uvchr, isGRAPH_uvchr, isIDCONT_uvchr, 952 * isIDFIRST_uvchr, isLOWER_uvchr, isPRINT_uvchr, isPSXSPC_uvchr, 953 * isPUNCT_uvchr, isSPACE_uvchr, isUPPER_uvchr, isWORDCHAR_uvchr, 954 * isWORDCHAR_uvchr, isXDIGIT_uvchr 955 * 956 * The UTF-8 handling is buggy in early Perls, and this can give inaccurate 957 * results for code points above 0xFF, until the implementation started 958 * settling down in 5.12 and 5.14 */ 959 960#endif 961 962#define D_PPP_TOO_SHORT_MSG "Malformed UTF-8 character starting with:" \ 963 " \\x%02x (too short; %d bytes available, need" \ 964 " %d)\n" 965/* Perls starting here had a new API which handled multi-character results */ 966#if { VERSION >= 5.7.3 } 967 968__UNDEFINED__ toLOWER_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_lower(NATIVE_TO_UNI(c), s, l)) 969__UNDEFINED__ toUPPER_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_upper(NATIVE_TO_UNI(c), s, l)) 970__UNDEFINED__ toTITLE_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_title(NATIVE_TO_UNI(c), s, l)) 971__UNDEFINED__ toFOLD_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_fold( NATIVE_TO_UNI(c), s, l)) 972 973# if { VERSION != 5.15.6 } /* Just this version is broken */ 974 975 /* Prefer the macro to the function */ 976# if defined toLOWER_utf8 977# define D_PPP_TO_LOWER_CALLEE(s,r,l) toLOWER_utf8(s,r,l) 978# else 979# define D_PPP_TO_LOWER_CALLEE(s,r,l) to_utf8_lower(s,r,l) 980# endif 981# if defined toTITLE_utf8 982# define D_PPP_TO_TITLE_CALLEE(s,r,l) toTITLE_utf8(s,r,l) 983# else 984# define D_PPP_TO_TITLE_CALLEE(s,r,l) to_utf8_title(s,r,l) 985# endif 986# if defined toUPPER_utf8 987# define D_PPP_TO_UPPER_CALLEE(s,r,l) toUPPER_utf8(s,r,l) 988# else 989# define D_PPP_TO_UPPER_CALLEE(s,r,l) to_utf8_upper(s,r,l) 990# endif 991# if defined toFOLD_utf8 992# define D_PPP_TO_FOLD_CALLEE(s,r,l) toFOLD_utf8(s,r,l) 993# else 994# define D_PPP_TO_FOLD_CALLEE(s,r,l) to_utf8_fold(s,r,l) 995# endif 996# else /* Below is 5.15.6, which failed to make the macros available 997# outside of core, so we have to use the 'Perl_' form. khw 998# decided it was easier to just handle this case than have to 999# document the exception, and make an exception in the tests below 1000# */ 1001# define D_PPP_TO_LOWER_CALLEE(s,r,l) \ 1002 Perl__to_utf8_lower_flags(aTHX_ s, r, l, 0, NULL) 1003# define D_PPP_TO_TITLE_CALLEE(s,r,l) \ 1004 Perl__to_utf8_title_flags(aTHX_ s, r, l, 0, NULL) 1005# define D_PPP_TO_UPPER_CALLEE(s,r,l) \ 1006 Perl__to_utf8_upper_flags(aTHX_ s, r, l, 0, NULL) 1007# define D_PPP_TO_FOLD_CALLEE(s,r,l) \ 1008 Perl__to_utf8_fold_flags(aTHX_ s, r, l, FOLD_FLAGS_FULL, NULL) 1009# endif 1010 1011/* The actual implementation of the backported macros. If too short, croak, 1012 * otherwise call the original that doesn't have an upper limit parameter */ 1013# define D_PPP_GENERIC_MULTI_ARG_TO(name, s, e,r,l) \ 1014 (((((e) - (s)) <= 0) \ 1015 /* We could just do nothing, but modern perls croak */ \ 1016 ? (croak("Attempting case change on zero length string"), \ 1017 0) /* So looks like it returns something, and will compile */ \ 1018 : ((e) - (s)) < UTF8SKIP(s)) \ 1019 ? (croak(D_PPP_TOO_SHORT_MSG, \ 1020 s[0], (int) ((e) - (s)), (int) UTF8SKIP(s)), \ 1021 0) \ 1022 : D_PPP_TO_ ## name ## _CALLEE(s,r,l)) 1023 1024__UNDEFINED__ toUPPER_utf8_safe(s,e,r,l) \ 1025 D_PPP_GENERIC_MULTI_ARG_TO(UPPER,s,e,r,l) 1026__UNDEFINED__ toLOWER_utf8_safe(s,e,r,l) \ 1027 D_PPP_GENERIC_MULTI_ARG_TO(LOWER,s,e,r,l) 1028__UNDEFINED__ toTITLE_utf8_safe(s,e,r,l) \ 1029 D_PPP_GENERIC_MULTI_ARG_TO(TITLE,s,e,r,l) 1030__UNDEFINED__ toFOLD_utf8_safe(s,e,r,l) \ 1031 D_PPP_GENERIC_MULTI_ARG_TO(FOLD,s,e,r,l) 1032 1033#elif { VERSION >= 5.006 } 1034 1035/* Here we have UTF-8 support, but using the original API where the case 1036 * changing functions merely returned the changed code point; hence they 1037 * couldn't handle multi-character results. */ 1038 1039# ifdef uvchr_to_utf8 1040# define D_PPP_UV_TO_UTF8 uvchr_to_utf8 1041# else 1042# define D_PPP_UV_TO_UTF8 uv_to_utf8 1043# endif 1044 1045 /* Get the utf8 of the case changed value, and store its length; then have 1046 * to re-calculate the changed case value in order to return it */ 1047# define D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(name, c, s, l) \ 1048 (*(l) = (D_PPP_UV_TO_UTF8(s, \ 1049 UNI_TO_NATIVE(to_uni_ ## name(NATIVE_TO_UNI(c)))) - (s)), \ 1050 UNI_TO_NATIVE(to_uni_ ## name(NATIVE_TO_UNI(c)))) 1051 1052__UNDEFINED__ toLOWER_uvchr(c, s, l) \ 1053 D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(lower, c, s, l) 1054__UNDEFINED__ toUPPER_uvchr(c, s, l) \ 1055 D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(upper, c, s, l) 1056__UNDEFINED__ toTITLE_uvchr(c, s, l) \ 1057 D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(title, c, s, l) 1058__UNDEFINED__ toFOLD_uvchr(c, s, l) toLOWER_uvchr(c, s, l) 1059 1060# define D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(name, s, e, r, l) \ 1061 (((((e) - (s)) <= 0) \ 1062 ? (croak("Attempting case change on zero length string"), \ 1063 0) /* So looks like it returns something, and will compile */ \ 1064 : ((e) - (s)) < UTF8SKIP(s)) \ 1065 ? (croak(D_PPP_TOO_SHORT_MSG, \ 1066 s[0], (int) ((e) - (s)), (int) UTF8SKIP(s)), \ 1067 0) \ 1068 /* Get the changed code point and store its UTF-8 */ \ 1069 : D_PPP_UV_TO_UTF8(r, to_utf8_ ## name(s)), \ 1070 /* Then store its length, and re-get code point for return */ \ 1071 *(l) = UTF8SKIP(r), to_utf8_ ## name(r)) 1072 1073/* Warning: toUPPER_utf8_safe, toLOWER_utf8_safe, toTITLE_utf8_safe, 1074 * toUPPER_uvchr, toLOWER_uvchr, toTITLE_uvchr 1075 The UTF-8 case changing operations had bugs before around 5.12 or 5.14; 1076 this backport does not correct them. 1077 1078 In perls before 7.3, multi-character case changing is not implemented; this 1079 backport uses the simple case changes available in those perls. */ 1080 1081__UNDEFINED__ toUPPER_utf8_safe(s,e,r,l) \ 1082 D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(upper, s, e, r, l) 1083__UNDEFINED__ toLOWER_utf8_safe(s,e,r,l) \ 1084 D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(lower, s, e, r, l) 1085__UNDEFINED__ toTITLE_utf8_safe(s,e,r,l) \ 1086 D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(title, s, e, r, l) 1087 1088 /* Warning: toFOLD_utf8_safe, toFOLD_uvchr 1089 The UTF-8 case changing operations had bugs before around 5.12 or 5.14; 1090 this backport does not correct them. 1091 1092 In perls before 7.3, case folding is not implemented; instead, this 1093 backport substitutes simple (not multi-character, which isn't available) 1094 lowercasing. This gives the correct result in most, but not all, instances 1095 */ 1096 1097__UNDEFINED__ toFOLD_utf8_safe(s,e,r,l) toLOWER_utf8_safe(s,e,r,l) 1098 1099#endif 1100 1101/* Until we figure out how to support this in older perls... */ 1102#if { VERSION >= 5.8.0 } 1103 1104__UNDEFINED__ HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ 1105 SvUTF8(HeKEY_sv(he)) : \ 1106 (U32)HeKUTF8(he)) 1107 1108#endif 1109 1110__UNDEFINED__ C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0])) 1111__UNDEFINED__ C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a)) 1112 1113__UNDEFINED__ LIKELY(x) (x) 1114__UNDEFINED__ UNLIKELY(x) (x) 1115 1116#ifndef MUTABLE_PTR 1117#if defined(PERL_USE_GCC_BRACE_GROUPS) 1118# define MUTABLE_PTR(p) ({ void *_p = (p); _p; }) 1119#else 1120# define MUTABLE_PTR(p) ((void *) (p)) 1121#endif 1122#endif 1123 1124__UNDEFINED__ MUTABLE_AV(p) ((AV *)MUTABLE_PTR(p)) 1125__UNDEFINED__ MUTABLE_CV(p) ((CV *)MUTABLE_PTR(p)) 1126__UNDEFINED__ MUTABLE_GV(p) ((GV *)MUTABLE_PTR(p)) 1127__UNDEFINED__ MUTABLE_HV(p) ((HV *)MUTABLE_PTR(p)) 1128__UNDEFINED__ MUTABLE_IO(p) ((IO *)MUTABLE_PTR(p)) 1129__UNDEFINED__ MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p)) 1130 1131=xsmisc 1132 1133typedef XSPROTO(XSPROTO_test_t); 1134typedef XSPROTO_test_t *XSPROTO_test_t_ptr; 1135 1136XS(XS_Devel__PPPort_dXSTARG); /* prototype */ 1137XS(XS_Devel__PPPort_dXSTARG) 1138{ 1139 dXSARGS; 1140 dXSTARG; 1141 IV iv; 1142 1143 PERL_UNUSED_VAR(cv); 1144 SP -= items; 1145 iv = SvIV(ST(0)) + 1; 1146 PUSHi(iv); 1147 XSRETURN(1); 1148} 1149 1150XS(XS_Devel__PPPort_dAXMARK); /* prototype */ 1151XS(XS_Devel__PPPort_dAXMARK) 1152{ 1153 dSP; 1154 dAXMARK; 1155 dITEMS; 1156 IV iv; 1157 1158 PERL_UNUSED_VAR(cv); 1159 SP -= items; 1160 iv = SvIV(ST(0)) - 1; 1161 mPUSHi(iv); 1162 XSRETURN(1); 1163} 1164 1165=xsboot 1166 1167{ 1168 XSPROTO_test_t_ptr p = &XS_Devel__PPPort_dXSTARG; 1169 newXS("Devel::PPPort::dXSTARG", *p, file); 1170} 1171newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file); 1172 1173=xsubs 1174 1175int 1176OpSIBLING_tests() 1177 PREINIT: 1178 OP *x = NULL; 1179 OP *kid = NULL; 1180 OP *middlekid = NULL; 1181 OP *lastkid = NULL; 1182 int count = 0; 1183 int failures = 0; 1184 int i; 1185 CODE: 1186 x = newOP(OP_PUSHMARK, 0); 1187 1188 /* No siblings yet! */ 1189 if (OpHAS_SIBLING(x) || OpSIBLING(x)) { 1190 failures++; warn("Op should not have had a sib"); 1191 } 1192 1193 1194 /* Add 2 siblings */ 1195 kid = x; 1196 1197 for (i = 0; i < 2; i++) { 1198 OP *newsib = newOP(OP_PUSHMARK, 0); 1199 OpMORESIB_set(kid, newsib); 1200 1201 kid = OpSIBLING(kid); 1202 lastkid = kid; 1203 } 1204 middlekid = OpSIBLING(x); 1205 1206 /* Should now have a sibling */ 1207 if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) { 1208 failures++; warn("Op should have had a sib after moresib_set"); 1209 } 1210 1211 /* Count the siblings */ 1212 for (kid = OpSIBLING(x); kid; kid = OpSIBLING(kid)) { 1213 count++; 1214 } 1215 1216 if (count != 2) { 1217 failures++; warn("Kid had %d sibs, expected 2", count); 1218 } 1219 1220 if (OpHAS_SIBLING(lastkid) || OpSIBLING(lastkid)) { 1221 failures++; warn("Last kid should not have a sib"); 1222 } 1223 1224 /* Really sets the parent, and says 'no more siblings' */ 1225 OpLASTSIB_set(x, lastkid); 1226 1227 if (OpHAS_SIBLING(x) || OpSIBLING(x)) { 1228 failures++; warn("OpLASTSIB_set failed?"); 1229 } 1230 1231 /* Restore the kid */ 1232 OpMORESIB_set(x, lastkid); 1233 1234 /* Try to remove it again */ 1235 OpLASTSIB_set(x, NULL); 1236 1237 if (OpHAS_SIBLING(x) || OpSIBLING(x)) { 1238 failures++; warn("OpLASTSIB_set with NULL failed?"); 1239 } 1240 1241 /* Try to restore with maybesib_set */ 1242 OpMAYBESIB_set(x, lastkid, NULL); 1243 1244 if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) { 1245 failures++; warn("Op should have had a sib after maybesibset"); 1246 } 1247 1248 op_free(lastkid); 1249 op_free(middlekid); 1250 op_free(x); 1251 RETVAL = failures; 1252 OUTPUT: 1253 RETVAL 1254 1255int 1256SvRXOK(sv) 1257 SV *sv 1258 CODE: 1259 RETVAL = SvRXOK(sv); 1260 OUTPUT: 1261 RETVAL 1262 1263int 1264ptrtests() 1265 PREINIT: 1266 int var, *p = &var; 1267 1268 CODE: 1269 RETVAL = 0; 1270 RETVAL += PTR2nat(p) != 0 ? 1 : 0; 1271 RETVAL += PTR2ul(p) != 0UL ? 2 : 0; 1272 RETVAL += PTR2UV(p) != (UV) 0 ? 4 : 0; 1273 RETVAL += PTR2IV(p) != (IV) 0 ? 8 : 0; 1274 RETVAL += PTR2NV(p) != (NV) 0 ? 16 : 0; 1275 RETVAL += p > NUM2PTR(int *, 0) ? 32 : 0; 1276 1277 OUTPUT: 1278 RETVAL 1279 1280int 1281gv_stashpvn(name, create) 1282 char *name 1283 I32 create 1284 CODE: 1285 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL; 1286 OUTPUT: 1287 RETVAL 1288 1289int 1290get_sv(name, create) 1291 char *name 1292 I32 create 1293 CODE: 1294 RETVAL = get_sv(name, create) != NULL; 1295 OUTPUT: 1296 RETVAL 1297 1298int 1299get_av(name, create) 1300 char *name 1301 I32 create 1302 CODE: 1303 RETVAL = get_av(name, create) != NULL; 1304 OUTPUT: 1305 RETVAL 1306 1307int 1308get_hv(name, create) 1309 char *name 1310 I32 create 1311 CODE: 1312 RETVAL = get_hv(name, create) != NULL; 1313 OUTPUT: 1314 RETVAL 1315 1316int 1317get_cv(name, create) 1318 char *name 1319 I32 create 1320 CODE: 1321 RETVAL = get_cv(name, create) != NULL; 1322 OUTPUT: 1323 RETVAL 1324 1325void 1326xsreturn(two) 1327 int two 1328 PPCODE: 1329 mXPUSHp("test1", 5); 1330 if (two) 1331 mXPUSHp("test2", 5); 1332 if (two) 1333 XSRETURN(2); 1334 else 1335 XSRETURN(1); 1336 1337SV* 1338boolSV(value) 1339 int value 1340 CODE: 1341 RETVAL = newSVsv(boolSV(value)); 1342 OUTPUT: 1343 RETVAL 1344 1345SV* 1346DEFSV() 1347 CODE: 1348 RETVAL = newSVsv(DEFSV); 1349 OUTPUT: 1350 RETVAL 1351 1352void 1353DEFSV_modify() 1354 PPCODE: 1355 XPUSHs(sv_mortalcopy(DEFSV)); 1356 ENTER; 1357 SAVE_DEFSV; 1358 DEFSV_set(newSVpvs("DEFSV")); 1359 XPUSHs(sv_mortalcopy(DEFSV)); 1360 /* Yes, this leaks the above scalar; 5.005 with threads for some reason */ 1361 /* frees it upon LEAVE, thus mortalizing it causes "attempt to free..." */ 1362 /* sv_2mortal(DEFSV); */ 1363 LEAVE; 1364 XPUSHs(sv_mortalcopy(DEFSV)); 1365 XSRETURN(3); 1366 1367int 1368ERRSV() 1369 CODE: 1370 RETVAL = SvTRUEx(ERRSV); 1371 OUTPUT: 1372 RETVAL 1373 1374SV* 1375UNDERBAR() 1376 CODE: 1377 { 1378 dUNDERBAR; 1379 RETVAL = newSVsv(UNDERBAR); 1380 } 1381 OUTPUT: 1382 RETVAL 1383 1384void 1385prepush() 1386 CODE: 1387 { 1388 dXSTARG; 1389 XSprePUSH; 1390 PUSHi(42); 1391 XSRETURN(1); 1392 } 1393 1394int 1395PERL_ABS(a) 1396 int a 1397 1398void 1399SVf(x) 1400 SV *x 1401 PPCODE: 1402#if { VERSION >= 5.004 } 1403 x = sv_2mortal(newSVpvf("[%" SVf "]", SVfARG(x))); 1404#endif 1405 XPUSHs(x); 1406 XSRETURN(1); 1407 1408void 1409Perl_ppaddr_t(string) 1410 char *string 1411 PREINIT: 1412 Perl_ppaddr_t lower; 1413 PPCODE: 1414 lower = PL_ppaddr[OP_LC]; 1415 mXPUSHs(newSVpv(string, 0)); 1416 PUTBACK; 1417 ENTER; 1418 (void)*(lower)(aTHXR); 1419 SPAGAIN; 1420 LEAVE; 1421 XSRETURN(1); 1422 1423#if { VERSION >= 5.8.0 } 1424 1425void 1426check_HeUTF8(utf8_key) 1427 SV *utf8_key; 1428 PREINIT: 1429 HV *hash; 1430 HE *ent; 1431 STRLEN klen; 1432 char *key; 1433 PPCODE: 1434 hash = newHV(); 1435 1436 key = SvPV(utf8_key, klen); 1437 hv_store(hash, key, SvUTF8(utf8_key) ? -klen : klen, 1438 newSVpvs("string"), 0); 1439 hv_iterinit(hash); 1440 ent = hv_iternext(hash); 1441 assert(ent); 1442 mXPUSHp((HeUTF8(ent) == 0 ? "norm" : "utf8"), 4); 1443 hv_undef(hash); 1444 1445 1446#endif 1447 1448void 1449check_c_array() 1450 PREINIT: 1451 int x[] = { 10, 11, 12, 13 }; 1452 PPCODE: 1453 mXPUSHi(C_ARRAY_LENGTH(x)); /* 4 */ 1454 mXPUSHi(*(C_ARRAY_END(x)-1)); /* 13 */ 1455 1456bool 1457isBLANK(ord) 1458 UV ord 1459 CODE: 1460 RETVAL = isBLANK(ord); 1461 OUTPUT: 1462 RETVAL 1463 1464bool 1465isBLANK_A(ord) 1466 UV ord 1467 CODE: 1468 RETVAL = isBLANK_A(ord); 1469 OUTPUT: 1470 RETVAL 1471 1472bool 1473isBLANK_L1(ord) 1474 UV ord 1475 CODE: 1476 RETVAL = isBLANK_L1(ord); 1477 OUTPUT: 1478 RETVAL 1479 1480bool 1481isUPPER(ord) 1482 UV ord 1483 CODE: 1484 RETVAL = isUPPER(ord); 1485 OUTPUT: 1486 RETVAL 1487 1488bool 1489isUPPER_A(ord) 1490 UV ord 1491 CODE: 1492 RETVAL = isUPPER_A(ord); 1493 OUTPUT: 1494 RETVAL 1495 1496bool 1497isUPPER_L1(ord) 1498 UV ord 1499 CODE: 1500 RETVAL = isUPPER_L1(ord); 1501 OUTPUT: 1502 RETVAL 1503 1504bool 1505isLOWER(ord) 1506 UV ord 1507 CODE: 1508 RETVAL = isLOWER(ord); 1509 OUTPUT: 1510 RETVAL 1511 1512bool 1513isLOWER_A(ord) 1514 UV ord 1515 CODE: 1516 RETVAL = isLOWER_A(ord); 1517 OUTPUT: 1518 RETVAL 1519 1520bool 1521isLOWER_L1(ord) 1522 UV ord 1523 CODE: 1524 RETVAL = isLOWER_L1(ord); 1525 OUTPUT: 1526 RETVAL 1527 1528bool 1529isALPHA(ord) 1530 UV ord 1531 CODE: 1532 RETVAL = isALPHA(ord); 1533 OUTPUT: 1534 RETVAL 1535 1536bool 1537isALPHA_A(ord) 1538 UV ord 1539 CODE: 1540 RETVAL = isALPHA_A(ord); 1541 OUTPUT: 1542 RETVAL 1543 1544bool 1545isALPHA_L1(ord) 1546 UV ord 1547 CODE: 1548 RETVAL = isALPHA_L1(ord); 1549 OUTPUT: 1550 RETVAL 1551 1552bool 1553isWORDCHAR(ord) 1554 UV ord 1555 CODE: 1556 RETVAL = isWORDCHAR(ord); 1557 OUTPUT: 1558 RETVAL 1559 1560bool 1561isWORDCHAR_A(ord) 1562 UV ord 1563 CODE: 1564 RETVAL = isWORDCHAR_A(ord); 1565 OUTPUT: 1566 RETVAL 1567 1568bool 1569isWORDCHAR_L1(ord) 1570 UV ord 1571 CODE: 1572 RETVAL = isWORDCHAR_L1(ord); 1573 OUTPUT: 1574 RETVAL 1575 1576bool 1577isALPHANUMERIC(ord) 1578 UV ord 1579 CODE: 1580 RETVAL = isALPHANUMERIC(ord); 1581 OUTPUT: 1582 RETVAL 1583 1584bool 1585isALPHANUMERIC_A(ord) 1586 UV ord 1587 CODE: 1588 RETVAL = isALPHANUMERIC_A(ord); 1589 OUTPUT: 1590 RETVAL 1591 1592bool 1593isALNUM(ord) 1594 UV ord 1595 CODE: 1596 RETVAL = isALNUM(ord); 1597 OUTPUT: 1598 RETVAL 1599 1600bool 1601isALNUM_A(ord) 1602 UV ord 1603 CODE: 1604 RETVAL = isALNUM_A(ord); 1605 OUTPUT: 1606 RETVAL 1607 1608bool 1609isDIGIT(ord) 1610 UV ord 1611 CODE: 1612 RETVAL = isDIGIT(ord); 1613 OUTPUT: 1614 RETVAL 1615 1616bool 1617isDIGIT_A(ord) 1618 UV ord 1619 CODE: 1620 RETVAL = isDIGIT_A(ord); 1621 OUTPUT: 1622 RETVAL 1623 1624bool 1625isOCTAL(ord) 1626 UV ord 1627 CODE: 1628 RETVAL = isOCTAL(ord); 1629 OUTPUT: 1630 RETVAL 1631 1632bool 1633isOCTAL_A(ord) 1634 UV ord 1635 CODE: 1636 RETVAL = isOCTAL_A(ord); 1637 OUTPUT: 1638 RETVAL 1639 1640bool 1641isIDFIRST(ord) 1642 UV ord 1643 CODE: 1644 RETVAL = isIDFIRST(ord); 1645 OUTPUT: 1646 RETVAL 1647 1648bool 1649isIDFIRST_A(ord) 1650 UV ord 1651 CODE: 1652 RETVAL = isIDFIRST_A(ord); 1653 OUTPUT: 1654 RETVAL 1655 1656bool 1657isIDCONT(ord) 1658 UV ord 1659 CODE: 1660 RETVAL = isIDCONT(ord); 1661 OUTPUT: 1662 RETVAL 1663 1664bool 1665isIDCONT_A(ord) 1666 UV ord 1667 CODE: 1668 RETVAL = isIDCONT_A(ord); 1669 OUTPUT: 1670 RETVAL 1671 1672bool 1673isSPACE(ord) 1674 UV ord 1675 CODE: 1676 RETVAL = isSPACE(ord); 1677 OUTPUT: 1678 RETVAL 1679 1680bool 1681isSPACE_A(ord) 1682 UV ord 1683 CODE: 1684 RETVAL = isSPACE_A(ord); 1685 OUTPUT: 1686 RETVAL 1687 1688bool 1689isASCII(ord) 1690 UV ord 1691 CODE: 1692 RETVAL = isASCII(ord); 1693 OUTPUT: 1694 RETVAL 1695 1696bool 1697isASCII_A(ord) 1698 UV ord 1699 CODE: 1700 RETVAL = isASCII_A(ord); 1701 OUTPUT: 1702 RETVAL 1703 1704bool 1705isCNTRL(ord) 1706 UV ord 1707 CODE: 1708 RETVAL = isCNTRL(ord); 1709 OUTPUT: 1710 RETVAL 1711 1712bool 1713isCNTRL_A(ord) 1714 UV ord 1715 CODE: 1716 RETVAL = isCNTRL_A(ord); 1717 OUTPUT: 1718 RETVAL 1719 1720bool 1721isPRINT(ord) 1722 UV ord 1723 CODE: 1724 RETVAL = isPRINT(ord); 1725 OUTPUT: 1726 RETVAL 1727 1728bool 1729isPRINT_A(ord) 1730 UV ord 1731 CODE: 1732 RETVAL = isPRINT_A(ord); 1733 OUTPUT: 1734 RETVAL 1735 1736bool 1737isGRAPH(ord) 1738 UV ord 1739 CODE: 1740 RETVAL = isGRAPH(ord); 1741 OUTPUT: 1742 RETVAL 1743 1744bool 1745isGRAPH_A(ord) 1746 UV ord 1747 CODE: 1748 RETVAL = isGRAPH_A(ord); 1749 OUTPUT: 1750 RETVAL 1751 1752bool 1753isPUNCT(ord) 1754 UV ord 1755 CODE: 1756 RETVAL = isPUNCT(ord); 1757 OUTPUT: 1758 RETVAL 1759 1760bool 1761isPUNCT_A(ord) 1762 UV ord 1763 CODE: 1764 RETVAL = isPUNCT_A(ord); 1765 OUTPUT: 1766 RETVAL 1767 1768bool 1769isXDIGIT(ord) 1770 UV ord 1771 CODE: 1772 RETVAL = isXDIGIT(ord); 1773 OUTPUT: 1774 RETVAL 1775 1776bool 1777isXDIGIT_A(ord) 1778 UV ord 1779 CODE: 1780 RETVAL = isXDIGIT_A(ord); 1781 OUTPUT: 1782 RETVAL 1783 1784bool 1785isPSXSPC(ord) 1786 UV ord 1787 CODE: 1788 RETVAL = isPSXSPC(ord); 1789 OUTPUT: 1790 RETVAL 1791 1792bool 1793isPSXSPC_A(ord) 1794 UV ord 1795 CODE: 1796 RETVAL = isPSXSPC_A(ord); 1797 OUTPUT: 1798 RETVAL 1799 1800bool 1801isALPHANUMERIC_L1(ord) 1802 UV ord 1803 CODE: 1804 RETVAL = isALPHANUMERIC_L1(ord); 1805 OUTPUT: 1806 RETVAL 1807 1808bool 1809isALNUMC_L1(ord) 1810 UV ord 1811 CODE: 1812 RETVAL = isALNUMC_L1(ord); 1813 OUTPUT: 1814 RETVAL 1815 1816bool 1817isDIGIT_L1(ord) 1818 UV ord 1819 CODE: 1820 RETVAL = isDIGIT_L1(ord); 1821 OUTPUT: 1822 RETVAL 1823 1824bool 1825isOCTAL_L1(ord) 1826 UV ord 1827 CODE: 1828 RETVAL = isOCTAL_L1(ord); 1829 OUTPUT: 1830 RETVAL 1831 1832bool 1833isIDFIRST_L1(ord) 1834 UV ord 1835 CODE: 1836 RETVAL = isIDFIRST_L1(ord); 1837 OUTPUT: 1838 RETVAL 1839 1840bool 1841isIDCONT_L1(ord) 1842 UV ord 1843 CODE: 1844 RETVAL = isIDCONT_L1(ord); 1845 OUTPUT: 1846 RETVAL 1847 1848bool 1849isSPACE_L1(ord) 1850 UV ord 1851 CODE: 1852 RETVAL = isSPACE_L1(ord); 1853 OUTPUT: 1854 RETVAL 1855 1856bool 1857isASCII_L1(ord) 1858 UV ord 1859 CODE: 1860 RETVAL = isASCII_L1(ord); 1861 OUTPUT: 1862 RETVAL 1863 1864bool 1865isCNTRL_L1(ord) 1866 UV ord 1867 CODE: 1868 RETVAL = isCNTRL_L1(ord); 1869 OUTPUT: 1870 RETVAL 1871 1872bool 1873isPRINT_L1(ord) 1874 UV ord 1875 CODE: 1876 RETVAL = isPRINT_L1(ord); 1877 OUTPUT: 1878 RETVAL 1879 1880bool 1881isGRAPH_L1(ord) 1882 UV ord 1883 CODE: 1884 RETVAL = isGRAPH_L1(ord); 1885 OUTPUT: 1886 RETVAL 1887 1888bool 1889isPUNCT_L1(ord) 1890 UV ord 1891 CODE: 1892 RETVAL = isPUNCT_L1(ord); 1893 OUTPUT: 1894 RETVAL 1895 1896bool 1897isXDIGIT_L1(ord) 1898 UV ord 1899 CODE: 1900 RETVAL = isXDIGIT_L1(ord); 1901 OUTPUT: 1902 RETVAL 1903 1904bool 1905isPSXSPC_L1(ord) 1906 UV ord 1907 CODE: 1908 RETVAL = isPSXSPC_L1(ord); 1909 OUTPUT: 1910 RETVAL 1911 1912bool 1913isASCII_uvchr(ord) 1914 UV ord 1915 CODE: 1916 RETVAL = isASCII_uvchr(ord); 1917 OUTPUT: 1918 RETVAL 1919 1920bool 1921isASCII_utf8_safe(s, offset) 1922 unsigned char * s 1923 int offset 1924 CODE: 1925 PERL_UNUSED_ARG(offset); 1926 RETVAL = isASCII_utf8_safe(s, s + 1 + offset); 1927 OUTPUT: 1928 RETVAL 1929 1930#if { VERSION >= 5.006 } 1931 1932bool 1933isBLANK_uvchr(ord) 1934 UV ord 1935 CODE: 1936 RETVAL = isBLANK_uvchr(ord); 1937 OUTPUT: 1938 RETVAL 1939 1940bool 1941isALPHA_uvchr(ord) 1942 UV ord 1943 CODE: 1944 RETVAL = isALPHA_uvchr(ord); 1945 OUTPUT: 1946 RETVAL 1947 1948bool 1949isALPHANUMERIC_uvchr(ord) 1950 UV ord 1951 CODE: 1952 RETVAL = isALPHANUMERIC_uvchr(ord); 1953 OUTPUT: 1954 RETVAL 1955 1956bool 1957isCNTRL_uvchr(ord) 1958 UV ord 1959 CODE: 1960 RETVAL = isCNTRL_uvchr(ord); 1961 OUTPUT: 1962 RETVAL 1963 1964bool 1965isDIGIT_uvchr(ord) 1966 UV ord 1967 CODE: 1968 RETVAL = isDIGIT_uvchr(ord); 1969 OUTPUT: 1970 RETVAL 1971 1972bool 1973isIDFIRST_uvchr(ord) 1974 UV ord 1975 CODE: 1976 RETVAL = isIDFIRST_uvchr(ord); 1977 OUTPUT: 1978 RETVAL 1979 1980bool 1981isIDCONT_uvchr(ord) 1982 UV ord 1983 CODE: 1984 RETVAL = isIDCONT_uvchr(ord); 1985 OUTPUT: 1986 RETVAL 1987 1988bool 1989isGRAPH_uvchr(ord) 1990 UV ord 1991 CODE: 1992 RETVAL = isGRAPH_uvchr(ord); 1993 OUTPUT: 1994 RETVAL 1995 1996bool 1997isLOWER_uvchr(ord) 1998 UV ord 1999 CODE: 2000 RETVAL = isLOWER_uvchr(ord); 2001 OUTPUT: 2002 RETVAL 2003 2004bool 2005isPRINT_uvchr(ord) 2006 UV ord 2007 CODE: 2008 RETVAL = isPRINT_uvchr(ord); 2009 OUTPUT: 2010 RETVAL 2011 2012bool 2013isPSXSPC_uvchr(ord) 2014 UV ord 2015 CODE: 2016 RETVAL = isPSXSPC_uvchr(ord); 2017 OUTPUT: 2018 RETVAL 2019 2020bool 2021isPUNCT_uvchr(ord) 2022 UV ord 2023 CODE: 2024 RETVAL = isPUNCT_uvchr(ord); 2025 OUTPUT: 2026 RETVAL 2027 2028bool 2029isSPACE_uvchr(ord) 2030 UV ord 2031 CODE: 2032 RETVAL = isSPACE_uvchr(ord); 2033 OUTPUT: 2034 RETVAL 2035 2036bool 2037isUPPER_uvchr(ord) 2038 UV ord 2039 CODE: 2040 RETVAL = isUPPER_uvchr(ord); 2041 OUTPUT: 2042 RETVAL 2043 2044bool 2045isWORDCHAR_uvchr(ord) 2046 UV ord 2047 CODE: 2048 RETVAL = isWORDCHAR_uvchr(ord); 2049 OUTPUT: 2050 RETVAL 2051 2052bool 2053isXDIGIT_uvchr(ord) 2054 UV ord 2055 CODE: 2056 RETVAL = isXDIGIT_uvchr(ord); 2057 OUTPUT: 2058 RETVAL 2059 2060bool 2061isALPHA_utf8_safe(s, offset) 2062 unsigned char * s 2063 int offset 2064 CODE: 2065 RETVAL = isALPHA_utf8_safe(s, s + UTF8SKIP(s) + offset); 2066 OUTPUT: 2067 RETVAL 2068 2069bool 2070isALPHANUMERIC_utf8_safe(s, offset) 2071 unsigned char * s 2072 int offset 2073 CODE: 2074 RETVAL = isALPHANUMERIC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2075 OUTPUT: 2076 RETVAL 2077 2078bool 2079isBLANK_utf8_safe(s, offset) 2080 unsigned char * s 2081 int offset 2082 CODE: 2083 RETVAL = isBLANK_utf8_safe(s, s + UTF8SKIP(s) + offset); 2084 OUTPUT: 2085 RETVAL 2086 2087bool 2088isCNTRL_utf8_safe(s, offset) 2089 unsigned char * s 2090 int offset 2091 CODE: 2092 RETVAL = isCNTRL_utf8_safe(s, s + UTF8SKIP(s) + offset); 2093 OUTPUT: 2094 RETVAL 2095 2096bool 2097isDIGIT_utf8_safe(s, offset) 2098 unsigned char * s 2099 int offset 2100 CODE: 2101 RETVAL = isDIGIT_utf8_safe(s, s + UTF8SKIP(s) + offset); 2102 OUTPUT: 2103 RETVAL 2104 2105bool 2106isGRAPH_utf8_safe(s, offset) 2107 unsigned char * s 2108 int offset 2109 CODE: 2110 RETVAL = isGRAPH_utf8_safe(s, s + UTF8SKIP(s) + offset); 2111 OUTPUT: 2112 RETVAL 2113 2114bool 2115isIDCONT_utf8_safe(s, offset) 2116 unsigned char * s 2117 int offset 2118 CODE: 2119 RETVAL = isIDCONT_utf8_safe(s, s + UTF8SKIP(s) + offset); 2120 OUTPUT: 2121 RETVAL 2122 2123bool 2124isIDFIRST_utf8_safe(s, offset) 2125 unsigned char * s 2126 int offset 2127 CODE: 2128 RETVAL = isIDFIRST_utf8_safe(s, s + UTF8SKIP(s) + offset); 2129 OUTPUT: 2130 RETVAL 2131 2132bool 2133isLOWER_utf8_safe(s, offset) 2134 unsigned char * s 2135 int offset 2136 CODE: 2137 RETVAL = isLOWER_utf8_safe(s, s + UTF8SKIP(s) + offset); 2138 OUTPUT: 2139 RETVAL 2140 2141bool 2142isPRINT_utf8_safe(s, offset) 2143 unsigned char * s 2144 int offset 2145 CODE: 2146 RETVAL = isPRINT_utf8_safe(s, s + UTF8SKIP(s) + offset); 2147 OUTPUT: 2148 RETVAL 2149 2150bool 2151isPSXSPC_utf8_safe(s, offset) 2152 unsigned char * s 2153 int offset 2154 CODE: 2155 RETVAL = isPSXSPC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2156 OUTPUT: 2157 RETVAL 2158 2159bool 2160isPUNCT_utf8_safe(s, offset) 2161 unsigned char * s 2162 int offset 2163 CODE: 2164 RETVAL = isPUNCT_utf8_safe(s, s + UTF8SKIP(s) + offset); 2165 OUTPUT: 2166 RETVAL 2167 2168bool 2169isSPACE_utf8_safe(s, offset) 2170 unsigned char * s 2171 int offset 2172 CODE: 2173 RETVAL = isSPACE_utf8_safe(s, s + UTF8SKIP(s) + offset); 2174 OUTPUT: 2175 RETVAL 2176 2177bool 2178isUPPER_utf8_safe(s, offset) 2179 unsigned char * s 2180 int offset 2181 CODE: 2182 RETVAL = isUPPER_utf8_safe(s, s + UTF8SKIP(s) + offset); 2183 OUTPUT: 2184 RETVAL 2185 2186bool 2187isWORDCHAR_utf8_safe(s, offset) 2188 unsigned char * s 2189 int offset 2190 CODE: 2191 RETVAL = isWORDCHAR_utf8_safe(s, s + UTF8SKIP(s) + offset); 2192 OUTPUT: 2193 RETVAL 2194 2195bool 2196isXDIGIT_utf8_safe(s, offset) 2197 unsigned char * s 2198 int offset 2199 CODE: 2200 RETVAL = isXDIGIT_utf8_safe(s, s + UTF8SKIP(s) + offset); 2201 OUTPUT: 2202 RETVAL 2203 2204bool 2205isALPHA_LC_utf8_safe(s, offset) 2206 unsigned char * s 2207 int offset 2208 CODE: 2209 RETVAL = isALPHA_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2210 OUTPUT: 2211 RETVAL 2212 2213bool 2214isALPHANUMERIC_LC_utf8_safe(s, offset) 2215 unsigned char * s 2216 int offset 2217 CODE: 2218 RETVAL = isALPHANUMERIC_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2219 OUTPUT: 2220 RETVAL 2221 2222bool 2223isASCII_LC_utf8_safe(s, offset) 2224 unsigned char * s 2225 int offset 2226 CODE: 2227 PERL_UNUSED_ARG(offset); 2228 RETVAL = isASCII_utf8_safe(s, s + UTF8SKIP(s) + offset); 2229 OUTPUT: 2230 RETVAL 2231 2232bool 2233isBLANK_LC_utf8_safe(s, offset) 2234 unsigned char * s 2235 int offset 2236 CODE: 2237 RETVAL = isBLANK_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2238 OUTPUT: 2239 RETVAL 2240 2241bool 2242isCNTRL_LC_utf8_safe(s, offset) 2243 unsigned char * s 2244 int offset 2245 CODE: 2246 RETVAL = isCNTRL_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2247 OUTPUT: 2248 RETVAL 2249 2250bool 2251isDIGIT_LC_utf8_safe(s, offset) 2252 unsigned char * s 2253 int offset 2254 CODE: 2255 RETVAL = isDIGIT_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2256 OUTPUT: 2257 RETVAL 2258 2259bool 2260isGRAPH_LC_utf8_safe(s, offset) 2261 unsigned char * s 2262 int offset 2263 CODE: 2264 RETVAL = isGRAPH_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2265 OUTPUT: 2266 RETVAL 2267 2268bool 2269isIDCONT_LC_utf8_safe(s, offset) 2270 unsigned char * s 2271 int offset 2272 CODE: 2273 RETVAL = isIDCONT_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2274 OUTPUT: 2275 RETVAL 2276 2277bool 2278isIDFIRST_LC_utf8_safe(s, offset) 2279 unsigned char * s 2280 int offset 2281 CODE: 2282 RETVAL = isIDFIRST_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2283 OUTPUT: 2284 RETVAL 2285 2286bool 2287isLOWER_LC_utf8_safe(s, offset) 2288 unsigned char * s 2289 int offset 2290 CODE: 2291 RETVAL = isLOWER_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2292 OUTPUT: 2293 RETVAL 2294 2295bool 2296isPRINT_LC_utf8_safe(s, offset) 2297 unsigned char * s 2298 int offset 2299 CODE: 2300 RETVAL = isPRINT_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2301 OUTPUT: 2302 RETVAL 2303 2304bool 2305isPSXSPC_LC_utf8_safe(s, offset) 2306 unsigned char * s 2307 int offset 2308 CODE: 2309 RETVAL = isPSXSPC_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2310 OUTPUT: 2311 RETVAL 2312 2313bool 2314isPUNCT_LC_utf8_safe(s, offset) 2315 unsigned char * s 2316 int offset 2317 CODE: 2318 RETVAL = isPUNCT_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2319 OUTPUT: 2320 RETVAL 2321 2322bool 2323isSPACE_LC_utf8_safe(s, offset) 2324 unsigned char * s 2325 int offset 2326 CODE: 2327 RETVAL = isSPACE_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2328 OUTPUT: 2329 RETVAL 2330 2331bool 2332isUPPER_LC_utf8_safe(s, offset) 2333 unsigned char * s 2334 int offset 2335 CODE: 2336 RETVAL = isUPPER_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2337 OUTPUT: 2338 RETVAL 2339 2340bool 2341isWORDCHAR_LC_utf8_safe(s, offset) 2342 unsigned char * s 2343 int offset 2344 CODE: 2345 RETVAL = isWORDCHAR_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2346 OUTPUT: 2347 RETVAL 2348 2349bool 2350isXDIGIT_LC_utf8_safe(s, offset) 2351 unsigned char * s 2352 int offset 2353 CODE: 2354 RETVAL = isXDIGIT_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); 2355 OUTPUT: 2356 RETVAL 2357 2358AV * 2359toLOWER_utf8_safe(s, offset) 2360 unsigned char * s 2361 int offset 2362 PREINIT: 2363 U8 u[UTF8_MAXBYTES+1]; 2364 Size_t len; 2365 UV ret; 2366 SV* utf8; 2367 AV * av; 2368 CODE: 2369 av = newAV(); 2370 ret = toLOWER_utf8_safe(s, s + UTF8SKIP(s) + offset, u, &len); 2371 av_push(av, newSVuv(ret)); 2372 2373 utf8 = newSVpvn((char *) u, len); 2374 SvUTF8_on(utf8); 2375 av_push(av, utf8); 2376 2377 av_push(av, newSVuv(len)); 2378 RETVAL = av; 2379 OUTPUT: 2380 RETVAL 2381 2382AV * 2383toTITLE_utf8_safe(s, offset) 2384 unsigned char * s 2385 int offset 2386 PREINIT: 2387 U8 u[UTF8_MAXBYTES+1]; 2388 Size_t len; 2389 UV ret; 2390 SV* utf8; 2391 AV * av; 2392 CODE: 2393 av = newAV(); 2394 ret = toTITLE_utf8_safe(s, s + UTF8SKIP(s) + offset, u, &len); 2395 av_push(av, newSVuv(ret)); 2396 2397 utf8 = newSVpvn((char *) u, len); 2398 SvUTF8_on(utf8); 2399 av_push(av, utf8); 2400 2401 av_push(av, newSVuv(len)); 2402 RETVAL = av; 2403 OUTPUT: 2404 RETVAL 2405 2406AV * 2407toUPPER_utf8_safe(s, offset) 2408 unsigned char * s 2409 int offset 2410 PREINIT: 2411 U8 u[UTF8_MAXBYTES+1]; 2412 Size_t len; 2413 UV ret; 2414 SV* utf8; 2415 AV * av; 2416 CODE: 2417 av = newAV(); 2418 ret = toUPPER_utf8_safe(s, s + UTF8SKIP(s) + offset, u, &len); 2419 av_push(av, newSVuv(ret)); 2420 2421 utf8 = newSVpvn((char *) u, len); 2422 SvUTF8_on(utf8); 2423 av_push(av, utf8); 2424 2425 av_push(av, newSVuv(len)); 2426 RETVAL = av; 2427 OUTPUT: 2428 RETVAL 2429 2430AV * 2431toFOLD_utf8_safe(s, offset) 2432 unsigned char * s 2433 int offset 2434 PREINIT: 2435 U8 u[UTF8_MAXBYTES+1]; 2436 Size_t len; 2437 UV ret; 2438 SV* utf8; 2439 AV * av; 2440 CODE: 2441 av = newAV(); 2442 ret = toFOLD_utf8_safe(s, s + UTF8SKIP(s) + offset, u, &len); 2443 av_push(av, newSVuv(ret)); 2444 2445 utf8 = newSVpvn((char *) u, len); 2446 SvUTF8_on(utf8); 2447 av_push(av, utf8); 2448 2449 av_push(av, newSVuv(len)); 2450 RETVAL = av; 2451 OUTPUT: 2452 RETVAL 2453 2454AV * 2455toLOWER_uvchr(c) 2456 UV c 2457 PREINIT: 2458 U8 u[UTF8_MAXBYTES+1]; 2459 Size_t len; 2460 UV ret; 2461 SV* utf8; 2462 AV * av; 2463 CODE: 2464 av = newAV(); 2465 ret = toLOWER_uvchr(c, u, &len); 2466 av_push(av, newSVuv(ret)); 2467 2468 utf8 = newSVpvn((char *) u, len); 2469 SvUTF8_on(utf8); 2470 av_push(av, utf8); 2471 2472 av_push(av, newSVuv(len)); 2473 RETVAL = av; 2474 OUTPUT: 2475 RETVAL 2476 2477AV * 2478toTITLE_uvchr(c) 2479 UV c 2480 PREINIT: 2481 U8 u[UTF8_MAXBYTES+1]; 2482 Size_t len; 2483 UV ret; 2484 SV* utf8; 2485 AV * av; 2486 CODE: 2487 av = newAV(); 2488 ret = toTITLE_uvchr(c, u, &len); 2489 av_push(av, newSVuv(ret)); 2490 2491 utf8 = newSVpvn((char *) u, len); 2492 SvUTF8_on(utf8); 2493 av_push(av, utf8); 2494 2495 av_push(av, newSVuv(len)); 2496 RETVAL = av; 2497 OUTPUT: 2498 RETVAL 2499 2500AV * 2501toUPPER_uvchr(c) 2502 UV c 2503 PREINIT: 2504 U8 u[UTF8_MAXBYTES+1]; 2505 Size_t len; 2506 UV ret; 2507 SV* utf8; 2508 AV * av; 2509 CODE: 2510 av = newAV(); 2511 ret = toUPPER_uvchr(c, u, &len); 2512 av_push(av, newSVuv(ret)); 2513 2514 utf8 = newSVpvn((char *) u, len); 2515 SvUTF8_on(utf8); 2516 av_push(av, utf8); 2517 2518 av_push(av, newSVuv(len)); 2519 RETVAL = av; 2520 OUTPUT: 2521 RETVAL 2522 2523AV * 2524toFOLD_uvchr(c) 2525 UV c 2526 PREINIT: 2527 U8 u[UTF8_MAXBYTES+1]; 2528 Size_t len; 2529 UV ret; 2530 SV* utf8; 2531 AV * av; 2532 CODE: 2533 av = newAV(); 2534 ret = toFOLD_uvchr(c, u, &len); 2535 av_push(av, newSVuv(ret)); 2536 2537 utf8 = newSVpvn((char *) u, len); 2538 SvUTF8_on(utf8); 2539 av_push(av, utf8); 2540 2541 av_push(av, newSVuv(len)); 2542 RETVAL = av; 2543 OUTPUT: 2544 RETVAL 2545 2546#endif 2547 2548UV 2549LATIN1_TO_NATIVE(cp) 2550 UV cp 2551 CODE: 2552 if (cp > 255) RETVAL= cp; 2553 else RETVAL= LATIN1_TO_NATIVE(cp); 2554 OUTPUT: 2555 RETVAL 2556 2557UV 2558NATIVE_TO_LATIN1(cp) 2559 UV cp 2560 CODE: 2561 RETVAL= NATIVE_TO_LATIN1(cp); 2562 OUTPUT: 2563 RETVAL 2564 2565STRLEN 2566av_tindex(av) 2567 SV *av 2568 CODE: 2569 RETVAL = av_tindex((AV*)SvRV(av)); 2570 OUTPUT: 2571 RETVAL 2572 2573STRLEN 2574av_top_index(av) 2575 SV *av 2576 CODE: 2577 RETVAL = av_top_index((AV*)SvRV(av)); 2578 OUTPUT: 2579 RETVAL 2580 2581STRLEN 2582av_count(av) 2583 SV *av 2584 CODE: 2585 RETVAL = av_count((AV*)SvRV(av)); 2586 OUTPUT: 2587 RETVAL 2588 2589=tests plan => 26827 2590 2591use vars qw($my_sv @my_av %my_hv); 2592 2593ok(&Devel::PPPort::boolSV(1), "Verify boolSV(1) is true"); 2594ok(!&Devel::PPPort::boolSV(0), "Verify boolSV(0) is false"); 2595 2596$_ = "Fred"; 2597is(&Devel::PPPort::DEFSV(), "Fred", '$_ is FRED; Verify DEFSV is FRED'); 2598is(&Devel::PPPort::UNDERBAR(), "Fred", 'And verify UNDERBAR is FRED'); 2599 2600if (ivers($]) >= ivers(5.9.2) && ivers($]) < ivers(5.23)) { 2601 eval q{ 2602 no warnings "deprecated"; 2603 no if $^V >= v5.17.9, warnings => "experimental::lexical_topic"; 2604 my $_ = "Tony"; 2605 is(&Devel::PPPort::DEFSV(), "Fred", 'lexical_topic eval: $_ is Tony; Verify DEFSV is Fred'); 2606 is(&Devel::PPPort::UNDERBAR(), "Tony", 'And verify UNDERBAR is Tony'); 2607 }; 2608 die __FILE__ . __LINE__ . ": $@" if $@; 2609} 2610else { 2611 skip("perl version outside testing range of lexical_topic", 2); 2612} 2613 2614my @r = &Devel::PPPort::DEFSV_modify(); 2615 2616ok(@r == 3, "Verify got 3 elements"); 2617is($r[0], 'Fred'); 2618is($r[1], 'DEFSV'); 2619is($r[2], 'Fred'); 2620 2621is(&Devel::PPPort::DEFSV(), "Fred"); 2622 2623eval { 1 }; 2624ok(!&Devel::PPPort::ERRSV(), "Verify ERRSV on true is false"); 2625eval { cannot_call_this_one() }; 2626ok(&Devel::PPPort::ERRSV(), "Verify ERRSV on false is true"); 2627 2628ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0)); 2629ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0)); 2630ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1)); 2631 2632$my_sv = 1; 2633ok(&Devel::PPPort::get_sv('my_sv', 0)); 2634ok(!&Devel::PPPort::get_sv('not_my_sv', 0)); 2635ok(&Devel::PPPort::get_sv('not_my_sv', 1)); 2636 2637@my_av = (1); 2638ok(&Devel::PPPort::get_av('my_av', 0)); 2639ok(!&Devel::PPPort::get_av('not_my_av', 0)); 2640ok(&Devel::PPPort::get_av('not_my_av', 1)); 2641 2642%my_hv = (a=>1); 2643ok(&Devel::PPPort::get_hv('my_hv', 0)); 2644ok(!&Devel::PPPort::get_hv('not_my_hv', 0)); 2645ok(&Devel::PPPort::get_hv('not_my_hv', 1)); 2646 2647sub my_cv { 1 }; 2648ok(&Devel::PPPort::get_cv('my_cv', 0)); 2649ok(!&Devel::PPPort::get_cv('not_my_cv', 0)); 2650ok(&Devel::PPPort::get_cv('not_my_cv', 1)); 2651 2652is(Devel::PPPort::dXSTARG(42), 43); 2653is(Devel::PPPort::dAXMARK(4711), 4710); 2654 2655is(Devel::PPPort::prepush(), 42); 2656 2657is(join(':', Devel::PPPort::xsreturn(0)), 'test1'); 2658is(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2'); 2659 2660is(Devel::PPPort::PERL_ABS(42), 42, "Verify PERL_ABS(42) is 42"); 2661is(Devel::PPPort::PERL_ABS(-13), 13, "Verify PERL_ABS(-13) is 13"); 2662 2663is(Devel::PPPort::SVf(42), ivers($]) >= ivers(5.4) ? '[42]' : '42'); 2664is(Devel::PPPort::SVf('abc'), ivers($]) >= ivers(5.4) ? '[abc]' : 'abc'); 2665 2666is(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo"); 2667 2668is(&Devel::PPPort::ptrtests(), 63); 2669 2670is(&Devel::PPPort::OpSIBLING_tests(), 0); 2671 2672if (ivers($]) >= ivers(5.9)) { 2673 eval q{ 2674 is(&Devel::PPPort::check_HeUTF8("hello"), "norm"); 2675 is(&Devel::PPPort::check_HeUTF8("\N{U+263a}"), "utf8"); 2676 }; 2677} else { 2678 skip("Too early perl version", 2); 2679} 2680 2681@r = &Devel::PPPort::check_c_array(); 2682is($r[0], 4); 2683is($r[1], "13"); 2684 2685ok(!Devel::PPPort::SvRXOK("")); 2686ok(!Devel::PPPort::SvRXOK(bless [], "Regexp")); 2687 2688if (ivers($]) < ivers(5.5)) { 2689 skip 'no qr// objects in this perl', 2; 2690} else { 2691 my $qr = eval 'qr/./'; 2692 ok(Devel::PPPort::SvRXOK($qr), "SVRXOK(qr) is true"); 2693 ok(Devel::PPPort::SvRXOK(bless $qr, "Surprise")); 2694} 2695 2696ok( Devel::PPPort::NATIVE_TO_LATIN1(0xB6) == 0xB6); 2697ok( Devel::PPPort::NATIVE_TO_LATIN1(0x1) == 0x1); 2698ok( Devel::PPPort::NATIVE_TO_LATIN1(ord("A")) == 0x41); 2699ok( Devel::PPPort::NATIVE_TO_LATIN1(ord("0")) == 0x30); 2700 2701ok( Devel::PPPort::LATIN1_TO_NATIVE(0xB6) == 0xB6, "Verify LATIN1_TO_NATIVE(0xB6) is 0xB6"); 2702if (ord("A") == 65) { 2703 ok( Devel::PPPort::LATIN1_TO_NATIVE(0x41) == 0x41); 2704 ok( Devel::PPPort::LATIN1_TO_NATIVE(0x30) == 0x30); 2705} 2706else { 2707 ok( Devel::PPPort::LATIN1_TO_NATIVE(0x41) == 0xC1); 2708 ok( Devel::PPPort::LATIN1_TO_NATIVE(0x30) == 0xF0); 2709} 2710 2711ok( Devel::PPPort::isALNUMC_L1(ord("5"))); 2712ok( Devel::PPPort::isALNUMC_L1(0xFC)); 2713ok(! Devel::PPPort::isALNUMC_L1(0xB6)); 2714 2715ok( Devel::PPPort::isOCTAL(ord("7")), "Verify '7' is OCTAL"); 2716ok(! Devel::PPPort::isOCTAL(ord("8")), "Verify '8' isn't OCTAL"); 2717 2718ok( Devel::PPPort::isOCTAL_A(ord("0")), "Verify '0' is OCTAL_A"); 2719ok(! Devel::PPPort::isOCTAL_A(ord("9")), "Verify '9' isn't OCTAL_A"); 2720 2721ok( Devel::PPPort::isOCTAL_L1(ord("2")), "Verify '2' is OCTAL_L1"); 2722ok(! Devel::PPPort::isOCTAL_L1(ord("8")), "Verify '8' isn't OCTAL_L1"); 2723 2724my $way_too_early_msg = 'UTF-8 not implemented on this perl'; 2725 2726# For the other properties, we test every code point from 0.255, and a 2727# smattering of higher ones. First populate a hash with keys like '65:ALPHA' 2728# to indicate that the code point there is alphabetic 2729my $i; 2730my %types; 2731for $i (0x41..0x5A, 0x61..0x7A, 0xAA, 0xB5, 0xBA, 0xC0..0xD6, 0xD8..0xF6, 2732 0xF8..0x101) 2733{ 2734 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); 2735 $types{"$native:ALPHA"} = 1; 2736 $types{"$native:ALPHANUMERIC"} = 1; 2737 $types{"$native:IDFIRST"} = 1; 2738 $types{"$native:IDCONT"} = 1; 2739 $types{"$native:PRINT"} = 1; 2740 $types{"$native:WORDCHAR"} = 1; 2741} 2742for $i (0x30..0x39, 0x660, 0xFF19) { 2743 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); 2744 $types{"$native:ALPHANUMERIC"} = 1; 2745 $types{"$native:DIGIT"} = 1; 2746 $types{"$native:IDCONT"} = 1; 2747 $types{"$native:WORDCHAR"} = 1; 2748 $types{"$native:GRAPH"} = 1; 2749 $types{"$native:PRINT"} = 1; 2750 $types{"$native:XDIGIT"} = 1 if $i < 255 || ($i >= 0xFF10 && $i <= 0xFF19); 2751} 2752 2753for $i (0..0x7F) { 2754 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); 2755 $types{"$native:ASCII"} = 1; 2756} 2757for $i (0..0x1f, 0x7F..0x9F) { 2758 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); 2759 $types{"$native:CNTRL"} = 1; 2760} 2761for $i (0x21..0x7E, 0xA1..0x101, 0x660) { 2762 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); 2763 $types{"$native:GRAPH"} = 1; 2764 $types{"$native:PRINT"} = 1; 2765} 2766for $i (0x09, 0x20, 0xA0) { 2767 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); 2768 $types{"$native:BLANK"} = 1; 2769 $types{"$native:SPACE"} = 1; 2770 $types{"$native:PSXSPC"} = 1; 2771 $types{"$native:PRINT"} = 1 if $i > 0x09; 2772} 2773for $i (0x09..0x0D, 0x85, 0x2029) { 2774 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); 2775 $types{"$native:SPACE"} = 1; 2776 $types{"$native:PSXSPC"} = 1; 2777} 2778for $i (0x41..0x5A, 0xC0..0xD6, 0xD8..0xDE, 0x100) { 2779 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); 2780 $types{"$native:UPPER"} = 1; 2781 $types{"$native:XDIGIT"} = 1 if $i < 0x47; 2782} 2783for $i (0x61..0x7A, 0xAA, 0xB5, 0xBA, 0xDF..0xF6, 0xF8..0xFF, 0x101) { 2784 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); 2785 $types{"$native:LOWER"} = 1; 2786 $types{"$native:XDIGIT"} = 1 if $i < 0x67; 2787} 2788for $i (0x21..0x2F, 0x3A..0x40, 0x5B..0x60, 0x7B..0x7E, 0xB6, 0xA1, 0xA7, 0xAB, 2789 0xB7, 0xBB, 0xBF, 0x5BE) 2790{ 2791 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); 2792 $types{"$native:PUNCT"} = 1; 2793 $types{"$native:GRAPH"} = 1; 2794 $types{"$native:PRINT"} = 1; 2795} 2796 2797$i = ord('_'); 2798$types{"$i:WORDCHAR"} = 1; 2799$types{"$i:IDFIRST"} = 1; 2800$types{"$i:IDCONT"} = 1; 2801 2802# Now find all the unique code points included above. 2803my %code_points_to_test; 2804my $key; 2805for $key (keys %types) { 2806 $key =~ s/:.*//; 2807 $code_points_to_test{$key} = 1; 2808} 2809 2810# And test each one 2811for $i (sort { $a <=> $b } keys %code_points_to_test) { 2812 my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); 2813 my $hex = sprintf("0x%02X", $native); 2814 2815 # And for each code point test each of the classes 2816 my $class; 2817 for $class (qw(ALPHA ALPHANUMERIC ASCII BLANK CNTRL DIGIT GRAPH IDCONT 2818 IDFIRST LOWER PRINT PSXSPC PUNCT SPACE UPPER WORDCHAR 2819 XDIGIT)) 2820 { 2821 if ($i < 256) { # For the ones that can fit in a byte, test each of 2822 # three macros. 2823 my $suffix; 2824 for $suffix ("", "_A", "_L1", "_uvchr") { 2825 my $should_be = ($i > 0x7F && $suffix !~ /_(uvchr|L1)/) 2826 ? 0 # Fail on non-ASCII unless unicode 2827 : ($types{"$native:$class"} || 0); 2828 if (ivers($]) < ivers(5.6) && $suffix eq '_uvchr') { 2829 skip("No UTF-8 on this perl", 1); 2830 next; 2831 } 2832 2833 my $eval_string = "Devel::PPPort::is${class}$suffix($hex)"; 2834 local $SIG{__WARN__} = sub {}; 2835 my $is = eval $eval_string || 0; 2836 die "eval 'For $i: $eval_string' gave $@" if $@; 2837 is($is, $should_be, "'$eval_string'"); 2838 } 2839 } 2840 2841 # For all code points, test the '_utf8' macros 2842 my $sub_fcn; 2843 for $sub_fcn ("", "_LC") { 2844 my $skip = ""; 2845 if (ivers($]) < ivers(5.6)) { 2846 $skip = $way_too_early_msg; 2847 } 2848 elsif (ivers($]) < ivers(5.7) && $native > 255) { 2849 $skip = "Perls earlier than 5.7 give wrong answers for above Latin1 code points"; 2850 } 2851 elsif (ivers($]) <= ivers(5.11.3) && $native == 0x2029 && ($class eq 'PRINT' || $class eq 'GRAPH')) { 2852 $skip = "Perls earlier than 5.11.3 considered high space characters as isPRINT and isGRAPH"; 2853 } 2854 elsif ($sub_fcn eq '_LC' && $i < 256) { 2855 $skip = "Testing of code points whose results depend on locale is skipped "; 2856 } 2857 my $fcn = "Devel::PPPort::is${class}${sub_fcn}_utf8_safe"; 2858 my $utf8; 2859 2860 if ($skip) { 2861 skip $skip, 1; 2862 } 2863 else { 2864 $utf8 = quotemeta Devel::PPPort::uvchr_to_utf8($native); 2865 my $should_be = $types{"$native:$class"} || 0; 2866 my $eval_string = "$fcn(\"$utf8\", 0)"; 2867 local $SIG{__WARN__} = sub {}; 2868 my $is = eval $eval_string || 0; 2869 die "eval 'For $i, $eval_string' gave $@" if $@; 2870 is($is, $should_be, sprintf("For U+%04X '%s'", $native, $eval_string)); 2871 } 2872 2873 # And for the high code points, test that a too short malformation (the 2874 # -1) causes it to fail 2875 if ($i > 255) { 2876 if ($skip) { 2877 skip $skip, 1; 2878 } 2879 elsif (ivers($]) >= ivers(5.25.9)) { 2880 skip("Prints an annoying error message that khw doesn't know how to easily suppress", 1); 2881 } 2882 else { 2883 my $eval_string = "$fcn(\"$utf8\", -1)"; 2884 local $SIG{__WARN__} = sub {}; 2885 my $is = eval "$eval_string" || 0; 2886 die "eval '$eval_string' gave $@" if $@; 2887 is($is, 0, sprintf("For U+%04X '%s'", $native, $eval_string)); 2888 } 2889 } 2890 } 2891 } 2892} 2893 2894my %case_changing = ( 'LOWER' => [ [ ord('A'), ord('a') ], 2895 [ Devel::PPPort::LATIN1_TO_NATIVE(0xC0), 2896 Devel::PPPort::LATIN1_TO_NATIVE(0xE0) ], 2897 [ 0x100, 0x101 ], 2898 ], 2899 'FOLD' => [ [ ord('C'), ord('c') ], 2900 [ Devel::PPPort::LATIN1_TO_NATIVE(0xC0), 2901 Devel::PPPort::LATIN1_TO_NATIVE(0xE0) ], 2902 [ 0x104, 0x105 ], 2903 [ Devel::PPPort::LATIN1_TO_NATIVE(0xDF), 2904 'ss' ], 2905 ], 2906 'UPPER' => [ [ ord('a'), ord('A'), ], 2907 [ Devel::PPPort::LATIN1_TO_NATIVE(0xE0), 2908 Devel::PPPort::LATIN1_TO_NATIVE(0xC0) ], 2909 [ 0x101, 0x100 ], 2910 [ Devel::PPPort::LATIN1_TO_NATIVE(0xDF), 2911 'SS' ], 2912 ], 2913 'TITLE' => [ [ ord('c'), ord('C'), ], 2914 [ Devel::PPPort::LATIN1_TO_NATIVE(0xE2), 2915 Devel::PPPort::LATIN1_TO_NATIVE(0xC2) ], 2916 [ 0x103, 0x102 ], 2917 [ Devel::PPPort::LATIN1_TO_NATIVE(0xDF), 2918 'Ss' ], 2919 ], 2920 ); 2921 2922my $name; 2923for $name (keys %case_changing) { 2924 my @code_points_to_test = @{$case_changing{$name}}; 2925 my $unchanged; 2926 for $unchanged (@code_points_to_test) { 2927 my @pair = @$unchanged; 2928 my $original = $pair[0]; 2929 my $changed = $pair[1]; 2930 my $utf8_changed = $changed; 2931 my $is_cp = $utf8_changed =~ /^\d+$/; 2932 my $should_be_bytes; 2933 if (ivers($]) >= ivers(5.6)) { 2934 if ($is_cp) { 2935 $utf8_changed = Devel::PPPort::uvchr_to_utf8($changed); 2936 $should_be_bytes = Devel::PPPort::UTF8_SAFE_SKIP($utf8_changed, 0); 2937 } 2938 else { 2939 die("Test currently doesn't work for non-ASCII multi-char case changes") if eval '$utf8_changed =~ /[[:^ascii:]]/'; 2940 $should_be_bytes = length $utf8_changed; 2941 } 2942 } 2943 2944 my $fcn = "to${name}_uvchr"; 2945 my $skip = ""; 2946 2947 if (ivers($]) < ivers(5.6)) { 2948 $skip = $way_too_early_msg; 2949 } 2950 elsif (! $is_cp) { 2951 $skip = "Can't do uvchr on a multi-char string"; 2952 } 2953 if ($skip) { 2954 skip $skip, 4; 2955 } 2956 else { 2957 if ($is_cp) { 2958 $utf8_changed = Devel::PPPort::uvchr_to_utf8($changed); 2959 $should_be_bytes = Devel::PPPort::UTF8_SAFE_SKIP($utf8_changed, 0); 2960 } 2961 else { 2962 my $non_ascii_re = (ivers($]) >= ivers(5.6)) ? '[[:^ascii:]]' : '[^\x00-\x7F]'; 2963 die("Test currently doesn't work for non-ASCII multi-char case changes") if eval '$utf8_changed =~ /$non_ascii_re/'; 2964 $should_be_bytes = length $utf8_changed; 2965 } 2966 2967 my $ret = eval "Devel::PPPort::$fcn($original)"; 2968 my $fail = $@; # Have to save $@, as it gets destroyed 2969 is ($fail, "", "$fcn($original) didn't fail"); 2970 my $first = (ivers($]) != ivers(5.6)) 2971 ? substr($utf8_changed, 0, 1) 2972 : $utf8_changed, 0, 1; 2973 is($ret->[0], ord $first, 2974 "ord of $fcn($original) is $changed"); 2975 is($ret->[1], $utf8_changed, 2976 "UTF-8 of of $fcn($original) is correct"); 2977 is($ret->[2], $should_be_bytes, 2978 "Length of $fcn($original) is $should_be_bytes"); 2979 } 2980 2981 my $truncate; 2982 for $truncate (0..2) { 2983 my $skip; 2984 if (ivers($]) < ivers(5.6)) { 2985 $skip = $way_too_early_msg; 2986 } 2987 elsif (! $is_cp && ivers($]) < ivers(5.7.3)) { 2988 $skip = "Multi-character case change not implemented until 5.7.3"; 2989 } 2990 elsif ($truncate == 2 && ivers($]) > ivers(5.25.8)) { 2991 $skip = "Zero length inputs cause assertion failure; test dies in modern perls"; 2992 } 2993 elsif ($truncate > 0 && length $changed > 1) { 2994 $skip = "Don't test shortened multi-char case changes"; 2995 } 2996 elsif ($truncate > 0 && Devel::PPPort::UVCHR_IS_INVARIANT($original)) { 2997 $skip = "Don't try to test shortened single bytes"; 2998 } 2999 if ($skip) { 3000 skip $skip, 4; 3001 } 3002 else { 3003 my $fcn = "to${name}_utf8_safe"; 3004 my $utf8 = quotemeta Devel::PPPort::uvchr_to_utf8($original); 3005 my $real_truncate = ($truncate < 2) 3006 ? $truncate : $should_be_bytes; 3007 my $eval_string = "Devel::PPPort::$fcn(\"$utf8\", $real_truncate)"; 3008 my $ret = eval "no warnings; $eval_string" || 0; 3009 my $fail = $@; # Have to save $@, as it gets destroyed 3010 if ($truncate == 0) { 3011 is ($fail, "", "Didn't fail on full length input"); 3012 my $first = (ivers($]) != ivers(5.6)) 3013 ? substr($utf8_changed, 0, 1) 3014 : $utf8_changed, 0, 1; 3015 is($ret->[0], ord $first, 3016 "ord of $fcn($original) is $changed"); 3017 is($ret->[1], $utf8_changed, 3018 "UTF-8 of of $fcn($original) is correct"); 3019 is($ret->[2], $should_be_bytes, 3020 "Length of $fcn($original) is $should_be_bytes"); 3021 } 3022 else { 3023 is ($fail, eval 'qr/Malformed UTF-8 character/', 3024 "Gave appropriate error for short char: $original"); 3025 skip("Expected failure means remaining tests for" 3026 . " this aren't relevant", 3); 3027 } 3028 } 3029 } 3030 } 3031} 3032 3033is(&Devel::PPPort::av_top_index([1,2,3]), 2); 3034is(&Devel::PPPort::av_tindex([1,2,3,4]), 3); 3035is(&Devel::PPPort::av_count([1,2,3,4]), 4); 3036