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