11152 #ifndef _P_P_PORTABILITY_H_
11153 #define _P_P_PORTABILITY_H_
11155 #ifndef DPPP_NAMESPACE
11156 # define DPPP_NAMESPACE DPPP_
11159 #define DPPP_CAT2(x,y) CAT2(x,y)
11160 #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
11162 #define D_PPP_RELEASE_DATE 1625616000
11164 #if ! defined(PERL_REVISION) && ! defined(PERL_VERSION_MAJOR)
11165 # if ! defined(__PATCHLEVEL_H_INCLUDED__) \
11166 && ! ( defined(PATCHLEVEL) && defined(SUBVERSION))
11167 # define PERL_PATCHLEVEL_H_IMPLICIT
11168 # include <patchlevel.h>
11170 # if ! defined(PERL_VERSION) \
11171 && ! defined(PERL_VERSION_MAJOR) \
11172 && ( ! defined(SUBVERSION) || ! defined(PATCHLEVEL) )
11173 # include <could_not_find_Perl_patchlevel.h>
11177 #ifdef PERL_VERSION_MAJOR
11178 # define D_PPP_MAJOR PERL_VERSION_MAJOR
11179 #elif defined(PERL_REVISION)
11180 # define D_PPP_MAJOR PERL_REVISION
11182 # define D_PPP_MAJOR 5
11185 #ifdef PERL_VERSION_MINOR
11186 # define D_PPP_MINOR PERL_VERSION_MINOR
11187 #elif defined(PERL_VERSION)
11188 # define D_PPP_MINOR PERL_VERSION
11189 #elif defined(PATCHLEVEL)
11190 # define D_PPP_MINOR PATCHLEVEL
11191 # define PERL_VERSION PATCHLEVEL
11193 # error Could not find a source for PERL_VERSION_MINOR
11196 #ifdef PERL_VERSION_PATCH
11197 # define D_PPP_PATCH PERL_VERSION_PATCH
11198 #elif defined(PERL_SUBVERSION)
11199 # define D_PPP_PATCH PERL_SUBVERSION
11200 #elif defined(SUBVERSION)
11201 # define D_PPP_PATCH SUBVERSION
11202 # define PERL_SUBVERSION SUBVERSION
11204 # error Could not find a source for PERL_VERSION_PATCH
11207 #if D_PPP_MAJOR < 5 || D_PPP_MAJOR == 6
11208 # error Devel::PPPort works only on Perl 5, Perl 7, ...
11209 #elif D_PPP_MAJOR != 5
11217 # undef PERL_REVISION
11218 # undef PERL_VERSION
11219 # undef PERL_SUBVERSION
11220 # define D_PPP_REVISION 5
11221 # define D_PPP_VERSION 201
11222 # define D_PPP_SUBVERSION 201
11223 # if (defined(__clang__) \
11224 && ( (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) \
11225 || defined(_STDC_C99) \
11226 || defined(__c99)))
11227 # define D_PPP_STRINGIFY(x) #x
11228 # define D_PPP_deprecate(xyz) _Pragma(D_PPP_STRINGIFY(GCC warning(D_PPP_STRINGIFY(xyz) " is deprecated")))
11229 # define PERL_REVISION (D_PPP_REVISION D_PPP_deprecate(PERL_REVISION))
11230 # define PERL_VERSION (D_PPP_REVISION D_PPP_deprecate(PERL_VERSION))
11231 # define PERL_SUBVERSION (D_PPP_SUBVERSION D_PPP_deprecate(PERL_SUBVERSION))
11233 # define PERL_REVISION D_PPP_REVISION
11234 # define PERL_VERSION D_PPP_REVISION
11235 # define PERL_SUBVERSION D_PPP_SUBVERSION
11254 #define D_PPP_DEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10))
11255 #define D_PPP_JNP_TO_BCD(j,n,p) ((D_PPP_DEC2BCD(j)<<24)|(D_PPP_DEC2BCD(n)<<12)|D_PPP_DEC2BCD(p))
11256 #define PERL_BCDVERSION D_PPP_JNP_TO_BCD(D_PPP_MAJOR, \
11263 #undef PERL_VERSION_EQ
11264 #undef PERL_VERSION_NE
11265 #undef PERL_VERSION_LT
11266 #undef PERL_VERSION_GE
11267 #undef PERL_VERSION_LE
11268 #undef PERL_VERSION_GT
11272 #ifndef PERL_VERSION_EQ
11273 # define PERL_VERSION_EQ(j,n,p) \
11274 (((p) == '*') ? ( (j) == D_PPP_VERSION_MAJOR \
11275 && (n) == D_PPP_VERSION_MINOR) \
11276 : (PERL_BCDVERSION == D_PPP_JNP_TO_BCD(j,n,p)))
11279 #ifndef PERL_VERSION_NE
11280 # define PERL_VERSION_NE(j,n,p) (! PERL_VERSION_EQ(j,n,p))
11282 #ifndef PERL_VERSION_LT
11283 # define PERL_VERSION_LT(j,n,p) \
11284 (PERL_BCDVERSION < D_PPP_JNP_TO_BCD( (j), \
11286 (((p) == '*') ? 0 : (p))))
11289 #ifndef PERL_VERSION_GE
11290 # define PERL_VERSION_GE(j,n,p) (! PERL_VERSION_LT(j,n,p))
11292 #ifndef PERL_VERSION_LE
11293 # define PERL_VERSION_LE(j,n,p) \
11294 (PERL_BCDVERSION < D_PPP_JNP_TO_BCD( (j), \
11295 (((p) == '*') ? ((n)+1) : (n)), \
11296 (((p) == '*') ? 0 : (p))))
11299 #ifndef PERL_VERSION_GT
11300 # define PERL_VERSION_GT(j,n,p) (! PERL_VERSION_LE(j,n,p))
11303 # define dTHR dNOOP
11306 # define dTHX dNOOP
11314 # define dTHXa(x) dNOOP
11341 #if (PERL_BCDVERSION < 0x5006000)
11342 # ifdef USE_THREADS
11344 # define aTHXR_ thr,
11349 # define dTHXR dTHR
11351 # define aTHXR aTHX
11352 # define aTHXR_ aTHX_
11353 # define dTHXR dTHX
11356 # define dTHXoa(x) dTHXa(x)
11360 # include <limits.h>
11363 #ifndef PERL_UCHAR_MIN
11364 # define PERL_UCHAR_MIN ((unsigned char)0)
11367 #ifndef PERL_UCHAR_MAX
11369 # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
11372 # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
11374 # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
11379 #ifndef PERL_USHORT_MIN
11380 # define PERL_USHORT_MIN ((unsigned short)0)
11383 #ifndef PERL_USHORT_MAX
11385 # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
11388 # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
11391 # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
11393 # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
11399 #ifndef PERL_SHORT_MAX
11401 # define PERL_SHORT_MAX ((short)SHORT_MAX)
11404 # define PERL_SHORT_MAX ((short)MAXSHORT)
11407 # define PERL_SHORT_MAX ((short)SHRT_MAX)
11409 # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
11415 #ifndef PERL_SHORT_MIN
11417 # define PERL_SHORT_MIN ((short)SHORT_MIN)
11420 # define PERL_SHORT_MIN ((short)MINSHORT)
11423 # define PERL_SHORT_MIN ((short)SHRT_MIN)
11425 # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
11431 #ifndef PERL_UINT_MAX
11433 # define PERL_UINT_MAX ((unsigned int)UINT_MAX)
11436 # define PERL_UINT_MAX ((unsigned int)MAXUINT)
11438 # define PERL_UINT_MAX (~(unsigned int)0)
11443 #ifndef PERL_UINT_MIN
11444 # define PERL_UINT_MIN ((unsigned int)0)
11447 #ifndef PERL_INT_MAX
11449 # define PERL_INT_MAX ((int)INT_MAX)
11452 # define PERL_INT_MAX ((int)MAXINT)
11454 # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
11459 #ifndef PERL_INT_MIN
11461 # define PERL_INT_MIN ((int)INT_MIN)
11464 # define PERL_INT_MIN ((int)MININT)
11466 # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
11471 #ifndef PERL_ULONG_MAX
11473 # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
11476 # define PERL_ULONG_MAX ((unsigned long)MAXULONG)
11478 # define PERL_ULONG_MAX (~(unsigned long)0)
11483 #ifndef PERL_ULONG_MIN
11484 # define PERL_ULONG_MIN ((unsigned long)0L)
11487 #ifndef PERL_LONG_MAX
11489 # define PERL_LONG_MAX ((long)LONG_MAX)
11492 # define PERL_LONG_MAX ((long)MAXLONG)
11494 # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
11499 #ifndef PERL_LONG_MIN
11501 # define PERL_LONG_MIN ((long)LONG_MIN)
11504 # define PERL_LONG_MIN ((long)MINLONG)
11506 # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
11511 #if defined(HAS_QUAD) && (defined(convex) || defined(uts))
11512 # ifndef PERL_UQUAD_MAX
11513 # ifdef ULONGLONG_MAX
11514 # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX)
11516 # ifdef MAXULONGLONG
11517 # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG)
11519 # define PERL_UQUAD_MAX (~(unsigned long long)0)
11524 # ifndef PERL_UQUAD_MIN
11525 # define PERL_UQUAD_MIN ((unsigned long long)0L)
11528 # ifndef PERL_QUAD_MAX
11529 # ifdef LONGLONG_MAX
11530 # define PERL_QUAD_MAX ((long long)LONGLONG_MAX)
11532 # ifdef MAXLONGLONG
11533 # define PERL_QUAD_MAX ((long long)MAXLONGLONG)
11535 # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1))
11540 # ifndef PERL_QUAD_MIN
11541 # ifdef LONGLONG_MIN
11542 # define PERL_QUAD_MIN ((long long)LONGLONG_MIN)
11544 # ifdef MINLONGLONG
11545 # define PERL_QUAD_MIN ((long long)MINLONGLONG)
11547 # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
11557 # define IVTYPE int
11561 # define IV_MIN PERL_INT_MIN
11565 # define IV_MAX PERL_INT_MAX
11569 # define UV_MIN PERL_UINT_MIN
11573 # define UV_MAX PERL_UINT_MAX
11578 # define IVSIZE INTSIZE
11583 # if defined(convex) || defined(uts)
11585 # define IVTYPE long long
11589 # define IV_MIN PERL_QUAD_MIN
11593 # define IV_MAX PERL_QUAD_MAX
11597 # define UV_MIN PERL_UQUAD_MIN
11601 # define UV_MAX PERL_UQUAD_MAX
11604 # ifdef LONGLONGSIZE
11606 # define IVSIZE LONGLONGSIZE
11612 # define IVTYPE long
11616 # define IV_MIN PERL_LONG_MIN
11620 # define IV_MAX PERL_LONG_MAX
11624 # define UV_MIN PERL_ULONG_MIN
11628 # define UV_MAX PERL_ULONG_MAX
11633 # define IVSIZE LONGSIZE
11644 # define LONGSIZE 8
11647 #ifndef PERL_QUAD_MIN
11648 # define PERL_QUAD_MIN IV_MIN
11651 #ifndef PERL_QUAD_MAX
11652 # define PERL_QUAD_MAX IV_MAX
11655 #ifndef PERL_UQUAD_MIN
11656 # define PERL_UQUAD_MIN UV_MIN
11659 #ifndef PERL_UQUAD_MAX
11660 # define PERL_UQUAD_MAX UV_MAX
11665 # define IVTYPE long
11669 # define LONGSIZE 4
11673 # define IV_MIN PERL_LONG_MIN
11677 # define IV_MAX PERL_LONG_MAX
11681 # define UV_MIN PERL_ULONG_MIN
11685 # define UV_MAX PERL_ULONG_MAX
11692 # define IVSIZE LONGSIZE
11698 # define UVTYPE unsigned IVTYPE
11702 # define UVSIZE IVSIZE
11705 #ifndef PERL_SIGNALS_UNSAFE_FLAG
11707 #define PERL_SIGNALS_UNSAFE_FLAG 0x0001
11709 #if (PERL_BCDVERSION < 0x5008000)
11710 # define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG
11712 # define D_PPP_PERL_SIGNALS_INIT 0
11715 #if defined(NEED_PL_signals)
11717 #elif defined(NEED_PL_signals_GLOBAL)
11722 #define PL_signals DPPP_(my_PL_signals)
11733 #if (PERL_BCDVERSION <= 0x5005005)
11735 # define PL_ppaddr ppaddr
11736 # define PL_no_modify no_modify
11740 #if (PERL_BCDVERSION <= 0x5004005)
11742 # define PL_DBsignal DBsignal
11743 # define PL_DBsingle DBsingle
11744 # define PL_DBsub DBsub
11745 # define PL_DBtrace DBtrace
11747 # define PL_Xpv Xpv
11748 # define PL_bufend bufend
11749 # define PL_bufptr bufptr
11750 # define PL_compiling compiling
11751 # define PL_copline copline
11752 # define PL_curcop curcop
11753 # define PL_curstash curstash
11754 # define PL_debstash debstash
11755 # define PL_defgv defgv
11756 # define PL_diehook diehook
11757 # define PL_dirty dirty
11758 # define PL_dowarn dowarn
11759 # define PL_errgv errgv
11760 # define PL_error_count error_count
11761 # define PL_expect expect
11762 # define PL_hexdigit hexdigit
11763 # define PL_hints hints
11764 # define PL_in_my in_my
11765 # define PL_laststatval laststatval
11766 # define PL_lex_state lex_state
11767 # define PL_lex_stuff lex_stuff
11768 # define PL_linestr linestr
11770 # define PL_perl_destruct_level perl_destruct_level
11771 # define PL_perldb perldb
11772 # define PL_rsfp_filters rsfp_filters
11773 # define PL_rsfp rsfp
11774 # define PL_stack_base stack_base
11775 # define PL_stack_sp stack_sp
11776 # define PL_statcache statcache
11777 # define PL_stdingv stdingv
11778 # define PL_sv_arenaroot sv_arenaroot
11779 # define PL_sv_no sv_no
11780 # define PL_sv_undef sv_undef
11781 # define PL_sv_yes sv_yes
11782 # define PL_tainted tainted
11783 # define PL_tainting tainting
11784 # define PL_tokenbuf tokenbuf
11785 # define PL_mess_sv mess_sv
11799 #if (PERL_BCDVERSION >= 0x5009005)
11800 # ifdef DPPP_PL_parser_NO_DUMMY
11801 # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \
11802 (croak("panic: PL_parser == NULL in %s:%d", \
11803 __FILE__, __LINE__), (yy_parser *) NULL))->var)
11805 # ifdef DPPP_PL_parser_NO_DUMMY_WARNING
11806 # define D_PPP_parser_dummy_warning(var)
11808 # define D_PPP_parser_dummy_warning(var) \
11809 warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__),
11811 # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \
11812 (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var)
11813 #if defined(NEED_PL_parser)
11814 static yy_parser
DPPP_(dummy_PL_parser);
11815 #elif defined(NEED_PL_parser_GLOBAL)
11816 yy_parser
DPPP_(dummy_PL_parser);
11818 extern yy_parser
DPPP_(dummy_PL_parser);
11838 # define PL_expect D_PPP_my_PL_parser_var(expect)
11839 # define PL_copline D_PPP_my_PL_parser_var(copline)
11840 # define PL_rsfp D_PPP_my_PL_parser_var(rsfp)
11841 # define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters)
11842 # define PL_linestr D_PPP_my_PL_parser_var(linestr)
11843 # define PL_bufptr D_PPP_my_PL_parser_var(bufptr)
11844 # define PL_bufend D_PPP_my_PL_parser_var(bufend)
11845 # define PL_lex_state D_PPP_my_PL_parser_var(lex_state)
11846 # define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff)
11847 # define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf)
11848 # define PL_in_my D_PPP_my_PL_parser_var(in_my)
11849 # define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash)
11850 # define PL_error_count D_PPP_my_PL_parser_var(error_count)
11856 # define PL_parser ((void *) 1)
11860 #if (PERL_BCDVERSION <= 0x5003022)
11861 # undef start_subparse
11862 # if (PERL_BCDVERSION < 0x5003022)
11863 #ifndef start_subparse
11864 # define start_subparse(a, b) Perl_start_subparse()
11868 #ifndef start_subparse
11869 # define start_subparse(a, b) Perl_start_subparse(b)
11874 #if (PERL_BCDVERSION < 0x5003007)
11880 #if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005)
11884 #define NEED_newCONSTSUB
11886 #if defined(NEED_newCONSTSUB)
11893 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
11896 # undef newCONSTSUB
11898 #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c)
11899 #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB)
11904 #define D_PPP_PL_copline PL_copline
11911 HV *old_cop_stash =
PL_curcop->cop_stash;
11924 newSVOP(OP_CONST, 0, newSVpv((
char *)
name, 0)),
11926 newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
11938 #ifndef PERL_MAGIC_sv
11939 # define PERL_MAGIC_sv '\0'
11942 #ifndef PERL_MAGIC_overload
11943 # define PERL_MAGIC_overload 'A'
11946 #ifndef PERL_MAGIC_overload_elem
11947 # define PERL_MAGIC_overload_elem 'a'
11950 #ifndef PERL_MAGIC_overload_table
11951 # define PERL_MAGIC_overload_table 'c'
11954 #ifndef PERL_MAGIC_bm
11955 # define PERL_MAGIC_bm 'B'
11958 #ifndef PERL_MAGIC_regdata
11959 # define PERL_MAGIC_regdata 'D'
11962 #ifndef PERL_MAGIC_regdatum
11963 # define PERL_MAGIC_regdatum 'd'
11966 #ifndef PERL_MAGIC_env
11967 # define PERL_MAGIC_env 'E'
11970 #ifndef PERL_MAGIC_envelem
11971 # define PERL_MAGIC_envelem 'e'
11974 #ifndef PERL_MAGIC_fm
11975 # define PERL_MAGIC_fm 'f'
11978 #ifndef PERL_MAGIC_regex_global
11979 # define PERL_MAGIC_regex_global 'g'
11982 #ifndef PERL_MAGIC_isa
11983 # define PERL_MAGIC_isa 'I'
11986 #ifndef PERL_MAGIC_isaelem
11987 # define PERL_MAGIC_isaelem 'i'
11990 #ifndef PERL_MAGIC_nkeys
11991 # define PERL_MAGIC_nkeys 'k'
11994 #ifndef PERL_MAGIC_dbfile
11995 # define PERL_MAGIC_dbfile 'L'
11998 #ifndef PERL_MAGIC_dbline
11999 # define PERL_MAGIC_dbline 'l'
12002 #ifndef PERL_MAGIC_mutex
12003 # define PERL_MAGIC_mutex 'm'
12006 #ifndef PERL_MAGIC_shared
12007 # define PERL_MAGIC_shared 'N'
12010 #ifndef PERL_MAGIC_shared_scalar
12011 # define PERL_MAGIC_shared_scalar 'n'
12014 #ifndef PERL_MAGIC_collxfrm
12015 # define PERL_MAGIC_collxfrm 'o'
12018 #ifndef PERL_MAGIC_tied
12019 # define PERL_MAGIC_tied 'P'
12022 #ifndef PERL_MAGIC_tiedelem
12023 # define PERL_MAGIC_tiedelem 'p'
12026 #ifndef PERL_MAGIC_tiedscalar
12027 # define PERL_MAGIC_tiedscalar 'q'
12030 #ifndef PERL_MAGIC_qr
12031 # define PERL_MAGIC_qr 'r'
12034 #ifndef PERL_MAGIC_sig
12035 # define PERL_MAGIC_sig 'S'
12038 #ifndef PERL_MAGIC_sigelem
12039 # define PERL_MAGIC_sigelem 's'
12042 #ifndef PERL_MAGIC_taint
12043 # define PERL_MAGIC_taint 't'
12046 #ifndef PERL_MAGIC_uvar
12047 # define PERL_MAGIC_uvar 'U'
12050 #ifndef PERL_MAGIC_uvar_elem
12051 # define PERL_MAGIC_uvar_elem 'u'
12054 #ifndef PERL_MAGIC_vstring
12055 # define PERL_MAGIC_vstring 'V'
12058 #ifndef PERL_MAGIC_vec
12059 # define PERL_MAGIC_vec 'v'
12062 #ifndef PERL_MAGIC_utf8
12063 # define PERL_MAGIC_utf8 'w'
12066 #ifndef PERL_MAGIC_substr
12067 # define PERL_MAGIC_substr 'x'
12070 #ifndef PERL_MAGIC_defelem
12071 # define PERL_MAGIC_defelem 'y'
12074 #ifndef PERL_MAGIC_glob
12075 # define PERL_MAGIC_glob '*'
12078 #ifndef PERL_MAGIC_arylen
12079 # define PERL_MAGIC_arylen '#'
12082 #ifndef PERL_MAGIC_pos
12083 # define PERL_MAGIC_pos '.'
12086 #ifndef PERL_MAGIC_backref
12087 # define PERL_MAGIC_backref '<'
12090 #ifndef PERL_MAGIC_ext
12091 # define PERL_MAGIC_ext '~'
12094 # define cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0)
12097 #ifndef OpHAS_SIBLING
12098 # define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling))
12102 # define OpSIBLING(o) (0 + (o)->op_sibling)
12105 #ifndef OpMORESIB_set
12106 # define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib))
12109 #ifndef OpLASTSIB_set
12110 # define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL)
12113 #ifndef OpMAYBESIB_set
12114 # define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib))
12118 # define HEf_SVKEY -2
12121 #if defined(DEBUGGING) && !defined(__COVERITY__)
12123 # define __ASSERT_(statement) assert(statement),
12128 # define __ASSERT_(statement)
12132 #ifndef __has_builtin
12133 # define __has_builtin(x) 0
12136 #if __has_builtin(__builtin_unreachable)
12137 # define D_PPP_HAS_BUILTIN_UNREACHABLE
12138 #elif (defined(__GNUC__) && ( __GNUC__ > 4 \
12139 || __GNUC__ == 4 && __GNUC_MINOR__ >= 5))
12140 # define D_PPP_HAS_BUILTIN_UNREACHABLE
12145 # define ASSUME(x) assert(x)
12146 # elif defined(_MSC_VER)
12147 # define ASSUME(x) __assume(x)
12148 # elif defined(__ARMCC_VERSION)
12149 # define ASSUME(x) __promise(x)
12150 # elif defined(D_PPP_HAS_BUILTIN_UNREACHABLE)
12151 # define ASSUME(x) ((x) ? (void) 0 : __builtin_unreachable())
12153 # define ASSUME(x) assert(x)
12157 #ifndef NOT_REACHED
12158 # ifdef D_PPP_HAS_BUILTIN_UNREACHABLE
12159 # define NOT_REACHED \
12161 ASSUME(!"UNREACHABLE"); __builtin_unreachable(); \
12163 # elif ! defined(__GNUC__) && defined(__sun)
12164 # define NOT_REACHED
12166 # define NOT_REACHED ASSUME(!"UNREACHABLE")
12170 #ifndef WIDEST_UTYPE
12173 # define WIDEST_UTYPE U64TYPE
12175 # define WIDEST_UTYPE unsigned Quad_t
12178 # define WIDEST_UTYPE U32
12183 #ifndef withinCOUNT
12184 # define withinCOUNT(c, l, n) \
12185 (((WIDEST_UTYPE) (((c)) - ((l) | 0))) <= (((WIDEST_UTYPE) ((n) | 0))))
12189 # define inRANGE(c, l, u) \
12190 ( (sizeof(c) == sizeof(U8)) ? withinCOUNT(((U8) (c)), (l), ((u) - (l))) \
12191 : (sizeof(c) == sizeof(U32)) ? withinCOUNT(((U32) (c)), (l), ((u) - (l))) \
12192 : (withinCOUNT(((WIDEST_UTYPE) (c)), (l), ((u) - (l)))))
12197 #undef FITS_IN_8_BITS
12198 #ifndef FITS_IN_8_BITS
12199 # define FITS_IN_8_BITS(c) ( (sizeof(c) == 1) \
12200 || !(((WIDEST_UTYPE)((c) | 0)) & ~0xFF))
12207 #define D_PPP_IS_GENERIC_UTF8_SAFE(s, e, macro) \
12208 (((e) - (s)) <= 0 \
12210 : UTF8_IS_INVARIANT((s)[0]) \
12211 ? is ## macro ## _L1((s)[0]) \
12212 : (((e) - (s)) < UTF8SKIP(s)) \
12214 : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \
12216 ? is ## macro ## _L1((WIDEST_UTYPE) LATIN1_TO_NATIVE( \
12217 UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \
12218 & UTF_START_MASK(2), \
12220 : is ## macro ## _utf8(s))
12226 #define D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, macro) \
12227 (((e) - (s)) <= 0 \
12229 : UTF8_IS_INVARIANT((s)[0]) \
12230 ? is ## macro ## _LC((s)[0]) \
12231 : (((e) - (s)) < UTF8SKIP(s)) \
12233 : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \
12235 ? is ## macro ## _LC((WIDEST_UTYPE) LATIN1_TO_NATIVE( \
12236 UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \
12237 & UTF_START_MASK(2), \
12239 : is ## macro ## _utf8(s))
12249 #define D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, macro) \
12250 (((e) - (s)) <= 0 \
12252 : UTF8_IS_INVARIANT((s)[0]) \
12253 ? is ## macro ## _LC((s)[0]) \
12254 : (((e) - (s)) < UTF8SKIP(s)) \
12256 : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \
12258 ? is ## macro ## _LC((WIDEST_UTYPE) LATIN1_TO_NATIVE( \
12259 UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \
12260 & UTF_START_MASK(2), \
12262 : is ## macro ## _utf8_safe(s, e))
12264 # define 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)
12268 # define SvRXOK(sv) (!!SvRX(sv))
12271 #ifndef PERL_UNUSED_DECL
12272 # ifdef HASATTRIBUTE
12273 # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
12274 # define PERL_UNUSED_DECL
12276 # define PERL_UNUSED_DECL __attribute__((unused))
12279 # define PERL_UNUSED_DECL
12283 #ifndef PERL_UNUSED_ARG
12284 # if defined(lint) && defined(S_SPLINT_S)
12286 # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
12288 # define PERL_UNUSED_ARG(x) ((void)x)
12292 #ifndef PERL_UNUSED_VAR
12293 # define PERL_UNUSED_VAR(x) ((void)x)
12296 #ifndef PERL_UNUSED_CONTEXT
12297 # ifdef USE_ITHREADS
12298 # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
12300 # define PERL_UNUSED_CONTEXT
12304 #ifndef PERL_UNUSED_RESULT
12305 # if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT)
12306 # define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END
12308 # define PERL_UNUSED_RESULT(v) ((void)(v))
12312 # define NOOP (void)0
12316 # define dNOOP extern int Perl___notused PERL_UNUSED_DECL
12320 # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
12321 # define NVTYPE long double
12323 # define NVTYPE double
12329 # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
12331 # define INT2PTR(any,d) (any)(d)
12333 # if PTRSIZE == LONGSIZE
12334 # define PTRV unsigned long
12336 # define PTRV unsigned
12338 # define INT2PTR(any,d) (any)(PTRV)(d)
12343 # if PTRSIZE == LONGSIZE
12344 # define PTR2ul(p) (unsigned long)(p)
12346 # define PTR2ul(p) INT2PTR(unsigned long,p)
12350 # define PTR2nat(p) (PTRV)(p)
12354 # define NUM2PTR(any,d) (any)PTR2nat(d)
12358 # define PTR2IV(p) INT2PTR(IV,p)
12362 # define PTR2UV(p) INT2PTR(UV,p)
12366 # define PTR2NV(p) NUM2PTR(NV,p)
12369 #undef START_EXTERN_C
12370 #undef END_EXTERN_C
12373 # define START_EXTERN_C extern "C" {
12374 # define END_EXTERN_C }
12375 # define EXTERN_C extern "C"
12377 # define START_EXTERN_C
12378 # define END_EXTERN_C
12379 # define EXTERN_C extern
12382 #if (PERL_BCDVERSION < 0x5004000) || defined(PERL_GCC_PEDANTIC)
12383 # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
12384 #ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
12385 # define PERL_GCC_BRACE_GROUPS_FORBIDDEN
12391 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
12392 # ifndef PERL_USE_GCC_BRACE_GROUPS
12393 # define PERL_USE_GCC_BRACE_GROUPS
12399 #ifdef PERL_USE_GCC_BRACE_GROUPS
12400 # define STMT_START (void)(
12401 # define STMT_END )
12403 # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
12404 # define STMT_START if (1)
12405 # define STMT_END else (void)0
12407 # define STMT_START do
12408 # define STMT_END while (0)
12412 # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
12417 # define DEFSV GvSV(PL_defgv)
12421 # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
12425 # define DEFSV_set(sv) (DEFSV = (sv))
12430 # define AvFILLp AvFILL
12433 # define av_tindex AvFILL
12436 #ifndef av_top_index
12437 # define av_top_index AvFILL
12441 # define av_count(av) (AvFILL(av)+1)
12444 # define ERRSV get_sv("@",FALSE)
12453 #ifndef gv_stashpvn
12454 # define gv_stashpvn(str,len,create) gv_stashpv(str,create)
12459 # define get_cv perl_get_cv
12463 # define get_sv perl_get_sv
12467 # define get_av perl_get_av
12471 # define get_hv perl_get_hv
12476 # define dUNDERBAR dNOOP
12480 # define UNDERBAR DEFSV
12483 # define dAX I32 ax = MARK - PL_stack_base + 1
12487 # define dITEMS I32 items = SP - MARK
12490 # define dXSTARG SV * targ = sv_newmortal()
12493 # define dAXMARK I32 ax = POPMARK; \
12494 SV ** const mark = PL_stack_base + ax++
12497 # define XSprePUSH (sp = PL_stack_base + ax - 1)
12500 #if (PERL_BCDVERSION < 0x5005000)
12502 # define XSRETURN(off) \
12504 PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
12509 # define XSPROTO(name) void name(pTHX_ CV* cv)
12513 # define SVfARG(p) ((void*)(p))
12516 # define PERL_ABS(x) ((x) < 0 ? -(x) : (x))
12519 # define dVAR dNOOP
12525 # define CPERLscope(x) x
12528 # define PERL_HASH(hash,str,len) \
12530 const char *s_PeRlHaSh = str; \
12531 I32 i_PeRlHaSh = len; \
12532 U32 hash_PeRlHaSh = 0; \
12533 while (i_PeRlHaSh--) \
12534 hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
12535 (hash) = hash_PeRlHaSh; \
12539 #ifndef PERLIO_FUNCS_DECL
12540 # ifdef PERLIO_FUNCS_CONST
12541 # define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
12542 # define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
12544 # define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
12545 # define PERLIO_FUNCS_CAST(funcs) (funcs)
12550 #if (PERL_BCDVERSION < 0x5009003)
12563 #if defined(EBCDIC) && defined(NATIVE_TO_ASCI)
12564 #ifndef NATIVE_TO_LATIN1
12565 # define NATIVE_TO_LATIN1(c) NATIVE_TO_ASCII(c)
12568 #ifndef LATIN1_TO_NATIVE
12569 # define LATIN1_TO_NATIVE(c) ASCII_TO_NATIVE(c)
12572 #ifndef NATIVE_TO_UNI
12573 # define NATIVE_TO_UNI(c) ((c) > 255 ? (c) : NATIVE_TO_LATIN1(c))
12576 #ifndef UNI_TO_NATIVE
12577 # define UNI_TO_NATIVE(c) ((c) > 255 ? (c) : LATIN1_TO_NATIVE(c))
12581 #ifndef NATIVE_TO_LATIN1
12582 # define NATIVE_TO_LATIN1(c) (c)
12585 #ifndef LATIN1_TO_NATIVE
12586 # define LATIN1_TO_NATIVE(c) (c)
12589 #ifndef NATIVE_TO_UNI
12590 # define NATIVE_TO_UNI(c) (c)
12593 #ifndef UNI_TO_NATIVE
12594 # define UNI_TO_NATIVE(c) (c)
12625 # if (PERL_BCDVERSION < 0x5022000)
12631 # undef isALNUMC_L1
12635 # undef isALPHANUMERIC
12636 # undef isALPHANUMERIC_A
12637 # undef isALPHANUMERIC_L1
12655 # undef isIDCONT_L1
12657 # undef isIDFIRST_A
12658 # undef isIDFIRST_L1
12678 # undef isWORDCHAR_A
12679 # undef isWORDCHAR_L1
12682 # undef isXDIGIT_L1
12685 # define isASCII(c) (isCNTRL(c) || isPRINT(c))
12691 # define isCNTRL(c) ( (c) == '\0' || (c) == '\a' || (c) == '\b' \
12692 || (c) == '\f' || (c) == '\n' || (c) == '\r' \
12693 || (c) == '\t' || (c) == '\v' \
12694 || ((c) <= 3 && (c) >= 1) \
12696 || ((c) <= 0x13 && (c) >= 0x0E) \
12700 || ((c) <= 0x1F && (c) >= 0x1C) \
12714 # define D_PPP_OUTLIER_CONTROL 0x5F
12716 # define D_PPP_OUTLIER_CONTROL 0xFF
12721 # define isCNTRL_L1(c) ((WIDEST_UTYPE) (c) < ' ' \
12722 || (WIDEST_UTYPE) (c) == D_PPP_OUTLIER_CONTROL)
12728 # define isLOWER(c) ( (c) >= 'a' && (c) <= 'z' \
12730 || ((c) >= 'j' && (c) <= 'r') \
12735 # define isUPPER(c) ( (c) >= 'A' && (c) <= 'Z' \
12737 || ((c) >= 'J' && (c) <= 'R') \
12743 # if (PERL_BCDVERSION < 0x5004000)
12753 # undef isIDFIRST_A
12760 # if (PERL_BCDVERSION == 0x5007000)
12764 # if (PERL_BCDVERSION < 0x5008000)
12768 # if (PERL_BCDVERSION < 0x5010000)
12776 # if (PERL_BCDVERSION < 0x5014000)
12782 # if (PERL_BCDVERSION < 0x5017008)
12786 # if (PERL_BCDVERSION < 0x5013007)
12787 # undef isALNUMC_L1
12790 # if (PERL_BCDVERSION < 0x5020000)
12797 # define isASCII(c) ((WIDEST_UTYPE) (c) <= 127)
12801 # define isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127)
12805 # define isCNTRL_L1(c) ( (WIDEST_UTYPE) (c) < ' ' \
12806 || inRANGE((c), 0x7F, 0x9F))
12810 # define isLOWER(c) inRANGE((c), 'a', 'z')
12814 # define isUPPER(c) inRANGE((c), 'A', 'Z')
12819 # define isASCII_L1(c) isASCII(c)
12823 # define isASCII_LC(c) isASCII(c)
12827 # define isALNUM(c) isWORDCHAR(c)
12831 # define isALNUMC(c) isALPHANUMERIC(c)
12834 #ifndef isALNUMC_L1
12835 # define isALNUMC_L1(c) isALPHANUMERIC_L1(c)
12839 # define isALPHA(c) (isUPPER(c) || isLOWER(c))
12843 # define isALPHA_L1(c) (isUPPER_L1(c) || isLOWER_L1(c))
12846 #ifndef isALPHANUMERIC
12847 # define isALPHANUMERIC(c) (isALPHA(c) || isDIGIT(c))
12850 #ifndef isALPHANUMERIC_L1
12851 # define isALPHANUMERIC_L1(c) (isALPHA_L1(c) || isDIGIT(c))
12854 #ifndef isALPHANUMERIC_LC
12855 # define isALPHANUMERIC_LC(c) (isALPHA_LC(c) || isDIGIT_LC(c))
12859 # define isBLANK(c) ((c) == ' ' || (c) == '\t')
12863 # define isBLANK_L1(c) ( isBLANK(c) \
12864 || ( FITS_IN_8_BITS(c) \
12865 && NATIVE_TO_LATIN1((U8) c) == 0xA0))
12869 # define isBLANK_LC(c) isBLANK(c)
12873 # define isDIGIT(c) inRANGE(c, '0', '9')
12877 # define isDIGIT_L1(c) isDIGIT(c)
12881 # define isGRAPH(c) (isWORDCHAR(c) || isPUNCT(c))
12885 # define isGRAPH_L1(c) ( isPRINT_L1(c) \
12887 && NATIVE_TO_LATIN1((U8) c) != 0xA0)
12891 # define isIDCONT(c) isWORDCHAR(c)
12894 #ifndef isIDCONT_L1
12895 # define isIDCONT_L1(c) isWORDCHAR_L1(c)
12898 #ifndef isIDCONT_LC
12899 # define isIDCONT_LC(c) isWORDCHAR_LC(c)
12903 # define isIDFIRST(c) (isALPHA(c) || (c) == '_')
12906 #ifndef isIDFIRST_L1
12907 # define isIDFIRST_L1(c) (isALPHA_L1(c) || (U8) (c) == '_')
12910 #ifndef isIDFIRST_LC
12911 # define isIDFIRST_LC(c) (isALPHA_LC(c) || (U8) (c) == '_')
12915 # define isLOWER_L1(c) ( isLOWER(c) \
12916 || ( FITS_IN_8_BITS(c) \
12917 && ( ( NATIVE_TO_LATIN1((U8) c) >= 0xDF \
12918 && NATIVE_TO_LATIN1((U8) c) != 0xF7) \
12919 || NATIVE_TO_LATIN1((U8) c) == 0xAA \
12920 || NATIVE_TO_LATIN1((U8) c) == 0xBA \
12921 || NATIVE_TO_LATIN1((U8) c) == 0xB5)))
12925 # define isOCTAL(c) (((WIDEST_UTYPE)((c)) & ~7) == '0')
12929 # define isOCTAL_L1(c) isOCTAL(c)
12933 # define isPRINT(c) (isGRAPH(c) || (c) == ' ')
12937 # define isPRINT_L1(c) (FITS_IN_8_BITS(c) && ! isCNTRL_L1(c))
12941 # define isPSXSPC(c) isSPACE(c)
12944 #ifndef isPSXSPC_L1
12945 # define isPSXSPC_L1(c) isSPACE_L1(c)
12949 # define isPUNCT(c) ( (c) == '-' || (c) == '!' || (c) == '"' \
12950 || (c) == '#' || (c) == '$' || (c) == '%' \
12951 || (c) == '&' || (c) == '\'' || (c) == '(' \
12952 || (c) == ')' || (c) == '*' || (c) == '+' \
12953 || (c) == ',' || (c) == '.' || (c) == '/' \
12954 || (c) == ':' || (c) == ';' || (c) == '<' \
12955 || (c) == '=' || (c) == '>' || (c) == '?' \
12956 || (c) == '@' || (c) == '[' || (c) == '\\' \
12957 || (c) == ']' || (c) == '^' || (c) == '_' \
12958 || (c) == '`' || (c) == '{' || (c) == '|' \
12959 || (c) == '}' || (c) == '~')
12963 # define isPUNCT_L1(c) ( isPUNCT(c) \
12964 || ( FITS_IN_8_BITS(c) \
12965 && ( NATIVE_TO_LATIN1((U8) c) == 0xA1 \
12966 || NATIVE_TO_LATIN1((U8) c) == 0xA7 \
12967 || NATIVE_TO_LATIN1((U8) c) == 0xAB \
12968 || NATIVE_TO_LATIN1((U8) c) == 0xB6 \
12969 || NATIVE_TO_LATIN1((U8) c) == 0xB7 \
12970 || NATIVE_TO_LATIN1((U8) c) == 0xBB \
12971 || NATIVE_TO_LATIN1((U8) c) == 0xBF)))
12975 # define isSPACE(c) ( isBLANK(c) || (c) == '\n' || (c) == '\r' \
12976 || (c) == '\v' || (c) == '\f')
12980 # define isSPACE_L1(c) ( isSPACE(c) \
12981 || (FITS_IN_8_BITS(c) \
12982 && ( NATIVE_TO_LATIN1((U8) c) == 0x85 \
12983 || NATIVE_TO_LATIN1((U8) c) == 0xA0)))
12987 # define isUPPER_L1(c) ( isUPPER(c) \
12988 || (FITS_IN_8_BITS(c) \
12989 && ( NATIVE_TO_LATIN1((U8) c) >= 0xC0 \
12990 && NATIVE_TO_LATIN1((U8) c) <= 0xDE \
12991 && NATIVE_TO_LATIN1((U8) c) != 0xD7)))
12995 # define isWORDCHAR(c) (isALPHANUMERIC(c) || (c) == '_')
12998 #ifndef isWORDCHAR_L1
12999 # define isWORDCHAR_L1(c) (isIDFIRST_L1(c) || isDIGIT(c))
13002 #ifndef isWORDCHAR_LC
13003 # define isWORDCHAR_LC(c) (isIDFIRST_LC(c) || isDIGIT_LC(c))
13007 # define isXDIGIT(c) ( isDIGIT(c) \
13008 || inRANGE((c), 'a', 'f') \
13009 || inRANGE((c), 'A', 'F'))
13012 #ifndef isXDIGIT_L1
13013 # define isXDIGIT_L1(c) isXDIGIT(c)
13016 #ifndef isXDIGIT_LC
13017 # define isXDIGIT_LC(c) isxdigit(c)
13020 # define isALNUM_A(c) isALNUM(c)
13024 # define isALNUMC_A(c) isALNUMC(c)
13028 # define isALPHA_A(c) isALPHA(c)
13031 #ifndef isALPHANUMERIC_A
13032 # define isALPHANUMERIC_A(c) isALPHANUMERIC(c)
13036 # define isASCII_A(c) isASCII(c)
13040 # define isBLANK_A(c) isBLANK(c)
13044 # define isCNTRL_A(c) isCNTRL(c)
13048 # define isDIGIT_A(c) isDIGIT(c)
13052 # define isGRAPH_A(c) isGRAPH(c)
13056 # define isIDCONT_A(c) isIDCONT(c)
13059 #ifndef isIDFIRST_A
13060 # define isIDFIRST_A(c) isIDFIRST(c)
13064 # define isLOWER_A(c) isLOWER(c)
13068 # define isOCTAL_A(c) isOCTAL(c)
13072 # define isPRINT_A(c) isPRINT(c)
13076 # define isPSXSPC_A(c) isPSXSPC(c)
13080 # define isPUNCT_A(c) isPUNCT(c)
13084 # define isSPACE_A(c) isSPACE(c)
13088 # define isUPPER_A(c) isUPPER(c)
13091 #ifndef isWORDCHAR_A
13092 # define isWORDCHAR_A(c) isWORDCHAR(c)
13096 # define isXDIGIT_A(c) isXDIGIT(c)
13098 #ifndef isASCII_utf8_safe
13099 # define isASCII_utf8_safe(s,e) (((e) - (s)) <= 0 ? 0 : isASCII(*(s)))
13102 #ifndef isASCII_uvchr
13103 # define isASCII_uvchr(c) (FITS_IN_8_BITS(c) ? isASCII_L1(c) : 0)
13106 #if (PERL_BCDVERSION >= 0x5006000)
13107 # ifdef isALPHA_uni /* If one defined, all are; this is just an exemplar */
13108 # define D_PPP_is_ctype(upper, lower, c) \
13109 (FITS_IN_8_BITS(c) \
13110 ? is ## upper ## _L1(c) \
13111 : is ## upper ## _uni((UV) (c))) /* _uni is old synonym */
13113 # define D_PPP_is_ctype(upper, lower, c) \
13114 (FITS_IN_8_BITS(c) \
13115 ? is ## upper ## _L1(c) \
13116 : is_uni_ ## lower((UV) (c))) /* is_uni_ is even older */
13118 #ifndef isALPHA_uvchr
13119 # define isALPHA_uvchr(c) D_PPP_is_ctype(ALPHA, alpha, c)
13122 #ifndef isALPHANUMERIC_uvchr
13123 # define isALPHANUMERIC_uvchr(c) (isALPHA_uvchr(c) || isDIGIT_uvchr(c))
13126 # ifdef is_uni_blank
13127 #ifndef isBLANK_uvchr
13128 # define isBLANK_uvchr(c) D_PPP_is_ctype(BLANK, blank, c)
13132 #ifndef isBLANK_uvchr
13133 # define isBLANK_uvchr(c) (FITS_IN_8_BITS(c) \
13135 : ( (UV) (c) == 0x1680 /* Unicode 3.0 */ \
13136 || inRANGE((UV) (c), 0x2000, 0x200A) \
13137 || (UV) (c) == 0x202F /* Unicode 3.0 */\
13138 || (UV) (c) == 0x205F /* Unicode 3.2 */\
13139 || (UV) (c) == 0x3000))
13143 #ifndef isCNTRL_uvchr
13144 # define isCNTRL_uvchr(c) D_PPP_is_ctype(CNTRL, cntrl, c)
13147 #ifndef isDIGIT_uvchr
13148 # define isDIGIT_uvchr(c) D_PPP_is_ctype(DIGIT, digit, c)
13151 #ifndef isGRAPH_uvchr
13152 # define isGRAPH_uvchr(c) D_PPP_is_ctype(GRAPH, graph, c)
13155 #ifndef isIDCONT_uvchr
13156 # define isIDCONT_uvchr(c) isWORDCHAR_uvchr(c)
13159 #ifndef isIDFIRST_uvchr
13160 # define isIDFIRST_uvchr(c) D_PPP_is_ctype(IDFIRST, idfirst, c)
13163 #ifndef isLOWER_uvchr
13164 # define isLOWER_uvchr(c) D_PPP_is_ctype(LOWER, lower, c)
13167 #ifndef isPRINT_uvchr
13168 # define isPRINT_uvchr(c) D_PPP_is_ctype(PRINT, print, c)
13171 #ifndef isPSXSPC_uvchr
13172 # define isPSXSPC_uvchr(c) isSPACE_uvchr(c)
13175 #ifndef isPUNCT_uvchr
13176 # define isPUNCT_uvchr(c) D_PPP_is_ctype(PUNCT, punct, c)
13179 #ifndef isSPACE_uvchr
13180 # define isSPACE_uvchr(c) D_PPP_is_ctype(SPACE, space, c)
13183 #ifndef isUPPER_uvchr
13184 # define isUPPER_uvchr(c) D_PPP_is_ctype(UPPER, upper, c)
13187 #ifndef isXDIGIT_uvchr
13188 # define isXDIGIT_uvchr(c) D_PPP_is_ctype(XDIGIT, xdigit, c)
13191 #ifndef isWORDCHAR_uvchr
13192 # define isWORDCHAR_uvchr(c) (FITS_IN_8_BITS(c) \
13193 ? isWORDCHAR_L1(c) : isALPHANUMERIC_uvchr(c))
13195 #ifndef isALPHA_utf8_safe
13196 # define isALPHA_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, ALPHA)
13199 # ifdef isALPHANUMERIC_utf8
13200 #ifndef isALPHANUMERIC_utf8_safe
13201 # define isALPHANUMERIC_utf8_safe(s,e) \
13202 D_PPP_IS_GENERIC_UTF8_SAFE(s, e, ALPHANUMERIC)
13206 #ifndef isALPHANUMERIC_utf8_safe
13207 # define isALPHANUMERIC_utf8_safe(s,e) \
13208 (isALPHA_utf8_safe(s,e) || isDIGIT_utf8_safe(s,e))
13213 /* This was broken before 5.18, and just use this instead of worrying about
13214 * which releases the official works on */
13216 #ifndef isBLANK_utf8_safe
13217 # define isBLANK_utf8_safe(s,e) \
13218 ( ( LIKELY((e) > (s)) ) ? /* Machine generated */ \
13219 ( ( 0x09 == ((const U8*)s)[0] || 0x20 == ((const U8*)s)[0] ) ? 1 \
13220 : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \
13221 ( ( 0xC2 == ((const U8*)s)[0] ) ? \
13222 ( ( 0xA0 == ((const U8*)s)[1] ) ? 2 : 0 ) \
13223 : ( 0xE1 == ((const U8*)s)[0] ) ? \
13224 ( ( ( 0x9A == ((const U8*)s)[1] ) && ( 0x80 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
13225 : ( 0xE2 == ((const U8*)s)[0] ) ? \
13226 ( ( 0x80 == ((const U8*)s)[1] ) ? \
13227 ( ( inRANGE(((const U8*)s)[2], 0x80, 0x8A ) || 0xAF == ((const U8*)s)[2] ) ? 3 : 0 )\
13228 : ( ( 0x81 == ((const U8*)s)[1] ) && ( 0x9F == ((const U8*)s)[2] ) ) ? 3 : 0 )\
13229 : ( ( ( 0xE3 == ((const U8*)s)[0] ) && ( 0x80 == ((const U8*)s)[1] ) ) && ( 0x80 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
13234 # elif 'A' == 193 && '^' == 95 /* EBCDIC 1047 */
13235 #ifndef isBLANK_utf8_safe
13236 # define isBLANK_utf8_safe(s,e) \
13237 ( ( LIKELY((e) > (s)) ) ? \
13238 ( ( 0x05 == ((const U8*)s)[0] || 0x40 == ((const U8*)s)[0] ) ? 1 \
13239 : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \
13240 ( ( 0x80 == ((const U8*)s)[0] ) ? \
13241 ( ( 0x41 == ((const U8*)s)[1] ) ? 2 : 0 ) \
13242 : ( 0xBC == ((const U8*)s)[0] ) ? \
13243 ( ( ( 0x63 == ((const U8*)s)[1] ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
13244 : ( 0xCA == ((const U8*)s)[0] ) ? \
13245 ( ( 0x41 == ((const U8*)s)[1] ) ? \
13246 ( ( inRANGE(((const U8*)s)[2], 0x41, 0x4A ) || 0x51 == ((const U8*)s)[2] ) ? 3 : 0 )\
13247 : ( 0x42 == ((const U8*)s)[1] ) ? \
13248 ( ( 0x56 == ((const U8*)s)[2] ) ? 3 : 0 ) \
13249 : ( ( 0x43 == ((const U8*)s)[1] ) && ( 0x73 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
13250 : ( ( ( 0xCE == ((const U8*)s)[0] ) && ( 0x41 == ((const U8*)s)[1] ) ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
13255 # elif 'A' == 193 && '^' == 176 /* EBCDIC 037 */
13256 #ifndef isBLANK_utf8_safe
13257 # define isBLANK_utf8_safe(s,e) \
13258 ( ( LIKELY((e) > (s)) ) ? \
13259 ( ( 0x05 == ((const U8*)s)[0] || 0x40 == ((const U8*)s)[0] ) ? 1 \
13260 : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \
13261 ( ( 0x78 == ((const U8*)s)[0] ) ? \
13262 ( ( 0x41 == ((const U8*)s)[1] ) ? 2 : 0 ) \
13263 : ( 0xBD == ((const U8*)s)[0] ) ? \
13264 ( ( ( 0x62 == ((const U8*)s)[1] ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
13265 : ( 0xCA == ((const U8*)s)[0] ) ? \
13266 ( ( 0x41 == ((const U8*)s)[1] ) ? \
13267 ( ( inRANGE(((const U8*)s)[2], 0x41, 0x4A ) || 0x51 == ((const U8*)s)[2] ) ? 3 : 0 )\
13268 : ( 0x42 == ((const U8*)s)[1] ) ? \
13269 ( ( 0x56 == ((const U8*)s)[2] ) ? 3 : 0 ) \
13270 : ( ( 0x43 == ((const U8*)s)[1] ) && ( 0x72 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
13271 : ( ( ( 0xCE == ((const U8*)s)[0] ) && ( 0x41 == ((const U8*)s)[1] ) ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
13277 # error Unknown character set
13279 #ifndef isCNTRL_utf8_safe
13280 # define isCNTRL_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, CNTRL)
13283 #ifndef isDIGIT_utf8_safe
13284 # define isDIGIT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, DIGIT)
13287 #ifndef isGRAPH_utf8_safe
13288 # define isGRAPH_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, GRAPH)
13291 # ifdef isIDCONT_utf8
13292 #ifndef isIDCONT_utf8_safe
13293 # define isIDCONT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, IDCONT)
13297 #ifndef isIDCONT_utf8_safe
13298 # define isIDCONT_utf8_safe(s,e) isWORDCHAR_utf8_safe(s,e)
13302 #ifndef isIDFIRST_utf8_safe
13303 # define isIDFIRST_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, IDFIRST)
13306 #ifndef isLOWER_utf8_safe
13307 # define isLOWER_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, LOWER)
13310 #ifndef isPRINT_utf8_safe
13311 # define isPRINT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, PRINT)
13314 # undef isPSXSPC_utf8_safe /* Use the modern definition */
13315 #ifndef isPSXSPC_utf8_safe
13316 # define isPSXSPC_utf8_safe(s,e) isSPACE_utf8_safe(s,e)
13318 #ifndef isPUNCT_utf8_safe
13319 # define isPUNCT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, PUNCT)
13322 #ifndef isSPACE_utf8_safe
13323 # define isSPACE_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, SPACE)
13326 #ifndef isUPPER_utf8_safe
13327 # define isUPPER_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, UPPER)
13330 # ifdef isWORDCHAR_utf8
13331 #ifndef isWORDCHAR_utf8_safe
13332 # define isWORDCHAR_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, WORDCHAR)
13336 #ifndef isWORDCHAR_utf8_safe
13337 # define isWORDCHAR_utf8_safe(s,e) \
13338 (isALPHANUMERIC_utf8_safe(s,e) || (*(s)) == '_')
13343 /* This was broken before 5.12, and just use this instead of worrying about
13344 * which releases the official works on */
13346 #ifndef isXDIGIT_utf8_safe
13347 # define isXDIGIT_utf8_safe(s,e) \
13348 ( ( LIKELY((e) > (s)) ) ? \
13349 ( ( inRANGE(((const U8*)s)[0], 0x30, 0x39 ) || inRANGE(((const U8*)s)[0], 0x41, 0x46 ) || inRANGE(((const U8*)s)[0], 0x61, 0x66 ) ) ? 1\
13350 : ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xEF == ((const U8*)s)[0] ) ) ? ( ( 0xBC == ((const U8*)s)[1] ) ?\
13351 ( ( inRANGE(((const U8*)s)[2], 0x90, 0x99 ) || inRANGE(((const U8*)s)[2], 0xA1, 0xA6 ) ) ? 3 : 0 )\
13352 : ( ( 0xBD == ((const U8*)s)[1] ) && ( inRANGE(((const U8*)s)[2], 0x81, 0x86 ) ) ) ? 3 : 0 ) : 0 )\
13356 # elif 'A' == 193 && '^' == 95 /* EBCDIC 1047 */
13357 #ifndef isXDIGIT_utf8_safe
13358 # define isXDIGIT_utf8_safe(s,e) \
13359 ( ( LIKELY((e) > (s)) ) ? \
13360 ( ( inRANGE(((const U8*)s)[0], 0x81, 0x86 ) || inRANGE(((const U8*)s)[0], 0xC1, 0xC6 ) || inRANGE(((const U8*)s)[0], 0xF0, 0xF9 ) ) ? 1\
13361 : ( ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xDD == ((const U8*)s)[0] ) ) && ( 0x73 == ((const U8*)s)[1] ) ) ? ( ( 0x67 == ((const U8*)s)[2] ) ?\
13362 ( ( inRANGE(((const U8*)s)[3], 0x57, 0x59 ) || inRANGE(((const U8*)s)[3], 0x62, 0x68 ) ) ? 4 : 0 )\
13363 : ( ( inRANGE(((const U8*)s)[2], 0x68, 0x69 ) ) && ( inRANGE(((const U8*)s)[3], 0x42, 0x47 ) ) ) ? 4 : 0 ) : 0 )\
13367 # elif 'A' == 193 && '^' == 176 /* EBCDIC 037 */
13368 #ifndef isXDIGIT_utf8_safe
13369 # define isXDIGIT_utf8_safe(s,e) \
13370 ( ( LIKELY((e) > (s)) ) ? \
13371 ( ( inRANGE(((const U8*)s)[0], 0x81, 0x86 ) || inRANGE(((const U8*)s)[0], 0xC1, 0xC6 ) || inRANGE(((const U8*)s)[0], 0xF0, 0xF9 ) ) ? 1\
13372 : ( ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xDD == ((const U8*)s)[0] ) ) && ( 0x72 == ((const U8*)s)[1] ) ) ? ( ( 0x66 == ((const U8*)s)[2] ) ?\
13373 ( ( inRANGE(((const U8*)s)[3], 0x57, 0x59 ) || 0x5F == ((const U8*)s)[3] || inRANGE(((const U8*)s)[3], 0x62, 0x67 ) ) ? 4 : 0 )\
13374 : ( ( inRANGE(((const U8*)s)[2], 0x67, 0x68 ) ) && ( inRANGE(((const U8*)s)[3], 0x42, 0x47 ) ) ) ? 4 : 0 ) : 0 )\
13379 # error Unknown character set
13381 #ifndef isALPHA_LC_utf8_safe
13382 # define isALPHA_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, ALPHA)
13385 # ifdef isALPHANUMERIC_utf8
13386 #ifndef isALPHANUMERIC_LC_utf8_safe
13387 # define isALPHANUMERIC_LC_utf8_safe(s,e) \
13388 D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, ALPHANUMERIC)
13392 #ifndef isALPHANUMERIC_LC_utf8_safe
13393 # define isALPHANUMERIC_LC_utf8_safe(s,e) \
13394 (isALPHA_LC_utf8_safe(s,e) || isDIGIT_LC_utf8_safe(s,e))
13398 #ifndef isBLANK_LC_utf8_safe
13399 # define isBLANK_LC_utf8_safe(s,e) \
13400 D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, BLANK)
13403 #ifndef isCNTRL_LC_utf8_safe
13404 # define isCNTRL_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, CNTRL)
13407 #ifndef isDIGIT_LC_utf8_safe
13408 # define isDIGIT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, DIGIT)
13411 #ifndef isGRAPH_LC_utf8_safe
13412 # define isGRAPH_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, GRAPH)
13415 # ifdef isIDCONT_utf8
13416 #ifndef isIDCONT_LC_utf8_safe
13417 # define isIDCONT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, IDCONT)
13421 #ifndef isIDCONT_LC_utf8_safe
13422 # define isIDCONT_LC_utf8_safe(s,e) isWORDCHAR_LC_utf8_safe(s,e)
13426 #ifndef isIDFIRST_LC_utf8_safe
13427 # define isIDFIRST_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, IDFIRST)
13430 #ifndef isLOWER_LC_utf8_safe
13431 # define isLOWER_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, LOWER)
13434 #ifndef isPRINT_LC_utf8_safe
13435 # define isPRINT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, PRINT)
13438 # undef isPSXSPC_LC_utf8_safe /* Use the modern definition */
13439 #ifndef isPSXSPC_LC_utf8_safe
13440 # define isPSXSPC_LC_utf8_safe(s,e) isSPACE_LC_utf8_safe(s,e)
13442 #ifndef isPUNCT_LC_utf8_safe
13443 # define isPUNCT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, PUNCT)
13446 #ifndef isSPACE_LC_utf8_safe
13447 # define isSPACE_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, SPACE)
13450 #ifndef isUPPER_LC_utf8_safe
13451 # define isUPPER_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, UPPER)
13454 # ifdef isWORDCHAR_utf8
13455 #ifndef isWORDCHAR_LC_utf8_safe
13456 # define isWORDCHAR_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, WORDCHAR)
13460 #ifndef isWORDCHAR_LC_utf8_safe
13461 # define isWORDCHAR_LC_utf8_safe(s,e) \
13462 (isALPHANUMERIC_LC_utf8_safe(s,e) || (*(s)) == '_')
13466 #ifndef isXDIGIT_LC_utf8_safe
13467 # define isXDIGIT_LC_utf8_safe(s,e) \
13468 D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, XDIGIT)
13471 /* Warning: isALPHANUMERIC_utf8_safe, isALPHA_utf8_safe, isASCII_utf8_safe,
13472 * isBLANK_utf8_safe, isCNTRL_utf8_safe, isDIGIT_utf8_safe, isGRAPH_utf8_safe,
13473 * isIDCONT_utf8_safe, isIDFIRST_utf8_safe, isLOWER_utf8_safe,
13474 * isPRINT_utf8_safe, isPSXSPC_utf8_safe, isPUNCT_utf8_safe, isSPACE_utf8_safe,
13475 * isUPPER_utf8_safe, isWORDCHAR_utf8_safe, isWORDCHAR_utf8_safe,
13476 * isXDIGIT_utf8_safe,
13477 * isALPHANUMERIC_LC_utf8_safe, isALPHA_LC_utf8_safe, isASCII_LC_utf8_safe,
13478 * isBLANK_LC_utf8_safe, isCNTRL_LC_utf8_safe, isDIGIT_LC_utf8_safe,
13479 * isGRAPH_LC_utf8_safe, isIDCONT_LC_utf8_safe, isIDFIRST_LC_utf8_safe,
13480 * isLOWER_LC_utf8_safe, isPRINT_LC_utf8_safe, isPSXSPC_LC_utf8_safe,
13481 * isPUNCT_LC_utf8_safe, isSPACE_LC_utf8_safe, isUPPER_LC_utf8_safe,
13482 * isWORDCHAR_LC_utf8_safe, isWORDCHAR_LC_utf8_safe, isXDIGIT_LC_utf8_safe,
13483 * isALPHANUMERIC_uvchr, isALPHA_uvchr, isASCII_uvchr, isBLANK_uvchr,
13484 * isCNTRL_uvchr, isDIGIT_uvchr, isGRAPH_uvchr, isIDCONT_uvchr,
13485 * isIDFIRST_uvchr, isLOWER_uvchr, isPRINT_uvchr, isPSXSPC_uvchr,
13486 * isPUNCT_uvchr, isSPACE_uvchr, isUPPER_uvchr, isWORDCHAR_uvchr,
13487 * isWORDCHAR_uvchr, isXDIGIT_uvchr
13489 * The UTF-8 handling is buggy in early Perls, and this can give inaccurate
13490 * results for code points above 0xFF, until the implementation started
13491 * settling down in 5.12 and 5.14 */
13495 #define D_PPP_TOO_SHORT_MSG "Malformed UTF-8 character starting with:" \
13496 " \\x%02x (too short; %d bytes available, need" \
13498 /* Perls starting here had a new API which handled multi-character results */
13499 #if (PERL_BCDVERSION >= 0x5007003)
13500 #ifndef toLOWER_uvchr
13501 # define toLOWER_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_lower(NATIVE_TO_UNI(c), s, l))
13504 #ifndef toUPPER_uvchr
13505 # define toUPPER_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_upper(NATIVE_TO_UNI(c), s, l))
13508 #ifndef toTITLE_uvchr
13509 # define toTITLE_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_title(NATIVE_TO_UNI(c), s, l))
13512 #ifndef toFOLD_uvchr
13513 # define toFOLD_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_fold( NATIVE_TO_UNI(c), s, l))
13516 # if (PERL_BCDVERSION != 0x5015006) /* Just this version is broken */
13518 /* Prefer the macro to the function */
13519 # if defined toLOWER_utf8
13520 # define D_PPP_TO_LOWER_CALLEE(s,r,l) toLOWER_utf8(s,r,l)
13522 # define D_PPP_TO_LOWER_CALLEE(s,r,l) to_utf8_lower(s,r,l)
13524 # if defined toTITLE_utf8
13525 # define D_PPP_TO_TITLE_CALLEE(s,r,l) toTITLE_utf8(s,r,l)
13527 # define D_PPP_TO_TITLE_CALLEE(s,r,l) to_utf8_title(s,r,l)
13529 # if defined toUPPER_utf8
13530 # define D_PPP_TO_UPPER_CALLEE(s,r,l) toUPPER_utf8(s,r,l)
13532 # define D_PPP_TO_UPPER_CALLEE(s,r,l) to_utf8_upper(s,r,l)
13534 # if defined toFOLD_utf8
13535 # define D_PPP_TO_FOLD_CALLEE(s,r,l) toFOLD_utf8(s,r,l)
13537 # define D_PPP_TO_FOLD_CALLEE(s,r,l) to_utf8_fold(s,r,l)
13539 # else /* Below is 5.15.6, which failed to make the macros available
13540 # outside of core, so we have to use the 'Perl_' form. khw
13541 # decided it was easier to just handle this case than have to
13542 # document the exception, and make an exception in the tests below
13544 # define D_PPP_TO_LOWER_CALLEE(s,r,l) \
13545 Perl__to_utf8_lower_flags(aTHX_ s, r, l, 0, NULL)
13546 # define D_PPP_TO_TITLE_CALLEE(s,r,l) \
13547 Perl__to_utf8_title_flags(aTHX_ s, r, l, 0, NULL)
13548 # define D_PPP_TO_UPPER_CALLEE(s,r,l) \
13549 Perl__to_utf8_upper_flags(aTHX_ s, r, l, 0, NULL)
13550 # define D_PPP_TO_FOLD_CALLEE(s,r,l) \
13551 Perl__to_utf8_fold_flags(aTHX_ s, r, l, FOLD_FLAGS_FULL, NULL)
13554 /* The actual implementation of the backported macros. If too short, croak,
13555 * otherwise call the original that doesn't have an upper limit parameter */
13556 # define D_PPP_GENERIC_MULTI_ARG_TO(name, s, e,r,l) \
13557 (((((e) - (s)) <= 0) \
13558 /* We could just do nothing, but modern perls croak */ \
13559 ? (croak("Attempting case change on zero length string"), \
13560 0) /* So looks like it returns something, and will compile */ \
13561 : ((e) - (s)) < UTF8SKIP(s)) \
13562 ? (croak(D_PPP_TOO_SHORT_MSG, \
13563 s[0], (int) ((e) - (s)), (int) UTF8SKIP(s)), \
13565 : D_PPP_TO_ ## name ## _CALLEE(s,r,l))
13566 #ifndef toUPPER_utf8_safe
13567 # define toUPPER_utf8_safe(s,e,r,l) \
13568 D_PPP_GENERIC_MULTI_ARG_TO(UPPER,s,e,r,l)
13571 #ifndef toLOWER_utf8_safe
13572 # define toLOWER_utf8_safe(s,e,r,l) \
13573 D_PPP_GENERIC_MULTI_ARG_TO(LOWER,s,e,r,l)
13576 #ifndef toTITLE_utf8_safe
13577 # define toTITLE_utf8_safe(s,e,r,l) \
13578 D_PPP_GENERIC_MULTI_ARG_TO(TITLE,s,e,r,l)
13581 #ifndef toFOLD_utf8_safe
13582 # define toFOLD_utf8_safe(s,e,r,l) \
13583 D_PPP_GENERIC_MULTI_ARG_TO(FOLD,s,e,r,l)
13586 #elif (PERL_BCDVERSION >= 0x5006000)
13588 /* Here we have UTF-8 support, but using the original API where the case
13589 * changing functions merely returned the changed code point; hence they
13590 * couldn't handle multi-character results. */
13592 # ifdef uvchr_to_utf8
13593 # define D_PPP_UV_TO_UTF8 uvchr_to_utf8
13595 # define D_PPP_UV_TO_UTF8 uv_to_utf8
13598 /* Get the utf8 of the case changed value, and store its length; then have
13599 * to re-calculate the changed case value in order to return it */
13600 # define D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(name, c, s, l) \
13601 (*(l) = (D_PPP_UV_TO_UTF8(s, \
13602 UNI_TO_NATIVE(to_uni_ ## name(NATIVE_TO_UNI(c)))) - (s)), \
13603 UNI_TO_NATIVE(to_uni_ ## name(NATIVE_TO_UNI(c))))
13604 #ifndef toLOWER_uvchr
13605 # define toLOWER_uvchr(c, s, l) \
13606 D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(lower, c, s, l)
13609 #ifndef toUPPER_uvchr
13610 # define toUPPER_uvchr(c, s, l) \
13611 D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(upper, c, s, l)
13614 #ifndef toTITLE_uvchr
13615 # define toTITLE_uvchr(c, s, l) \
13616 D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(title, c, s, l)
13619 #ifndef toFOLD_uvchr
13620 # define toFOLD_uvchr(c, s, l) toLOWER_uvchr(c, s, l)
13623 # define D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(name, s, e, r, l) \
13624 (((((e) - (s)) <= 0) \
13625 ? (croak("Attempting case change on zero length string"), \
13626 0) /* So looks like it returns something, and will compile */ \
13627 : ((e) - (s)) < UTF8SKIP(s)) \
13628 ? (croak(D_PPP_TOO_SHORT_MSG, \
13629 s[0], (int) ((e) - (s)), (int) UTF8SKIP(s)), \
13631 /* Get the changed code point and store its UTF-8 */ \
13632 : D_PPP_UV_TO_UTF8(r, to_utf8_ ## name(s)), \
13633 /* Then store its length, and re-get code point for return */ \
13634 *(l) = UTF8SKIP(r), to_utf8_ ## name(r))
13636 /* Warning: toUPPER_utf8_safe, toLOWER_utf8_safe, toTITLE_utf8_safe,
13637 * toUPPER_uvchr, toLOWER_uvchr, toTITLE_uvchr
13638 The UTF-8 case changing operations had bugs before around 5.12 or 5.14;
13639 this backport does not correct them.
13641 In perls before 7.3, multi-character case changing is not implemented; this
13642 backport uses the simple case changes available in those perls. */
13643 #ifndef toUPPER_utf8_safe
13644 # define toUPPER_utf8_safe(s,e,r,l) \
13645 D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(upper, s, e, r, l)
13648 #ifndef toLOWER_utf8_safe
13649 # define toLOWER_utf8_safe(s,e,r,l) \
13650 D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(lower, s, e, r, l)
13653 #ifndef toTITLE_utf8_safe
13654 # define toTITLE_utf8_safe(s,e,r,l) \
13655 D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(title, s, e, r, l)
13658 /* Warning: toFOLD_utf8_safe, toFOLD_uvchr
13659 The UTF-8 case changing operations had bugs before around 5.12 or 5.14;
13660 this backport does not correct them.
13662 In perls before 7.3, case folding is not implemented; instead, this
13663 backport substitutes simple (not multi-character, which isn't available)
13664 lowercasing. This gives the correct result in most, but not all, instances
13666 #ifndef toFOLD_utf8_safe
13667 # define toFOLD_utf8_safe(s,e,r,l) toLOWER_utf8_safe(s,e,r,l)
13672 /* Until we figure out how to support this in older perls... */
13673 #if (PERL_BCDVERSION >= 0x5008000)
13675 # define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \
13676 SvUTF8(HeKEY_sv(he)) : \
13681 #ifndef C_ARRAY_LENGTH
13682 # define C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0]))
13685 #ifndef C_ARRAY_END
13686 # define C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a))
13689 # define LIKELY(x) (x)
13693 # define UNLIKELY(x) (x)
13696 #ifndef MUTABLE_PTR
13697 #if defined(PERL_USE_GCC_BRACE_GROUPS)
13698 # define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
13700 # define MUTABLE_PTR(p) ((void *) (p))
13704 # define MUTABLE_AV(p) ((AV *)MUTABLE_PTR(p))
13708 # define MUTABLE_CV(p) ((CV *)MUTABLE_PTR(p))
13712 # define MUTABLE_GV(p) ((GV *)MUTABLE_PTR(p))
13716 # define MUTABLE_HV(p) ((HV *)MUTABLE_PTR(p))
13720 # define MUTABLE_IO(p) ((IO *)MUTABLE_PTR(p))
13724 # define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p))
13727 #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf)
13728 #if defined(PERL_USE_GCC_BRACE_GROUPS)
13729 # define vnewSVpvf(pat, args) ({ SV *_sv = newSV(0); sv_vsetpvfn(_sv, (pat), strlen((pat)), (args), Null(SV**), 0, Null(bool*)); _sv; })
13731 # define vnewSVpvf(pat, args) ((PL_Sv = newSV(0)), sv_vsetpvfn(PL_Sv, (pat), strlen((pat)), (args), Null(SV**), 0, Null(bool*)), PL_Sv)
13735 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf)
13736 # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
13739 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf)
13740 # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
13743 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg)
13744 #if defined(NEED_sv_catpvf_mg)
13745 static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...);
13748 extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...);
13751 #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL)
13753 #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg)
13757 DPPP_(my_sv_catpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...)
13760 va_start(args, pat);
13761 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
13769 #ifdef PERL_IMPLICIT_CONTEXT
13770 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext)
13771 #if defined(NEED_sv_catpvf_mg_nocontext)
13772 static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * const sv, const char * const pat, ...);
13775 extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * const sv, const char * const pat, ...);
13778 #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL)
13780 #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
13781 #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
13785 DPPP_(my_sv_catpvf_mg_nocontext)(SV * const sv, const char * const pat, ...)
13789 va_start(args, pat);
13790 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
13799 /* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */
13800 #ifndef sv_catpvf_mg
13801 # ifdef PERL_IMPLICIT_CONTEXT
13802 # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
13804 # define sv_catpvf_mg Perl_sv_catpvf_mg
13808 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg)
13809 # define sv_vcatpvf_mg(sv, pat, args) \
13811 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
13816 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg)
13817 #if defined(NEED_sv_setpvf_mg)
13818 static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...);
13821 extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...);
13824 #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL)
13826 #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg)
13830 DPPP_(my_sv_setpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...)
13833 va_start(args, pat);
13834 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
13842 #ifdef PERL_IMPLICIT_CONTEXT
13843 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext)
13844 #if defined(NEED_sv_setpvf_mg_nocontext)
13845 static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * const sv, const char * const pat, ...);
13848 extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * const sv, const char * const pat, ...);
13851 #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL)
13853 #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
13854 #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
13858 DPPP_(my_sv_setpvf_mg_nocontext)(SV * const sv, const char * const pat, ...)
13862 va_start(args, pat);
13863 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
13872 /* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */
13873 #ifndef sv_setpvf_mg
13874 # ifdef PERL_IMPLICIT_CONTEXT
13875 # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
13877 # define sv_setpvf_mg Perl_sv_setpvf_mg
13881 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg)
13882 # define sv_vsetpvf_mg(sv, pat, args) \
13884 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
13889 /* Hint: sv_2pv_nolen
13890 * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen().
13892 #ifndef sv_2pv_nolen
13893 # define sv_2pv_nolen(sv) SvPV_nolen(sv)
13899 * Does not work in perl-5.6.1, ppport.h implements a version
13900 * borrowed from perl-5.7.3.
13903 #if (PERL_BCDVERSION < 0x5007000)
13905 # define sv_2pvbyte(sv, lp) (sv_utf8_downgrade((sv), 0), SvPV((sv), *(lp)))
13908 /* Hint: sv_2pvbyte
13909 * Use the SvPVbyte() macro instead of sv_2pvbyte().
13912 /* Replace sv_2pvbyte with SvPVbyte */
13916 #define SvPVbyte(sv, lp) \
13917 ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
13918 ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
13924 # define SvPVbyte SvPV
13925 # define sv_2pvbyte sv_2pv
13928 #ifndef sv_2pvbyte_nolen
13929 # define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv)
13933 * Always use the SvPV() macro instead of sv_pvn().
13936 /* Replace sv_pvn with SvPV */
13938 /* Hint: sv_pvn_force
13939 * Always use the SvPV_force() macro instead of sv_pvn_force().
13942 /* Replace sv_pvn_force with SvPV_force */
13944 /* If these are undefined, they're not handled by the core anyway */
13945 #ifndef SV_IMMEDIATE_UNREF
13946 # define SV_IMMEDIATE_UNREF 0
13950 # define SV_GMAGIC 0
13953 #ifndef SV_COW_DROP_PV
13954 # define SV_COW_DROP_PV 0
13957 #ifndef SV_UTF8_NO_ENCODING
13958 # define SV_UTF8_NO_ENCODING 0
13961 #ifndef SV_CONST_RETURN
13962 # define SV_CONST_RETURN 0
13965 #ifndef SV_MUTABLE_RETURN
13966 # define SV_MUTABLE_RETURN 0
13970 # define SV_SMAGIC 0
13973 #ifndef SV_HAS_TRAILING_NUL
13974 # define SV_HAS_TRAILING_NUL 0
13977 #ifndef SV_COW_SHARED_HASH_KEYS
13978 # define SV_COW_SHARED_HASH_KEYS 0
13981 #if defined(PERL_USE_GCC_BRACE_GROUPS)
13982 #ifndef sv_2pv_flags
13983 # define sv_2pv_flags(sv, lp, flags) ({ SV *_sv = (sv); const I32 _flags = (flags); STRLEN *_lp = lp; _lp = _lp ? : &PL_na; (!(_flags & SV_GMAGIC) && SvGMAGICAL(_sv)) ? ({ char *_pv; SvGMAGICAL_off(_sv); _pv = sv_2pv(_sv, _lp); SvGMAGICAL_on(_sv); _pv; }) : sv_2pv(_sv, _lp); })
13986 #ifndef sv_pvn_force_flags
13987 # define sv_pvn_force_flags(sv, lp, flags) ({ SV *_sv = (sv); const I32 _flags = (flags); STRLEN *_lp = lp; _lp = _lp ? : &PL_na; (!(_flags & SV_GMAGIC) && SvGMAGICAL(_sv)) ? ({ char *_pv; SvGMAGICAL_off(_sv); _pv = sv_pvn_force(_sv, _lp); SvGMAGICAL_on(_sv); _pv; }) : sv_pvn_force(_sv, _lp); })
13991 #ifndef sv_2pv_flags
13992 # define sv_2pv_flags(sv, lp, flags) ((PL_Sv = (sv)), (!((flags) & SV_GMAGIC) && SvGMAGICAL(PL_Sv)) ? (SvGMAGICAL_off(PL_Sv), (PL_Xpv = (XPV *)sv_2pv(PL_Sv, (lp) ? (lp) : &PL_na)), SvGMAGICAL_on(PL_Sv), (char *)PL_Xpv) : sv_2pv(PL_Sv, (lp) ? (lp) : &PL_na))
13995 #ifndef sv_pvn_force_flags
13996 # define sv_pvn_force_flags(sv, lp, flags) ((PL_Sv = (sv)), (!((flags) & SV_GMAGIC) && SvGMAGICAL(PL_Sv)) ? (SvGMAGICAL_off(PL_Sv), (PL_Xpv = (XPV *)sv_pvn_force(PL_Sv, (lp) ? (lp) : &PL_na)), SvGMAGICAL_on(PL_Sv), (char *)PL_Xpv) : sv_pvn_force(PL_Sv, (lp) ? (lp) : &PL_na))
14001 #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) )
14002 # define D_PPP_SVPV_NOLEN_LP_ARG &PL_na
14004 # define D_PPP_SVPV_NOLEN_LP_ARG 0
14007 # define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC)
14010 #ifndef SvPV_mutable
14011 # define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC)
14014 # define SvPV_flags(sv, lp, flags) \
14015 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
14016 ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags))
14018 #ifndef SvPV_flags_const
14019 # define SvPV_flags_const(sv, lp, flags) \
14020 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
14021 ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \
14022 (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN))
14024 #ifndef SvPV_flags_const_nolen
14025 # define SvPV_flags_const_nolen(sv, flags) \
14026 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
14027 ? SvPVX_const(sv) : \
14028 (const char*) sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN))
14030 #ifndef SvPV_flags_mutable
14031 # define SvPV_flags_mutable(sv, lp, flags) \
14032 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
14033 ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \
14034 sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
14037 # define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC)
14040 #ifndef SvPV_force_nolen
14041 # define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC)
14044 #ifndef SvPV_force_mutable
14045 # define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC)
14048 #ifndef SvPV_force_nomg
14049 # define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0)
14052 #ifndef SvPV_force_nomg_nolen
14053 # define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0)
14055 #ifndef SvPV_force_flags
14056 # define SvPV_force_flags(sv, lp, flags) \
14057 ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
14058 ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags))
14060 #ifndef SvPV_force_flags_nolen
14061 # define SvPV_force_flags_nolen(sv, flags) \
14062 ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
14063 ? SvPVX(sv) : sv_pvn_force_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, flags))
14065 #ifndef SvPV_force_flags_mutable
14066 # define SvPV_force_flags_mutable(sv, lp, flags) \
14067 ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
14068 ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \
14069 : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
14072 # define SvPV_nolen(sv) \
14073 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
14074 ? SvPVX(sv) : sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC))
14076 #ifndef SvPV_nolen_const
14077 # define SvPV_nolen_const(sv) \
14078 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
14079 ? SvPVX_const(sv) : sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN))
14082 # if defined(PERL_USE_GCC_BRACE_GROUPS)
14083 #ifndef SvPVx_nolen_const
14084 # define SvPVx_nolen_const(sv) ({SV *sV_ = (sv); SvPV_nolen_const(sV_); })
14088 #ifndef SvPVx_nolen_const
14089 # define SvPVx_nolen_const(sv) (PL_Sv = sv, SvPV_nolen_const(PL_Sv))
14094 # define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0)
14097 #ifndef SvPV_nomg_const
14098 # define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0)
14101 #ifndef SvPV_nomg_const_nolen
14102 # define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0)
14105 #ifndef SvPV_nomg_nolen
14106 # define SvPV_nomg_nolen(sv) ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
14107 ? SvPVX(sv) : sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, 0))
14110 # define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \
14111 SvPV_set((sv), (char *) saferealloc( \
14112 (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \
14116 # define SvPVCLEAR(sv) sv_setpvs((sv), "")
14119 # define WARN_ALL 0
14122 #ifndef WARN_CLOSURE
14123 # define WARN_CLOSURE 1
14126 #ifndef WARN_DEPRECATED
14127 # define WARN_DEPRECATED 2
14130 #ifndef WARN_EXITING
14131 # define WARN_EXITING 3
14135 # define WARN_GLOB 4
14142 #ifndef WARN_CLOSED
14143 # define WARN_CLOSED 6
14147 # define WARN_EXEC 7
14151 # define WARN_LAYER 8
14154 #ifndef WARN_NEWLINE
14155 # define WARN_NEWLINE 9
14159 # define WARN_PIPE 10
14162 #ifndef WARN_UNOPENED
14163 # define WARN_UNOPENED 11
14167 # define WARN_MISC 12
14170 #ifndef WARN_NUMERIC
14171 # define WARN_NUMERIC 13
14175 # define WARN_ONCE 14
14178 #ifndef WARN_OVERFLOW
14179 # define WARN_OVERFLOW 15
14183 # define WARN_PACK 16
14186 #ifndef WARN_PORTABLE
14187 # define WARN_PORTABLE 17
14190 #ifndef WARN_RECURSION
14191 # define WARN_RECURSION 18
14194 #ifndef WARN_REDEFINE
14195 # define WARN_REDEFINE 19
14198 #ifndef WARN_REGEXP
14199 # define WARN_REGEXP 20
14202 #ifndef WARN_SEVERE
14203 # define WARN_SEVERE 21
14206 #ifndef WARN_DEBUGGING
14207 # define WARN_DEBUGGING 22
14210 #ifndef WARN_INPLACE
14211 # define WARN_INPLACE 23
14214 #ifndef WARN_INTERNAL
14215 # define WARN_INTERNAL 24
14218 #ifndef WARN_MALLOC
14219 # define WARN_MALLOC 25
14222 #ifndef WARN_SIGNAL
14223 # define WARN_SIGNAL 26
14226 #ifndef WARN_SUBSTR
14227 # define WARN_SUBSTR 27
14230 #ifndef WARN_SYNTAX
14231 # define WARN_SYNTAX 28
14234 #ifndef WARN_AMBIGUOUS
14235 # define WARN_AMBIGUOUS 29
14238 #ifndef WARN_BAREWORD
14239 # define WARN_BAREWORD 30
14243 # define WARN_DIGIT 31
14246 #ifndef WARN_PARENTHESIS
14247 # define WARN_PARENTHESIS 32
14250 #ifndef WARN_PRECEDENCE
14251 # define WARN_PRECEDENCE 33
14254 #ifndef WARN_PRINTF
14255 # define WARN_PRINTF 34
14258 #ifndef WARN_PROTOTYPE
14259 # define WARN_PROTOTYPE 35
14263 # define WARN_QW 36
14266 #ifndef WARN_RESERVED
14267 # define WARN_RESERVED 37
14270 #ifndef WARN_SEMICOLON
14271 # define WARN_SEMICOLON 38
14275 # define WARN_TAINT 39
14278 #ifndef WARN_THREADS
14279 # define WARN_THREADS 40
14282 #ifndef WARN_UNINITIALIZED
14283 # define WARN_UNINITIALIZED 41
14286 #ifndef WARN_UNPACK
14287 # define WARN_UNPACK 42
14291 # define WARN_UNTIE 43
14295 # define WARN_UTF8 44
14299 # define WARN_VOID 45
14302 #ifndef WARN_ASSERTIONS
14303 # define WARN_ASSERTIONS 46
14306 # define packWARN(a) (a)
14310 # define packWARN2(a,b) (packWARN(a) << 8 | (b))
14314 # define packWARN3(a,b,c) (packWARN2(a,b) << 8 | (c))
14318 # define packWARN4(a,b,c,d) (packWARN3(a,b,c) << 8 | (d))
14323 # define ckWARN(a) (PL_dowarn & G_WARN_ON)
14325 # define ckWARN(a) PL_dowarn
14329 # define ckWARN2(a,b) (ckWARN(a) || ckWARN(b))
14333 # define ckWARN3(a,b,c) (ckWARN(c) || ckWARN2(a,b))
14337 # define ckWARN4(a,b,c,d) (ckWARN(d) || ckWARN3(a,b,c))
14341 # ifdef isLEXWARN_off
14342 # define ckWARN_d(a) (isLEXWARN_off || ckWARN(a))
14344 # define ckWARN_d(a) 1
14348 # define ckWARN2_d(a,b) (ckWARN_d(a) || ckWARN_d(b))
14352 # define ckWARN3_d(a,b,c) (ckWARN_d(c) || ckWARN2_d(a,b))
14356 # define ckWARN4_d(a,b,c,d) (ckWARN_d(d) || ckWARN3_d(a,b,c))
14359 # define vwarner(err, pat, argsp) \
14360 STMT_START { SV *sv; \
14361 PERL_UNUSED_ARG(err); \
14362 sv = vnewSVpvf(pat, argsp); \
14364 warn("%s", SvPV_nolen(sv)); \
14368 #if (PERL_BCDVERSION >= 0x5004000) && !defined(warner)
14369 # if defined(NEED_warner)
14370 static void DPPP_(my_warner)(U32 err, const char * pat, ...);
14373 extern void DPPP_(my_warner)(U32 err, const char * pat, ...);
14376 #if defined(NEED_warner) || defined(NEED_warner_GLOBAL)
14378 #define Perl_warner DPPP_(my_warner)
14382 DPPP_(my_warner)(U32 err, const char *pat, ...)
14385 va_start(args, pat);
14386 vwarner(err, pat, &args);
14390 # define warner Perl_warner
14392 # define Perl_warner_nocontext Perl_warner
14397 #if (PERL_BCDVERSION >= 0x5004000) && !defined(ck_warner)
14398 # if defined(NEED_ck_warner)
14399 static void DPPP_(my_ck_warner)(pTHX_ U32 err, const char * pat, ...);
14402 extern void DPPP_(my_ck_warner)(pTHX_ U32 err, const char * pat, ...);
14405 #if defined(NEED_ck_warner) || defined(NEED_ck_warner_GLOBAL)
14407 #define Perl_ck_warner DPPP_(my_ck_warner)
14411 DPPP_(my_ck_warner)(pTHX_ U32 err, const char *pat, ...)
14415 if ( ! ckWARN((err ) & 0xFF)
14416 && ! ckWARN((err >> 8) & 0xFF)
14417 && ! ckWARN((err >> 16) & 0xFF)
14418 && ! ckWARN((err >> 24) & 0xFF))
14423 va_start(args, pat);
14424 vwarner(err, pat, &args);
14428 # define ck_warner Perl_ck_warner
14432 #if (PERL_BCDVERSION >= 0x5004000) && !defined(ck_warner_d)
14433 # if defined(NEED_ck_warner_d)
14434 static void DPPP_(my_ck_warner_d)(pTHX_ U32 err, const char * pat, ...);
14437 extern void DPPP_(my_ck_warner_d)(pTHX_ U32 err, const char * pat, ...);
14440 #if defined(NEED_ck_warner_d) || defined(NEED_ck_warner_d_GLOBAL)
14442 #define Perl_ck_warner_d DPPP_(my_ck_warner_d)
14446 DPPP_(my_ck_warner_d)(pTHX_ U32 err, const char *pat, ...)
14450 if ( ! ckWARN_d((err ) & 0xFF)
14451 && ! ckWARN_d((err >> 8) & 0xFF)
14452 && ! ckWARN_d((err >> 16) & 0xFF)
14453 && ! ckWARN_d((err >> 24) & 0xFF))
14458 va_start(args, pat);
14459 vwarner(err, pat, &args);
14463 # define ck_warner_d Perl_ck_warner_d
14470 # if IVSIZE == LONGSIZE
14476 # elif IVSIZE == INTSIZE
14483 # error "cannot define IV/UV formats"
14488 # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
14489 defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000)
14490 /* Not very likely, but let's try anyway. */
14491 # define NVef PERL_PRIeldbl
14492 # define NVff PERL_PRIfldbl
14493 # define NVgf PERL_PRIgldbl
14501 # define sv_setuv(sv, uv) \
14504 if (TeMpUv <= IV_MAX) \
14505 sv_setiv(sv, TeMpUv); \
14507 sv_setnv(sv, (double)TeMpUv); \
14511 # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv))
14514 #if defined(PERL_USE_GCC_BRACE_GROUPS)
14516 # define sv_2uv(sv) ({ SV *_sv = (sv); (UV) (SvNOK(_sv) ? SvNV(_sv) : sv_2nv(_sv)); })
14521 # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv)))
14526 # define SvUVX(sv) ((UV)SvIVX(sv))
14530 # define SvUVXx(sv) SvUVX(sv)
14534 # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
14537 #if defined(PERL_USE_GCC_BRACE_GROUPS)
14539 # define SvUVx(sv) ({ SV *_sv = (sv)); SvUV(_sv); })
14544 # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
14550 * Always use the SvUVx() macro instead of sv_uv().
14552 /* Replace sv_uv with SvUVx */
14554 # define sv_uv(sv) SvUVx(sv)
14557 #if !defined(SvUOK) && defined(SvIOK_UV)
14558 # define SvUOK(sv) SvIOK_UV(sv)
14561 # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
14564 #ifndef XSRETURN_UV
14565 # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
14568 # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
14572 # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
14575 #if !defined(my_strnlen)
14576 #if defined(NEED_my_strnlen)
14577 static Size_t DPPP_(my_my_strnlen)(const char * str, Size_t maxlen);
14580 extern Size_t DPPP_(my_my_strnlen)(const char * str, Size_t maxlen);
14583 #if defined(NEED_my_strnlen) || defined(NEED_my_strnlen_GLOBAL)
14585 #define my_strnlen DPPP_(my_my_strnlen)
14586 #define Perl_my_strnlen DPPP_(my_my_strnlen)
14590 DPPP_(my_my_strnlen)(const char *str, Size_t maxlen)
14592 const char *p = str;
14594 while(maxlen-- && *p)
14605 # define memNE(s1,s2,l) (memcmp(s1,s2,l))
14609 # define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
14614 # define memNE(s1,s2,l) (bcmp(s1,s2,l))
14618 # define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
14623 # define memEQs(s1, l, s2) \
14624 (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1)))
14628 # define memNEs(s1, l, s2) !memEQs(s1, l, s2)
14631 # define memCHRs(s, c) ((const char *) memchr("" s "" , c, sizeof(s)-1))
14634 # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
14638 # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
14643 # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t))
14648 # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d)
14653 # define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t))
14657 # define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB)
14661 # define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF)
14665 # define Poison(d,n,t) PoisonFree(d,n,t)
14668 # define Newx(v,n,t) New(0,v,n,t)
14672 # define Newxc(v,n,t,c) Newc(0,v,n,t,c)
14676 # define Newxz(v,n,t) Newz(0,v,n,t)
14679 #ifdef NEED_mess_sv
14684 #define NEED_mess_nocontext
14689 #if (PERL_BCDVERSION >= 0x5007003) || ( (PERL_BCDVERSION >= 0x5006001) && (PERL_BCDVERSION < 0x5007000) )
14690 # if ( (PERL_BCDVERSION >= 0x5008000) && (PERL_BCDVERSION < 0x5008009) ) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5010001) )
14691 # define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) \
14693 SV *_errsv = ERRSV; \
14694 SvFLAGS(_errsv) = (SvFLAGS(_errsv) & ~SVf_UTF8) | \
14695 (SvFLAGS(sv) & SVf_UTF8); \
14698 # define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) STMT_START {} STMT_END
14700 # define croak_sv(sv) \
14703 if (SvROK(_sv)) { \
14704 sv_setsv(ERRSV, _sv); \
14707 D_PPP_FIX_UTF8_ERRSV_FOR_SV(_sv); \
14708 croak("%" SVf, SVfARG(_sv)); \
14711 #elif (PERL_BCDVERSION >= 0x5004000)
14712 # define croak_sv(sv) croak("%" SVf, SVfARG(sv))
14714 # define croak_sv(sv) croak("%s", SvPV_nolen(sv))
14719 #if defined(NEED_die_sv)
14720 static OP * DPPP_(my_die_sv)(pTHX_ SV * baseex);
14723 extern OP * DPPP_(my_die_sv)(pTHX_ SV * baseex);
14726 #if defined(NEED_die_sv) || defined(NEED_die_sv_GLOBAL)
14731 #define die_sv(a) DPPP_(my_die_sv)(aTHX_ a)
14732 #define Perl_die_sv DPPP_(my_die_sv)
14735 DPPP_(my_die_sv)(pTHX_ SV *baseex)
14744 #if (PERL_BCDVERSION >= 0x5004000)
14745 # define warn_sv(sv) warn("%" SVf, SVfARG(sv))
14747 # define warn_sv(sv) warn("%s", SvPV_nolen(sv))
14751 #if ! defined vmess && (PERL_BCDVERSION >= 0x5004000)
14752 # if defined(NEED_vmess)
14753 static SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args);
14756 extern SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args);
14759 #if defined(NEED_vmess) || defined(NEED_vmess_GLOBAL)
14764 #define vmess(a,b) DPPP_(my_vmess)(aTHX_ a,b)
14765 #define Perl_vmess DPPP_(my_vmess)
14769 DPPP_(my_vmess)(pTHX_ const char* pat, va_list* args)
14777 #if (PERL_BCDVERSION < 0x5006000) && (PERL_BCDVERSION >= 0x5004000)
14781 #if !defined(mess_nocontext) && !defined(Perl_mess_nocontext) && (PERL_BCDVERSION >= 0x5004000)
14782 #if defined(NEED_mess_nocontext)
14783 static SV * DPPP_(my_mess_nocontext)(const char * pat, ...);
14786 extern SV * DPPP_(my_mess_nocontext)(const char * pat, ...);
14789 #if defined(NEED_mess_nocontext) || defined(NEED_mess_nocontext_GLOBAL)
14791 #define mess_nocontext DPPP_(my_mess_nocontext)
14792 #define Perl_mess_nocontext DPPP_(my_mess_nocontext)
14795 DPPP_(my_mess_nocontext)(const char* pat, ...)
14800 va_start(args, pat);
14801 sv = vmess(pat, &args);
14809 #if defined(NEED_mess)
14810 static SV * DPPP_(my_mess)(pTHX_ const char * pat, ...);
14813 extern SV * DPPP_(my_mess)(pTHX_ const char * pat, ...);
14816 #if defined(NEED_mess) || defined(NEED_mess_GLOBAL)
14818 #define Perl_mess DPPP_(my_mess)
14821 DPPP_(my_mess)(pTHX_ const char* pat, ...)
14825 va_start(args, pat);
14826 sv = vmess(pat, &args);
14830 #ifdef mess_nocontext
14831 #define mess mess_nocontext
14833 #define mess Perl_mess_nocontext
14838 #if ! defined mess_sv && (PERL_BCDVERSION >= 0x5004000)
14839 #if defined(NEED_mess_sv)
14840 static SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume);
14843 extern SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume);
14846 #if defined(NEED_mess_sv) || defined(NEED_mess_sv_GLOBAL)
14851 #define mess_sv(a,b) DPPP_(my_mess_sv)(aTHX_ a,b)
14852 #define Perl_mess_sv DPPP_(my_mess_sv)
14855 DPPP_(my_mess_sv)(pTHX_ SV *basemsg, bool consume)
14860 if (SvPOK(basemsg) && SvCUR(basemsg) && *(SvEND(basemsg)-1) == '\n') {
14864 SvSetSV_nosteal(ret, basemsg);
14869 sv_catsv(basemsg, mess(""));
14874 tmp = newSVsv(ret);
14875 SvSetSV_nosteal(ret, basemsg);
14876 sv_catsv(ret, tmp);
14883 #ifndef warn_nocontext
14884 #define warn_nocontext warn
14887 #ifndef croak_nocontext
14888 #define croak_nocontext croak
14891 #ifndef croak_no_modify
14892 #define croak_no_modify() croak_nocontext("%s", PL_no_modify)
14893 #define Perl_croak_no_modify() croak_no_modify()
14896 #ifndef croak_memory_wrap
14897 #if (PERL_BCDVERSION >= 0x5009002) || ( (PERL_BCDVERSION >= 0x5008006) && (PERL_BCDVERSION < 0x5009000) )
14898 # define croak_memory_wrap() croak_nocontext("%s", PL_memory_wrap)
14900 # define croak_memory_wrap() croak_nocontext("panic: memory wrap")
14904 #ifndef croak_xs_usage
14905 #if defined(NEED_croak_xs_usage)
14906 static void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params);
14909 extern void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params);
14912 #if defined(NEED_croak_xs_usage) || defined(NEED_croak_xs_usage_GLOBAL)
14914 #define croak_xs_usage DPPP_(my_croak_xs_usage)
14915 #define Perl_croak_xs_usage DPPP_(my_croak_xs_usage)
14917 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
14918 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
14921 DPPP_(my_croak_xs_usage)(const CV *const cv, const char *const params)
14924 const GV *const gv = CvGV(cv);
14926 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
14929 const char *const gvname = GvNAME(gv);
14930 const HV *const stash = GvSTASH(gv);
14931 const char *const hvname = stash ? HvNAME(stash) : NULL;
14934 croak("Usage: %s::%s(%s)", hvname, gvname, params);
14936 croak("Usage: %s(%s)", gvname, params);
14938 /* Pants. I don't think that it should be possible to get here. */
14939 croak("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
14946 # define mPUSHs(s) PUSHs(sv_2mortal(s))
14950 # define PUSHmortal PUSHs(sv_newmortal())
14954 # define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l))
14958 # define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n))
14962 # define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i))
14966 # define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u))
14969 # define mXPUSHs(s) XPUSHs(sv_2mortal(s))
14972 #ifndef XPUSHmortal
14973 # define XPUSHmortal XPUSHs(sv_newmortal())
14977 # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END
14981 # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END
14985 # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END
14989 # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END
14994 # define call_sv perl_call_sv
14998 # define call_pv perl_call_pv
15002 # define call_argv perl_call_argv
15005 #ifndef call_method
15006 # define call_method perl_call_method
15010 # define eval_sv perl_eval_sv
15013 #if (PERL_BCDVERSION >= 0x5003098) && (PERL_BCDVERSION < 0x5006000)
15015 # define eval_pv perl_eval_pv
15021 #if (PERL_BCDVERSION < 0x5006000)
15022 #ifndef Perl_eval_sv
15023 # define Perl_eval_sv perl_eval_sv
15026 #if (PERL_BCDVERSION >= 0x5003098)
15027 #ifndef Perl_eval_pv
15028 # define Perl_eval_pv perl_eval_pv
15034 # define G_LIST G_ARRAY /* Replace */
15036 #ifndef PERL_LOADMOD_DENY
15037 # define PERL_LOADMOD_DENY 0x1
15040 #ifndef PERL_LOADMOD_NOIMPORT
15041 # define PERL_LOADMOD_NOIMPORT 0x2
15044 #ifndef PERL_LOADMOD_IMPORT_OPS
15045 # define PERL_LOADMOD_IMPORT_OPS 0x4
15048 #if defined(PERL_USE_GCC_BRACE_GROUPS)
15049 # define D_PPP_CROAK_IF_ERROR(cond) ({ SV *_errsv; ((cond) && (_errsv = ERRSV) && (SvROK(_errsv) || SvTRUE(_errsv)) && (croak_sv(_errsv), 1)); })
15051 # define D_PPP_CROAK_IF_ERROR(cond) ((cond) && (SvROK(ERRSV) || SvTRUE(ERRSV)) && (croak_sv(ERRSV), 1))
15055 # define G_METHOD 64
15059 # if (PERL_BCDVERSION < 0x5006000)
15060 # define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \
15061 (flags) & ~G_METHOD) : perl_call_sv(sv, flags))
15063 # define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \
15064 (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags))
15069 # define G_RETHROW 8192
15073 # if defined(PERL_USE_GCC_BRACE_GROUPS)
15074 # define eval_sv(sv, flags) ({ I32 _flags = (flags); I32 _ret = Perl_eval_sv(aTHX_ sv, (_flags & ~G_RETHROW)); D_PPP_CROAK_IF_ERROR(_flags & G_RETHROW); _ret; })
15076 # define eval_sv(sv, flags) ((PL_na = Perl_eval_sv(aTHX_ sv, ((flags) & ~G_RETHROW))), D_PPP_CROAK_IF_ERROR((flags) & G_RETHROW), (I32)PL_na)
15081 * This implementation of eval_pv fails on compilers that don't allow
15082 * statements nested within expressions. However, we don't care about the bug
15083 * it's trying to fix, because we only call eval_pv with croak_on_error=0.
15084 * So, pending an upstream fix for this, just remove it.
15087 /* Older Perl versions have broken croak_on_error=1 */
15088 #if (PERL_BCDVERSION < 0x5031002)
15091 # if defined(PERL_USE_GCC_BRACE_GROUPS)
15092 # define eval_pv(p, croak_on_error) ({ SV *_sv = Perl_eval_pv(aTHX_ p, 0); D_PPP_CROAK_IF_ERROR(croak_on_error); _sv; })
15094 # define eval_pv(p, croak_on_error) ((PL_Sv = Perl_eval_pv(aTHX_ p, 0)), D_PPP_CROAK_IF_ERROR(croak_on_error), PL_Sv)
15098 #endif /* NOT_USED */
15100 /* This is backport for Perl 5.3.97d and older which do not provide perl_eval_pv */
15102 #if defined(NEED_eval_pv)
15103 static SV * DPPP_(my_eval_pv)(const char * p, I32 croak_on_error);
15106 extern SV * DPPP_(my_eval_pv)(const char * p, I32 croak_on_error);
15109 #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL)
15114 #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b)
15115 #define Perl_eval_pv DPPP_(my_eval_pv)
15119 DPPP_(my_eval_pv)(const char *p, I32 croak_on_error)
15122 SV* sv = newSVpv(p, 0);
15125 eval_sv(sv, G_SCALAR);
15132 D_PPP_CROAK_IF_ERROR(croak_on_error);
15140 #if ! defined(vload_module) && defined(start_subparse)
15141 #if defined(NEED_vload_module)
15142 static void DPPP_(my_vload_module)(U32 flags, SV * name, SV * ver, va_list * args);
15145 extern void DPPP_(my_vload_module)(U32 flags, SV * name, SV * ver, va_list * args);
15148 #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL)
15150 #ifdef vload_module
15151 # undef vload_module
15153 #define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d)
15154 #define Perl_vload_module DPPP_(my_vload_module)
15158 DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args)
15164 OP * const modname = newSVOP(OP_CONST, 0, name);
15165 /* 5.005 has a somewhat hacky force_normal that doesn't croak on
15166 SvREADONLY() if PL_compiling is true. Current perls take care in
15167 ck_require() to correctly turn off SvREADONLY before calling
15168 force_normal_flags(). This seems a better fix than fudging PL_compiling
15170 SvREADONLY_off(((SVOP*)modname)->op_sv);
15171 modname->op_private |= OPpCONST_BARE;
15173 veop = newSVOP(OP_CONST, 0, ver);
15177 if (flags & PERL_LOADMOD_NOIMPORT) {
15178 imop = sawparens(newNULLLIST());
15180 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
15181 imop = va_arg(*args, OP*);
15186 sv = va_arg(*args, SV*);
15188 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
15189 sv = va_arg(*args, SV*);
15193 const line_t ocopline = PL_copline;
15194 COP * const ocurcop = PL_curcop;
15195 const int oexpect = PL_expect;
15197 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
15198 #if (PERL_BCDVERSION > 0x5003000)
15202 PL_expect = oexpect;
15203 PL_copline = ocopline;
15204 PL_curcop = ocurcop;
15211 #ifndef load_module
15212 #if defined(NEED_load_module)
15213 static void DPPP_(my_load_module)(U32 flags, SV * name, SV * ver, ...);
15216 extern void DPPP_(my_load_module)(U32 flags, SV * name, SV * ver, ...);
15219 #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL)
15222 # undef load_module
15224 #define load_module DPPP_(my_load_module)
15225 #define Perl_load_module DPPP_(my_load_module)
15229 DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...)
15232 va_start(args, ver);
15233 vload_module(flags, name, ver, &args);
15240 # define newRV_inc(sv) newRV(sv) /* Replace */
15243 #ifndef newRV_noinc
15244 #if defined(PERL_USE_GCC_BRACE_GROUPS)
15245 # define newRV_noinc(sv) ({ SV *_sv = (SV *)newRV((sv)); SvREFCNT_dec((sv)); _sv; })
15247 # define newRV_noinc(sv) ((PL_Sv = (SV *)newRV((sv))), SvREFCNT_dec((sv)), PL_Sv)
15252 * Boilerplate macros for initializing and accessing interpreter-local
15253 * data from C. All statics in extensions should be reworked to use
15254 * this, if you want to make the extension thread-safe. See ext/re/re.xs
15255 * for an example of the use of these macros.
15257 * Code that uses these macros is responsible for the following:
15258 * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
15259 * 2. Declare a typedef named my_cxt_t that is a structure that contains
15260 * all the data that needs to be interpreter-local.
15261 * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
15262 * 4. Use the MY_CXT_INIT macro such that it is called exactly once
15263 * (typically put in the BOOT: section).
15264 * 5. Use the members of the my_cxt_t structure everywhere as
15266 * 6. Use the dMY_CXT macro (a declaration) in all the functions that
15270 #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
15271 defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
15273 #ifndef START_MY_CXT
15275 /* This must appear in all extensions that define a my_cxt_t structure,
15276 * right after the definition (i.e. at file scope). The non-threads
15277 * case below uses it to declare the data as static. */
15278 #define START_MY_CXT
15280 #if (PERL_BCDVERSION < 0x5004068)
15281 /* Fetches the SV that keeps the per-interpreter data. */
15282 #define dMY_CXT_SV \
15283 SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE)
15284 #else /* >= perl5.004_68 */
15285 #define dMY_CXT_SV \
15286 SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
15287 sizeof(MY_CXT_KEY)-1, TRUE)
15288 #endif /* < perl5.004_68 */
15290 /* This declaration should be used within all functions that use the
15291 * interpreter-local data. */
15294 my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
15296 /* Creates and zeroes the per-interpreter data.
15297 * (We allocate my_cxtp in a Perl SV so that it will be released when
15298 * the interpreter goes away.) */
15299 #define MY_CXT_INIT \
15301 /* newSV() allocates one more than needed */ \
15302 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
15303 Zero(my_cxtp, 1, my_cxt_t); \
15304 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
15306 /* This macro must be used to access members of the my_cxt_t structure.
15307 * e.g. MYCXT.some_data */
15308 #define MY_CXT (*my_cxtp)
15310 /* Judicious use of these macros can reduce the number of times dMY_CXT
15311 * is used. Use is similar to pTHX, aTHX etc. */
15312 #define pMY_CXT my_cxt_t *my_cxtp
15313 #define pMY_CXT_ pMY_CXT,
15314 #define _pMY_CXT ,pMY_CXT
15315 #define aMY_CXT my_cxtp
15316 #define aMY_CXT_ aMY_CXT,
15317 #define _aMY_CXT ,aMY_CXT
15319 #endif /* START_MY_CXT */
15321 #ifndef MY_CXT_CLONE
15322 /* Clones the per-interpreter data. */
15323 #define MY_CXT_CLONE \
15325 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
15326 Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
15327 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
15330 #else /* single interpreter */
15332 #ifndef START_MY_CXT
15334 #define START_MY_CXT static my_cxt_t my_cxt;
15335 #define dMY_CXT_SV dNOOP
15336 #define dMY_CXT dNOOP
15337 #define MY_CXT_INIT NOOP
15338 #define MY_CXT my_cxt
15340 #define pMY_CXT void
15347 #endif /* START_MY_CXT */
15349 #ifndef MY_CXT_CLONE
15350 #define MY_CXT_CLONE NOOP
15355 #ifndef SvREFCNT_inc
15356 # ifdef PERL_USE_GCC_BRACE_GROUPS
15357 # define SvREFCNT_inc(sv) \
15359 SV * const _sv = (SV*)(sv); \
15361 (SvREFCNT(_sv))++; \
15365 # define SvREFCNT_inc(sv) \
15366 ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL)
15370 #ifndef SvREFCNT_inc_simple
15371 # ifdef PERL_USE_GCC_BRACE_GROUPS
15372 # define SvREFCNT_inc_simple(sv) \
15375 (SvREFCNT(sv))++; \
15379 # define SvREFCNT_inc_simple(sv) \
15380 ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL)
15384 #ifndef SvREFCNT_inc_NN
15385 # ifdef PERL_USE_GCC_BRACE_GROUPS
15386 # define SvREFCNT_inc_NN(sv) \
15388 SV * const _sv = (SV*)(sv); \
15393 # define SvREFCNT_inc_NN(sv) \
15394 (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv)
15398 #ifndef SvREFCNT_inc_void
15399 # ifdef PERL_USE_GCC_BRACE_GROUPS
15400 # define SvREFCNT_inc_void(sv) \
15402 SV * const _sv = (SV*)(sv); \
15404 (void)(SvREFCNT(_sv)++); \
15407 # define SvREFCNT_inc_void(sv) \
15408 (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0)
15411 #ifndef SvREFCNT_inc_simple_void
15412 # define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END
15415 #ifndef SvREFCNT_inc_simple_NN
15416 # define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv))
15419 #ifndef SvREFCNT_inc_void_NN
15420 # define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv)))
15423 #ifndef SvREFCNT_inc_simple_void_NN
15424 # define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv)))
15428 #if defined(PERL_USE_GCC_BRACE_GROUPS)
15429 # define newSV_type(t) ({ SV *_sv = newSV(0); sv_upgrade(_sv, (t)); _sv; })
15431 # define newSV_type(t) ((PL_Sv = newSV(0)), sv_upgrade(PL_Sv, (t)), PL_Sv)
15435 #if (PERL_BCDVERSION < 0x5006000)
15436 # define D_PPP_CONSTPV_ARG(x) ((char *) (x))
15438 # define D_PPP_CONSTPV_ARG(x) (x)
15441 # define newSVpvn(data,len) ((data) \
15442 ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
15445 #ifndef newSVpvn_utf8
15446 # define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
15449 # define SVf_UTF8 0
15452 #ifndef newSVpvn_flags
15453 #if defined(PERL_USE_GCC_BRACE_GROUPS)
15454 # define newSVpvn_flags(s, len, flags) ({ SV *_sv = newSVpvn(D_PPP_CONSTPV_ARG((s)), (len)); SvFLAGS(_sv) |= ((flags) & SVf_UTF8); ((flags) & SVs_TEMP) ? sv_2mortal(_sv) : _sv; })
15456 # define newSVpvn_flags(s, len, flags) ((PL_Sv = newSVpvn(D_PPP_CONSTPV_ARG((s)), (len))), SvFLAGS(PL_Sv) |= ((flags) & SVf_UTF8), (((flags) & SVs_TEMP) ? sv_2mortal(PL_Sv) : PL_Sv))
15460 # define SV_NOSTEAL 16
15463 #if ( (PERL_BCDVERSION >= 0x5007003) && (PERL_BCDVERSION < 0x5008007) ) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009002) )
15464 #undef sv_setsv_flags
15465 #if defined(PERL_USE_GCC_BRACE_GROUPS)
15466 #define sv_setsv_flags(dstr, sstr, flags) \
15468 if (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) { \
15469 SvTEMP_off((SV *)(sstr)); \
15470 Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL); \
15471 SvTEMP_on((SV *)(sstr)); \
15473 Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL); \
15478 (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) ? ( \
15479 SvTEMP_off((SV *)(sstr)), \
15480 Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL), \
15481 SvTEMP_on((SV *)(sstr)), \
15484 Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL), \
15491 #if defined(PERL_USE_GCC_BRACE_GROUPS)
15492 #ifndef sv_setsv_flags
15493 # define sv_setsv_flags(dstr, sstr, flags) \
15495 if (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) { \
15496 SvTEMP_off((SV *)(sstr)); \
15497 if (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) { \
15498 SvGMAGICAL_off((SV *)(sstr)); \
15499 sv_setsv((dstr), (sstr)); \
15500 SvGMAGICAL_on((SV *)(sstr)); \
15502 sv_setsv((dstr), (sstr)); \
15504 SvTEMP_on((SV *)(sstr)); \
15506 if (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) { \
15507 SvGMAGICAL_off((SV *)(sstr)); \
15508 sv_setsv((dstr), (sstr)); \
15509 SvGMAGICAL_on((SV *)(sstr)); \
15511 sv_setsv((dstr), (sstr)); \
15518 #ifndef sv_setsv_flags
15519 # define sv_setsv_flags(dstr, sstr, flags) \
15521 (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) ? ( \
15522 SvTEMP_off((SV *)(sstr)), \
15523 (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) ? ( \
15524 SvGMAGICAL_off((SV *)(sstr)), \
15525 sv_setsv((dstr), (sstr)), \
15526 SvGMAGICAL_on((SV *)(sstr)), \
15529 sv_setsv((dstr), (sstr)), \
15532 SvTEMP_on((SV *)(sstr)), \
15535 (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) ? ( \
15536 SvGMAGICAL_off((SV *)(sstr)), \
15537 sv_setsv((dstr), (sstr)), \
15538 SvGMAGICAL_on((SV *)(sstr)), \
15541 sv_setsv((dstr), (sstr)), \
15550 #if defined(PERL_USE_GCC_BRACE_GROUPS)
15551 #ifndef newSVsv_flags
15552 # define newSVsv_flags(sv, flags) ({ SV *_sv = newSV(0); sv_setsv_flags(_sv, (sv), (flags)); _sv; })
15556 #ifndef newSVsv_flags
15557 # define newSVsv_flags(sv, flags) ((PL_Sv = newSV(0)), sv_setsv_flags(PL_Sv, (sv), (flags)), PL_Sv)
15561 #ifndef newSVsv_nomg
15562 # define newSVsv_nomg(sv) newSVsv_flags((sv), SV_NOSTEAL)
15565 #if (PERL_BCDVERSION >= 0x5017005)
15566 #ifndef sv_mortalcopy_flags
15567 # define sv_mortalcopy_flags(sv, flags) Perl_sv_mortalcopy_flags(aTHX_ (sv), (flags))
15571 #ifndef sv_mortalcopy_flags
15572 # define sv_mortalcopy_flags(sv, flags) sv_2mortal(newSVsv_flags((sv), (flags)))
15576 #ifndef SvMAGIC_set
15577 # define SvMAGIC_set(sv, val) \
15578 STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
15579 (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END
15582 #if (PERL_BCDVERSION < 0x5009003)
15583 #ifndef SvPVX_const
15584 # define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv)))
15587 #ifndef SvPVX_mutable
15588 # define SvPVX_mutable(sv) (0 + SvPVX(sv))
15591 # define SvRV_set(sv, val) \
15592 STMT_START { assert(SvTYPE(sv) >= SVt_RV); \
15593 (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END
15597 #ifndef SvPVX_const
15598 # define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv))
15601 #ifndef SvPVX_mutable
15602 # define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv)
15605 # define SvRV_set(sv, val) \
15606 STMT_START { assert(SvTYPE(sv) >= SVt_RV); \
15607 ((sv)->sv_u.svu_rv = (val)); } STMT_END
15611 #ifndef SvSTASH_set
15612 # define SvSTASH_set(sv, val) \
15613 STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
15614 (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END
15617 #if (PERL_BCDVERSION < 0x5004000)
15619 # define SvUV_set(sv, val) \
15620 STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
15621 (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END
15626 # define SvUV_set(sv, val) \
15627 STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
15628 (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END
15633 /* Hint: newSVpvn_share
15634 * The SVs created by this function only mimic the behaviour of
15635 * shared PVs without really being shared. Only use if you know
15636 * what you're doing.
15639 #ifndef newSVpvn_share
15641 #if defined(NEED_newSVpvn_share)
15642 static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char * s, I32 len, U32 hash);
15645 extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char * s, I32 len, U32 hash);
15648 #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL)
15650 #ifdef newSVpvn_share
15651 # undef newSVpvn_share
15653 #define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c)
15654 #define Perl_newSVpvn_share DPPP_(my_newSVpvn_share)
15658 DPPP_(my_newSVpvn_share)(pTHX_ const char *s, I32 len, U32 hash)
15664 PERL_HASH(hash, (char*) s, len);
15665 sv = newSVpvn((char *) s, len);
15666 sv_upgrade(sv, SVt_PVIV);
15676 #ifndef SvSHARED_HASH
15677 # define SvSHARED_HASH(sv) (0 + SvUVX(sv))
15680 # define HvNAME_get(hv) HvNAME(hv)
15682 #ifndef HvNAMELEN_get
15683 # define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0)
15686 #if (PERL_BCDVERSION >= 0x5009002) && (PERL_BCDVERSION <= 0x5009003) /* 5.9.2 and 5.9.3 ignore the length param */
15687 #undef gv_fetchpvn_flags
15690 #ifdef GV_NOADD_MASK
15691 # define D_PPP_GV_NOADD_MASK GV_NOADD_MASK
15693 # define D_PPP_GV_NOADD_MASK 0xE0
15695 #ifndef gv_fetchpvn_flags
15696 # define gv_fetchpvn_flags(name, len, flags, sv_type) gv_fetchpv(SvPVX(sv_2mortal(newSVpvn((name), (len)))), ((flags) & D_PPP_GV_NOADD_MASK) ? FALSE : TRUE, (I32)(sv_type))
15699 # define GvSVn(gv) GvSV(gv)
15702 #ifndef isGV_with_GP
15703 # define isGV_with_GP(gv) isGV(gv)
15707 # define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt)
15709 #ifndef get_cvn_flags
15710 # define get_cvn_flags(name, namelen, flags) get_cv(name, flags)
15713 #ifndef gv_init_pvn
15714 # define gv_init_pvn(gv, stash, ptr, len, flags) gv_init(gv, stash, ptr, len, flags & GV_ADDMULTI ? TRUE : FALSE)
15717 /* concatenating with "" ensures that only literal strings are accepted as argument
15718 * note that STR_WITH_LEN() can't be used as argument to macros or functions that
15719 * under some configurations might be macros
15721 #ifndef STR_WITH_LEN
15722 # define STR_WITH_LEN(s) (s ""), (sizeof(s)-1)
15725 # define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1)
15728 #ifndef newSVpvs_flags
15729 # define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags)
15732 #ifndef newSVpvs_share
15733 # define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0)
15737 # define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1)
15741 # define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1)
15745 # define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval)
15749 # define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0)
15751 #ifndef gv_fetchpvs
15752 # define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt)
15755 #ifndef gv_stashpvs
15756 # define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags)
15759 # define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags)
15762 # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
15765 /* That's the best we can do... */
15766 #ifndef sv_catpvn_nomg
15767 # define sv_catpvn_nomg sv_catpvn
15770 #ifndef sv_catsv_nomg
15771 # define sv_catsv_nomg sv_catsv
15774 #ifndef sv_setsv_nomg
15775 # define sv_setsv_nomg sv_setsv
15778 #ifndef sv_pvn_nomg
15779 # define sv_pvn_nomg sv_pvn
15783 #if defined(PERL_USE_GCC_BRACE_GROUPS)
15785 # define SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ({ SV *_sviv = sv_mortalcopy_flags((sv), SV_NOSTEAL); IV _iv = SvIV(_sviv); SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(_sviv) & SVf_IVisUV); _iv; }))
15789 # define SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvUV((sv)) : ({ SV *_svuv = sv_mortalcopy_flags((sv), SV_NOSTEAL); UV _uv = SvUV(_svuv); SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(_svuv) & SVf_IVisUV); _uv; }))
15794 # define SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ((PL_Sv = sv_mortalcopy_flags((sv), SV_NOSTEAL)), sv_upgrade(PL_Sv, SVt_PVIV), (SvIVX(PL_Sv) = SvIV(PL_Sv)), (SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(PL_Sv) & SVf_IVisUV)), SvIVX(PL_Sv)))
15798 # define SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ((PL_Sv = sv_mortalcopy_flags((sv), SV_NOSTEAL)), sv_upgrade(PL_Sv, SVt_PVIV), (SvUVX(PL_Sv) = SvUV(PL_Sv)), (SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(PL_Sv) & SVf_IVisUV)), SvUVX(PL_Sv)))
15804 # define SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : SvIVx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
15808 # define SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvUV((sv)) : SvUVx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
15813 # define SvNV_nomg(sv) (!SvGMAGICAL((sv)) ? SvNV((sv)) : SvNVx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
15816 #ifndef SvTRUE_nomg
15817 # define SvTRUE_nomg(sv) (!SvGMAGICAL((sv)) ? SvTRUE((sv)) : SvTRUEx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
15820 #ifndef sv_catpv_mg
15821 # define sv_catpv_mg(sv, ptr) \
15824 sv_catpv(TeMpSv,ptr); \
15825 SvSETMAGIC(TeMpSv); \
15829 #ifndef sv_catpvn_mg
15830 # define sv_catpvn_mg(sv, ptr, len) \
15833 sv_catpvn(TeMpSv,ptr,len); \
15834 SvSETMAGIC(TeMpSv); \
15838 #ifndef sv_catsv_mg
15839 # define sv_catsv_mg(dsv, ssv) \
15841 SV *TeMpSv = dsv; \
15842 sv_catsv(TeMpSv,ssv); \
15843 SvSETMAGIC(TeMpSv); \
15847 #ifndef sv_setiv_mg
15848 # define sv_setiv_mg(sv, i) \
15851 sv_setiv(TeMpSv,i); \
15852 SvSETMAGIC(TeMpSv); \
15856 #ifndef sv_setnv_mg
15857 # define sv_setnv_mg(sv, num) \
15860 sv_setnv(TeMpSv,num); \
15861 SvSETMAGIC(TeMpSv); \
15865 #ifndef sv_setpv_mg
15866 # define sv_setpv_mg(sv, ptr) \
15869 sv_setpv(TeMpSv,ptr); \
15870 SvSETMAGIC(TeMpSv); \
15874 #ifndef sv_setpvn_mg
15875 # define sv_setpvn_mg(sv, ptr, len) \
15878 sv_setpvn(TeMpSv,ptr,len); \
15879 SvSETMAGIC(TeMpSv); \
15883 #ifndef sv_setsv_mg
15884 # define sv_setsv_mg(dsv, ssv) \
15886 SV *TeMpSv = dsv; \
15887 sv_setsv(TeMpSv,ssv); \
15888 SvSETMAGIC(TeMpSv); \
15892 #ifndef sv_setuv_mg
15893 # define sv_setuv_mg(sv, i) \
15896 sv_setuv(TeMpSv,i); \
15897 SvSETMAGIC(TeMpSv); \
15901 #ifndef sv_usepvn_mg
15902 # define sv_usepvn_mg(sv, ptr, len) \
15905 sv_usepvn(TeMpSv,ptr,len); \
15906 SvSETMAGIC(TeMpSv); \
15909 #ifndef SvVSTRING_mg
15910 # define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL)
15913 /* Hint: sv_magic_portable
15914 * This is a compatibility function that is only available with
15915 * Devel::PPPort. It is NOT in the perl core.
15916 * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when
15917 * it is being passed a name pointer with namlen == 0. In that
15918 * case, perl 5.8.0 and later store the pointer, not a copy of it.
15919 * The compatibility can be provided back to perl 5.004. With
15920 * earlier versions, the code will not compile.
15923 #if (PERL_BCDVERSION < 0x5004000)
15925 /* code that uses sv_magic_portable will not compile */
15927 #elif (PERL_BCDVERSION < 0x5008000)
15929 # define sv_magic_portable(sv, obj, how, name, namlen) \
15931 SV *SvMp_sv = (sv); \
15932 char *SvMp_name = (char *) (name); \
15933 I32 SvMp_namlen = (namlen); \
15934 if (SvMp_name && SvMp_namlen == 0) \
15937 sv_magic(SvMp_sv, obj, how, 0, 0); \
15938 mg = SvMAGIC(SvMp_sv); \
15939 mg->mg_len = -42; /* XXX: this is the tricky part */ \
15940 mg->mg_ptr = SvMp_name; \
15944 sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \
15950 # define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e)
15954 #if !defined(mg_findext)
15955 #if defined(NEED_mg_findext)
15956 static MAGIC * DPPP_(my_mg_findext)(const SV * sv, int type, const MGVTBL * vtbl);
15959 extern MAGIC * DPPP_(my_mg_findext)(const SV * sv, int type, const MGVTBL * vtbl);
15962 #if defined(NEED_mg_findext) || defined(NEED_mg_findext_GLOBAL)
15964 #define mg_findext DPPP_(my_mg_findext)
15965 #define Perl_mg_findext DPPP_(my_mg_findext)
15969 DPPP_(my_mg_findext)(const SV * sv, int type, const MGVTBL *vtbl) {
15973 #ifdef AvPAD_NAMELIST
15974 assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
15977 for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) {
15978 if (mg->mg_type == type && mg->mg_virtual == vtbl)
15989 #if !defined(sv_unmagicext)
15990 #if defined(NEED_sv_unmagicext)
15991 static int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl);
15994 extern int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl);
15997 #if defined(NEED_sv_unmagicext) || defined(NEED_sv_unmagicext_GLOBAL)
15999 #ifdef sv_unmagicext
16000 # undef sv_unmagicext
16002 #define sv_unmagicext(a,b,c) DPPP_(my_sv_unmagicext)(aTHX_ a,b,c)
16003 #define Perl_sv_unmagicext DPPP_(my_sv_unmagicext)
16007 DPPP_(my_sv_unmagicext)(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
16012 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
16014 mgp = &(SvMAGIC(sv));
16015 for (mg = *mgp; mg; mg = *mgp) {
16016 const MGVTBL* const virt = mg->mg_virtual;
16017 if (mg->mg_type == type && virt == vtbl) {
16018 *mgp = mg->mg_moremagic;
16019 if (virt && virt->svt_free)
16020 virt->svt_free(aTHX_ sv, mg);
16021 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
16022 if (mg->mg_len > 0)
16023 Safefree(mg->mg_ptr);
16024 else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */
16025 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
16026 else if (mg->mg_type == PERL_MAGIC_utf8)
16027 Safefree(mg->mg_ptr);
16029 if (mg->mg_flags & MGf_REFCOUNTED)
16030 SvREFCNT_dec(mg->mg_obj);
16034 mgp = &mg->mg_moremagic;
16037 if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
16038 mg_magical(sv); /* else fix the flags now */
16042 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
16050 #ifdef USE_ITHREADS
16052 # define CopFILE(c) ((c)->cop_file)
16056 # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv)
16059 #ifndef CopFILE_set
16060 # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
16064 # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
16068 # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
16072 # define CopSTASHPV(c) ((c)->cop_stashpv)
16075 #ifndef CopSTASHPV_set
16076 # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch))
16080 # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
16083 #ifndef CopSTASH_set
16084 # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
16087 #ifndef CopSTASH_eq
16088 # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \
16089 || (CopSTASHPV(c) && HvNAME(hv) \
16090 && strEQ(CopSTASHPV(c), HvNAME(hv)))))
16095 # define CopFILEGV(c) ((c)->cop_filegv)
16098 #ifndef CopFILEGV_set
16099 # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
16102 #ifndef CopFILE_set
16103 # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
16107 # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv)
16111 # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav)
16115 # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch)
16119 # define CopSTASH(c) ((c)->cop_stash)
16122 #ifndef CopSTASH_set
16123 # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
16127 # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch)
16130 #ifndef CopSTASHPV_set
16131 # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
16134 #ifndef CopSTASH_eq
16135 # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
16138 #endif /* USE_ITHREADS */
16140 #if (PERL_BCDVERSION >= 0x5006000)
16143 # if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL)
16145 DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock)
16149 for (i = startingblock; i >= 0; i--) {
16150 const PERL_CONTEXT * const cx = &cxstk[i];
16151 switch (CxTYPE(cx)) {
16164 # if defined(NEED_caller_cx)
16165 static const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 level, const PERL_CONTEXT * * dbcxp);
16168 extern const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 level, const PERL_CONTEXT * * dbcxp);
16171 #if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL)
16176 #define caller_cx(a,b) DPPP_(my_caller_cx)(aTHX_ a,b)
16177 #define Perl_caller_cx DPPP_(my_caller_cx)
16180 const PERL_CONTEXT *
16181 DPPP_(my_caller_cx)(pTHX_ I32 level, const PERL_CONTEXT **dbcxp)
16183 I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix);
16184 const PERL_CONTEXT *cx;
16185 const PERL_CONTEXT *ccstack = cxstack;
16186 const PERL_SI *top_si = PL_curstackinfo;
16189 /* we may be in a higher stacklevel, so dig down deeper */
16190 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
16191 top_si = top_si->si_prev;
16192 ccstack = top_si->si_cxstack;
16193 cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix);
16197 /* caller() should not report the automatic calls to &DB::sub */
16198 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
16199 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
16203 cxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
16206 cx = &ccstack[cxix];
16207 if (dbcxp) *dbcxp = cx;
16209 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
16210 const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
16211 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
16212 field below is defined for any cx. */
16213 /* caller() should not report the automatic calls to &DB::sub */
16214 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
16215 cx = &ccstack[dbcxix];
16222 #endif /* caller_cx */
16224 #ifndef IN_PERL_COMPILETIME
16225 # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
16228 #ifndef IN_LOCALE_RUNTIME
16229 # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
16232 #ifndef IN_LOCALE_COMPILETIME
16233 # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
16237 # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
16239 #ifndef IS_NUMBER_IN_UV
16240 # define IS_NUMBER_IN_UV 0x01
16243 #ifndef IS_NUMBER_GREATER_THAN_UV_MAX
16244 # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
16247 #ifndef IS_NUMBER_NOT_INT
16248 # define IS_NUMBER_NOT_INT 0x04
16251 #ifndef IS_NUMBER_NEG
16252 # define IS_NUMBER_NEG 0x08
16255 #ifndef IS_NUMBER_INFINITY
16256 # define IS_NUMBER_INFINITY 0x10
16259 #ifndef IS_NUMBER_NAN
16260 # define IS_NUMBER_NAN 0x20
16262 #ifndef GROK_NUMERIC_RADIX
16263 # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
16265 #ifndef PERL_SCAN_GREATER_THAN_UV_MAX
16266 # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
16269 #ifndef PERL_SCAN_SILENT_ILLDIGIT
16270 # define PERL_SCAN_SILENT_ILLDIGIT 0x04
16273 #ifndef PERL_SCAN_ALLOW_UNDERSCORES
16274 # define PERL_SCAN_ALLOW_UNDERSCORES 0x01
16277 #ifndef PERL_SCAN_DISALLOW_PREFIX
16278 # define PERL_SCAN_DISALLOW_PREFIX 0x02
16281 #ifndef grok_numeric_radix
16282 #if defined(NEED_grok_numeric_radix)
16283 static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char * * sp, const char * send);
16286 extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char * * sp, const char * send);
16289 #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL)
16291 #ifdef grok_numeric_radix
16292 # undef grok_numeric_radix
16294 #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b)
16295 #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix)
16298 DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send)
16300 #ifdef USE_LOCALE_NUMERIC
16301 #ifdef PL_numeric_radix_sv
16302 if (PL_numeric_radix_sv && IN_LOCALE) {
16304 char* radix = SvPV(PL_numeric_radix_sv, len);
16305 if (*sp + len <= send && memEQ(*sp, radix, len)) {
16311 /* older perls don't have PL_numeric_radix_sv so the radix
16312 * must manually be requested from locale.h
16314 #include <locale.h>
16315 dTHR; /* needed for older threaded perls */
16316 struct lconv *lc = localeconv();
16317 char *radix = lc->decimal_point;
16318 if (radix && IN_LOCALE) {
16319 STRLEN len = strlen(radix);
16320 if (*sp + len <= send && memEQ(*sp, radix, len)) {
16326 #endif /* USE_LOCALE_NUMERIC */
16327 /* always try "." if numeric radix didn't match because
16328 * we may have data from different locales mixed */
16329 if (*sp < send && **sp == '.') {
16338 #ifndef grok_number
16339 #if defined(NEED_grok_number)
16340 static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
16343 extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
16346 #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL)
16349 # undef grok_number
16351 #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c)
16352 #define Perl_grok_number DPPP_(my_grok_number)
16355 DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep)
16357 const char *s = pv;
16358 const char *send = pv + len;
16359 const UV max_div_10 = UV_MAX / 10;
16360 const char max_mod_10 = UV_MAX % 10;
16365 while (s < send && isSPACE(*s))
16369 } else if (*s == '-') {
16371 numtype = IS_NUMBER_NEG;
16373 else if (*s == '+')
16379 /* next must be digit or the radix separator or beginning of infinity */
16381 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
16383 UV value = *s - '0';
16384 /* This construction seems to be more optimiser friendly.
16385 (without it gcc does the isDIGIT test and the *s - '0' separately)
16386 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
16387 In theory the optimiser could deduce how far to unroll the loop
16388 before checking for overflow. */
16390 int digit = *s - '0';
16391 if (digit >= 0 && digit <= 9) {
16392 value = value * 10 + digit;
16395 if (digit >= 0 && digit <= 9) {
16396 value = value * 10 + digit;
16399 if (digit >= 0 && digit <= 9) {
16400 value = value * 10 + digit;
16403 if (digit >= 0 && digit <= 9) {
16404 value = value * 10 + digit;
16407 if (digit >= 0 && digit <= 9) {
16408 value = value * 10 + digit;
16411 if (digit >= 0 && digit <= 9) {
16412 value = value * 10 + digit;
16415 if (digit >= 0 && digit <= 9) {
16416 value = value * 10 + digit;
16419 if (digit >= 0 && digit <= 9) {
16420 value = value * 10 + digit;
16422 /* Now got 9 digits, so need to check
16423 each time for overflow. */
16425 while (digit >= 0 && digit <= 9
16426 && (value < max_div_10
16427 || (value == max_div_10
16428 && digit <= max_mod_10))) {
16429 value = value * 10 + digit;
16435 if (digit >= 0 && digit <= 9
16437 /* value overflowed.
16438 skip the remaining digits, don't
16439 worry about setting *valuep. */
16442 } while (s < send && isDIGIT(*s));
16444 IS_NUMBER_GREATER_THAN_UV_MAX;
16464 numtype |= IS_NUMBER_IN_UV;
16469 if (GROK_NUMERIC_RADIX(&s, send)) {
16470 numtype |= IS_NUMBER_NOT_INT;
16471 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
16475 else if (GROK_NUMERIC_RADIX(&s, send)) {
16476 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
16477 /* no digits before the radix means we need digits after it */
16478 if (s < send && isDIGIT(*s)) {
16481 } while (s < send && isDIGIT(*s));
16483 /* integer approximation is valid - it's 0. */
16489 } else if (*s == 'I' || *s == 'i') {
16490 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
16491 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
16492 s++; if (s < send && (*s == 'I' || *s == 'i')) {
16493 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
16494 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
16495 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
16496 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
16500 } else if (*s == 'N' || *s == 'n') {
16501 /* XXX TODO: There are signaling NaNs and quiet NaNs. */
16502 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
16503 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
16510 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
16511 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
16512 } else if (sawnan) {
16513 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
16514 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
16515 } else if (s < send) {
16516 /* we can have an optional exponent part */
16517 if (*s == 'e' || *s == 'E') {
16518 /* The only flag we keep is sign. Blow away any "it's UV" */
16519 numtype &= IS_NUMBER_NEG;
16520 numtype |= IS_NUMBER_NOT_INT;
16522 if (s < send && (*s == '-' || *s == '+'))
16524 if (s < send && isDIGIT(*s)) {
16527 } while (s < send && isDIGIT(*s));
16533 while (s < send && isSPACE(*s))
16537 if (len == 10 && memEQ(pv, "0 but true", 10)) {
16540 return IS_NUMBER_IN_UV;
16548 * The grok_* routines have been modified to use warn() instead of
16549 * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit,
16550 * which is why the stack variable has been renamed to 'xdigit'.
16554 #if defined(NEED_grok_bin)
16555 static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
16558 extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
16561 #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL)
16566 #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d)
16567 #define Perl_grok_bin DPPP_(my_grok_bin)
16570 DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
16572 const char *s = start;
16573 STRLEN len = *len_p;
16577 const UV max_div_2 = UV_MAX / 2;
16578 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
16579 bool overflowed = FALSE;
16581 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
16582 /* strip off leading b or 0b.
16583 for compatibility silently suffer "b" and "0b" as valid binary
16590 else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
16597 for (; len-- && *s; s++) {
16599 if (bit == '0' || bit == '1') {
16600 /* Write it in this wonky order with a goto to attempt to get the
16601 compiler to make the common case integer-only loop pretty tight.
16602 With gcc seems to be much straighter code than old scan_bin. */
16605 if (value <= max_div_2) {
16606 value = (value << 1) | (bit - '0');
16609 /* Bah. We're just overflowed. */
16610 warn("Integer overflow in binary number");
16612 value_nv = (NV) value;
16615 /* If an NV has not enough bits in its mantissa to
16616 * represent a UV this summing of small low-order numbers
16617 * is a waste of time (because the NV cannot preserve
16618 * the low-order bits anyway): we could just remember when
16619 * did we overflow and in the end just multiply value_nv by the
16621 value_nv += (NV)(bit - '0');
16624 if (bit == '_' && len && allow_underscores && (bit = s[1])
16625 && (bit == '0' || bit == '1'))
16631 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
16632 warn("Illegal binary digit '%c' ignored", *s);
16636 if ( ( overflowed && value_nv > 4294967295.0)
16638 || (!overflowed && value > 0xffffffff )
16641 warn("Binary number > 0b11111111111111111111111111111111 non-portable");
16643 *len_p = s - start;
16648 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
16650 *result = value_nv;
16657 #if defined(NEED_grok_hex)
16658 static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
16661 extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
16664 #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL)
16669 #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d)
16670 #define Perl_grok_hex DPPP_(my_grok_hex)
16673 DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
16675 const char *s = start;
16676 STRLEN len = *len_p;
16680 const UV max_div_16 = UV_MAX / 16;
16681 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
16682 bool overflowed = FALSE;
16683 const char *xdigit;
16685 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
16686 /* strip off leading x or 0x.
16687 for compatibility silently suffer "x" and "0x" as valid hex numbers.
16694 else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
16701 for (; len-- && *s; s++) {
16702 xdigit = strchr((char *) PL_hexdigit, *s);
16704 /* Write it in this wonky order with a goto to attempt to get the
16705 compiler to make the common case integer-only loop pretty tight.
16706 With gcc seems to be much straighter code than old scan_hex. */
16709 if (value <= max_div_16) {
16710 value = (value << 4) | ((xdigit - PL_hexdigit) & 15);
16713 warn("Integer overflow in hexadecimal number");
16715 value_nv = (NV) value;
16718 /* If an NV has not enough bits in its mantissa to
16719 * represent a UV this summing of small low-order numbers
16720 * is a waste of time (because the NV cannot preserve
16721 * the low-order bits anyway): we could just remember when
16722 * did we overflow and in the end just multiply value_nv by the
16723 * right amount of 16-tuples. */
16724 value_nv += (NV)((xdigit - PL_hexdigit) & 15);
16727 if (*s == '_' && len && allow_underscores && s[1]
16728 && (xdigit = strchr((char *) PL_hexdigit, s[1])))
16734 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
16735 warn("Illegal hexadecimal digit '%c' ignored", *s);
16739 if ( ( overflowed && value_nv > 4294967295.0)
16741 || (!overflowed && value > 0xffffffff )
16744 warn("Hexadecimal number > 0xffffffff non-portable");
16746 *len_p = s - start;
16751 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
16753 *result = value_nv;
16760 #if defined(NEED_grok_oct)
16761 static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
16764 extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
16767 #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL)
16772 #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d)
16773 #define Perl_grok_oct DPPP_(my_grok_oct)
16776 DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
16778 const char *s = start;
16779 STRLEN len = *len_p;
16783 const UV max_div_8 = UV_MAX / 8;
16784 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
16785 bool overflowed = FALSE;
16787 for (; len-- && *s; s++) {
16788 /* gcc 2.95 optimiser not smart enough to figure that this subtraction
16789 out front allows slicker code. */
16790 int digit = *s - '0';
16791 if (digit >= 0 && digit <= 7) {
16792 /* Write it in this wonky order with a goto to attempt to get the
16793 compiler to make the common case integer-only loop pretty tight.
16797 if (value <= max_div_8) {
16798 value = (value << 3) | digit;
16801 /* Bah. We're just overflowed. */
16802 warn("Integer overflow in octal number");
16804 value_nv = (NV) value;
16807 /* If an NV has not enough bits in its mantissa to
16808 * represent a UV this summing of small low-order numbers
16809 * is a waste of time (because the NV cannot preserve
16810 * the low-order bits anyway): we could just remember when
16811 * did we overflow and in the end just multiply value_nv by the
16812 * right amount of 8-tuples. */
16813 value_nv += (NV)digit;
16816 if (digit == ('_' - '0') && len && allow_underscores
16817 && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
16823 /* Allow \octal to work the DWIM way (that is, stop scanning
16824 * as soon as non-octal characters are seen, complain only iff
16825 * someone seems to want to use the digits eight and nine). */
16826 if (digit == 8 || digit == 9) {
16827 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
16828 warn("Illegal octal digit '%c' ignored", *s);
16833 if ( ( overflowed && value_nv > 4294967295.0)
16835 || (!overflowed && value > 0xffffffff )
16838 warn("Octal number > 037777777777 non-portable");
16840 *len_p = s - start;
16845 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
16847 *result = value_nv;
16853 #if !defined(my_snprintf)
16854 #if defined(NEED_my_snprintf)
16855 static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
16858 extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
16861 #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL)
16863 #define my_snprintf DPPP_(my_my_snprintf)
16864 #define Perl_my_snprintf DPPP_(my_my_snprintf)
16868 DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...)
16873 va_start(ap, format);
16874 #ifdef HAS_VSNPRINTF
16875 retval = vsnprintf(buffer, len, format, ap);
16877 retval = vsprintf(buffer, format, ap);
16880 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
16881 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
16888 #if !defined(my_sprintf)
16889 #if defined(NEED_my_sprintf)
16890 static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...);
16893 extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...);
16896 #if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL)
16898 #define my_sprintf DPPP_(my_my_sprintf)
16901 /* Warning: my_sprintf
16902 It's safer to use my_snprintf instead
16905 /* Replace my_sprintf with my_snprintf */
16908 DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...)
16911 va_start(args, pat);
16912 vsprintf(buffer, pat, args);
16914 return strlen(buffer);
16922 # define dXCPT dJMPENV; int rEtV = 0
16923 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0)
16924 # define XCPT_TRY_END JMPENV_POP;
16925 # define XCPT_CATCH if (rEtV != 0)
16926 # define XCPT_RETHROW JMPENV_JUMP(rEtV)
16928 # define dXCPT Sigjmp_buf oldTOP; int rEtV = 0
16929 # define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0)
16930 # define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf);
16931 # define XCPT_CATCH if (rEtV != 0)
16932 # define XCPT_RETHROW Siglongjmp(top_env, rEtV)
16936 #if !defined(my_strlcat)
16937 #if defined(NEED_my_strlcat)
16938 static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size);
16941 extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size);
16944 #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL)
16946 #define my_strlcat DPPP_(my_my_strlcat)
16947 #define Perl_my_strlcat DPPP_(my_my_strlcat)
16951 DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size)
16953 Size_t used, length, copy;
16955 used = strlen(dst);
16956 length = strlen(src);
16957 if (size > 0 && used < size - 1) {
16958 copy = (length >= size - used) ? size - used - 1 : length;
16959 memcpy(dst + used, src, copy);
16960 dst[used + copy] = '\0';
16962 return used + length;
16967 #if !defined(my_strlcpy)
16968 #if defined(NEED_my_strlcpy)
16969 static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size);
16972 extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size);
16975 #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL)
16977 #define my_strlcpy DPPP_(my_my_strlcpy)
16978 #define Perl_my_strlcpy DPPP_(my_my_strlcpy)
16982 DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size)
16984 Size_t length, copy;
16986 length = strlen(src);
16988 copy = (length >= size) ? size - 1 : length;
16989 memcpy(dst, src, copy);
17000 # define SvUTF8(sv) (SvFLAGS(sv) & SVf_UTF8)
17005 #if (PERL_BCDVERSION == 0x5019001) /* 5.19.1 does not have UTF8fARG, only broken UTF8f */
17015 # define UTF8fARG(u,l,p) newSVpvn_flags((p), (l), ((u) ? SVf_UTF8 : 0) | SVs_TEMP)
17020 #define D_PPP_MIN(a,b) (((a) <= (b)) ? (a) : (b))
17021 #ifndef UNICODE_REPLACEMENT
17022 # define UNICODE_REPLACEMENT 0xFFFD
17026 #ifndef UTF8_MAXBYTES
17027 # define UTF8_MAXBYTES UTF8_MAXLEN
17031 #ifndef UTF_START_MARK
17032 # define UTF_START_MARK(len) \
17033 (((len) > 7) ? 0xFF : (0xFF & (0xFE << (7-(len)))))
17036 /* On non-EBCDIC was valid for some releases earlier than this, but easier to
17037 * just do one check */
17038 #if (PERL_BCDVERSION < 0x5018000)
17039 # undef UTF8_MAXBYTES_CASE
17043 # define D_PPP_BYTE_INFO_BITS 6 /* 6 bits meaningful in continuation bytes */
17044 #ifndef UTF8_MAXBYTES_CASE
17045 # define UTF8_MAXBYTES_CASE 13
17049 # define D_PPP_BYTE_INFO_BITS 5 /* 5 bits meaningful in continuation bytes */
17050 #ifndef UTF8_MAXBYTES_CASE
17051 # define UTF8_MAXBYTES_CASE 15
17055 #ifndef UTF_ACCUMULATION_SHIFT
17056 # define UTF_ACCUMULATION_SHIFT D_PPP_BYTE_INFO_BITS
17059 #ifdef NATIVE_TO_UTF
17060 #ifndef NATIVE_UTF8_TO_I8
17061 # define NATIVE_UTF8_TO_I8(c) NATIVE_TO_UTF(c)
17064 #else /* System doesn't support EBCDIC */
17065 #ifndef NATIVE_UTF8_TO_I8
17066 # define NATIVE_UTF8_TO_I8(c) (c)
17071 #ifdef UTF_TO_NATIVE
17072 #ifndef I8_TO_NATIVE_UTF8
17073 # define I8_TO_NATIVE_UTF8(c) UTF_TO_NATIVE(c)
17076 #else /* System doesn't support EBCDIC */
17077 #ifndef I8_TO_NATIVE_UTF8
17078 # define I8_TO_NATIVE_UTF8(c) (c)
17082 #ifndef UTF_START_MASK
17083 # define UTF_START_MASK(len) \
17084 (((len) >= 7) ? 0x00 : (0x1F >> ((len)-2)))
17087 #ifndef UTF_IS_CONTINUATION_MASK
17088 # define UTF_IS_CONTINUATION_MASK \
17089 ((U8) (0xFF << UTF_ACCUMULATION_SHIFT))
17092 #ifndef UTF_CONTINUATION_MARK
17093 # define UTF_CONTINUATION_MARK \
17094 (UTF_IS_CONTINUATION_MASK & 0xB0)
17097 #ifndef UTF_MIN_START_BYTE
17098 # define UTF_MIN_START_BYTE \
17099 ((UTF_CONTINUATION_MARK >> UTF_ACCUMULATION_SHIFT) | UTF_START_MARK(2))
17101 #ifndef UTF_MIN_ABOVE_LATIN1_BYTE
17102 # define UTF_MIN_ABOVE_LATIN1_BYTE \
17103 ((0x100 >> UTF_ACCUMULATION_SHIFT) | UTF_START_MARK(2))
17106 #if (PERL_BCDVERSION < 0x5007000) /* Was the complement of what should have been */
17107 # undef UTF8_IS_DOWNGRADEABLE_START
17109 #ifndef UTF8_IS_DOWNGRADEABLE_START
17110 # define UTF8_IS_DOWNGRADEABLE_START(c) \
17111 inRANGE(NATIVE_UTF8_TO_I8(c), \
17112 UTF_MIN_START_BYTE, UTF_MIN_ABOVE_LATIN1_BYTE - 1)
17115 #ifndef UTF_CONTINUATION_MASK
17116 # define UTF_CONTINUATION_MASK \
17117 ((U8) ((1U << UTF_ACCUMULATION_SHIFT) - 1))
17119 #ifndef UTF8_ACCUMULATE
17120 # define UTF8_ACCUMULATE(base, added) \
17121 (((base) << UTF_ACCUMULATION_SHIFT) \
17122 | ((NATIVE_UTF8_TO_I8(added)) \
17123 & UTF_CONTINUATION_MASK))
17125 #ifndef UTF8_ALLOW_ANYUV
17126 # define UTF8_ALLOW_ANYUV 0
17129 #ifndef UTF8_ALLOW_EMPTY
17130 # define UTF8_ALLOW_EMPTY 0x0001
17133 #ifndef UTF8_ALLOW_CONTINUATION
17134 # define UTF8_ALLOW_CONTINUATION 0x0002
17137 #ifndef UTF8_ALLOW_NON_CONTINUATION
17138 # define UTF8_ALLOW_NON_CONTINUATION 0x0004
17141 #ifndef UTF8_ALLOW_SHORT
17142 # define UTF8_ALLOW_SHORT 0x0008
17145 #ifndef UTF8_ALLOW_LONG
17146 # define UTF8_ALLOW_LONG 0x0010
17149 #ifndef UTF8_ALLOW_OVERFLOW
17150 # define UTF8_ALLOW_OVERFLOW 0x0080
17153 #ifndef UTF8_ALLOW_ANY
17154 # define UTF8_ALLOW_ANY ( UTF8_ALLOW_CONTINUATION \
17155 |UTF8_ALLOW_NON_CONTINUATION \
17156 |UTF8_ALLOW_SHORT \
17158 |UTF8_ALLOW_OVERFLOW)
17161 #if defined UTF8SKIP
17163 /* Don't use official versions because they use MIN, which may not be available */
17164 #undef UTF8_SAFE_SKIP
17165 #undef UTF8_CHK_SKIP
17166 #ifndef UTF8_SAFE_SKIP
17167 # define UTF8_SAFE_SKIP(s, e) ( \
17168 ((((e) - (s)) <= 0) \
17170 : D_PPP_MIN(((e) - (s)), UTF8SKIP(s))))
17172 #ifndef UTF8_CHK_SKIP
17173 # define UTF8_CHK_SKIP(s) \
17174 (s[0] == '\0' ? 1 : ((U8) D_PPP_MIN(my_strnlen((char *) (s), UTF8SKIP(s)), \
17178 /* UTF8_CHK_SKIP depends on my_strnlen */
17180 # define UTF8_SKIP(s) UTF8SKIP(s)
17186 #ifndef UTF8_IS_INVARIANT
17187 # define UTF8_IS_INVARIANT(c) isASCII(c)
17191 #ifndef UTF8_IS_INVARIANT
17192 # define UTF8_IS_INVARIANT(c) (isASCII(c) || isCNTRL_L1(c))
17196 #ifndef UVCHR_IS_INVARIANT
17197 # define UVCHR_IS_INVARIANT(c) UTF8_IS_INVARIANT(c)
17200 #ifdef UVCHR_IS_INVARIANT
17201 # if 'A' != 65 || UVSIZE < 8
17202 /* 32 bit platform, which includes UTF-EBCDIC on the releases this is
17204 # define D_PPP_UVCHR_SKIP_UPPER(c) 7
17206 # define D_PPP_UVCHR_SKIP_UPPER(c) \
17207 (((WIDEST_UTYPE) (c)) < \
17208 (((WIDEST_UTYPE) 1) << (6 * D_PPP_BYTE_INFO_BITS)) ? 7 : 13)
17211 # define UVCHR_SKIP(c) \
17212 UVCHR_IS_INVARIANT(c) ? 1 : \
17213 (WIDEST_UTYPE) (c) < (32 * (1U << ( D_PPP_BYTE_INFO_BITS))) ? 2 : \
17214 (WIDEST_UTYPE) (c) < (16 * (1U << (2 * D_PPP_BYTE_INFO_BITS))) ? 3 : \
17215 (WIDEST_UTYPE) (c) < ( 8 * (1U << (3 * D_PPP_BYTE_INFO_BITS))) ? 4 : \
17216 (WIDEST_UTYPE) (c) < ( 4 * (1U << (4 * D_PPP_BYTE_INFO_BITS))) ? 5 : \
17217 (WIDEST_UTYPE) (c) < ( 2 * (1U << (5 * D_PPP_BYTE_INFO_BITS))) ? 6 : \
17218 D_PPP_UVCHR_SKIP_UPPER(c)
17223 #ifdef is_ascii_string
17224 #ifndef is_invariant_string
17225 # define is_invariant_string(s,l) is_ascii_string(s,l)
17228 #ifndef is_utf8_invariant_string
17229 # define is_utf8_invariant_string(s,l) is_ascii_string(s,l)
17232 /* Hint: is_ascii_string, is_invariant_string
17233 is_utf8_invariant_string() does the same thing and is preferred because its
17234 name is more accurate as to what it does */
17238 #ifndef foldEQ_utf8
17239 # define foldEQ_utf8(s1,pe1,l1,u1,s2,pe2,l2,u2) \
17240 cBOOL(! ibcmp_utf8(s1,pe1,l1,u1,s2,pe2,l2,u2))
17245 #if defined(is_utf8_string) && defined(UTF8SKIP)
17246 #ifndef isUTF8_CHAR
17247 # define isUTF8_CHAR(s, e) ( \
17248 (e) <= (s) || ! is_utf8_string(s, UTF8_SAFE_SKIP(s, e)) \
17257 # define BOM_UTF8 "\xEF\xBB\xBF"
17260 #ifndef REPLACEMENT_CHARACTER_UTF8
17261 # define REPLACEMENT_CHARACTER_UTF8 "\xEF\xBF\xBD"
17266 # define BOM_UTF8 "\xDD\x73\x66\x73"
17269 #ifndef REPLACEMENT_CHARACTER_UTF8
17270 # define REPLACEMENT_CHARACTER_UTF8 "\xDD\x73\x73\x71"
17275 # define BOM_UTF8 "\xDD\x72\x65\x72"
17278 #ifndef REPLACEMENT_CHARACTER_UTF8
17279 # define REPLACEMENT_CHARACTER_UTF8 "\xDD\x72\x72\x70"
17283 # error Unknown character set
17286 #if (PERL_BCDVERSION < 0x5031004)
17287 /* Versions prior to this accepted things that are now considered
17288 * malformations, and didn't return -1 on error with warnings enabled
17290 # undef utf8_to_uvchr_buf
17293 /* This implementation brings modern, generally more restricted standards to
17294 * utf8_to_uvchr_buf. Some of these are security related, and clearly must
17295 * be done. But its arguable that the others need not, and hence should not.
17296 * The reason they're here is that a module that intends to play with the
17297 * latest perls should be able to work the same in all releases. An example is
17298 * that perl no longer accepts any UV for a code point, but limits them to
17299 * IV_MAX or below. This is for future internal use of the larger code points.
17300 * If it turns out that some of these changes are breaking code that isn't
17301 * intended to work with modern perls, the tighter restrictions could be
17302 * relaxed. khw thinks this is unlikely, but has been wrong in the past. */
17304 /* 5.6.0 is the first release with UTF-8, and we don't implement this function
17305 * there due to its likely lack of still being in use, and the underlying
17306 * implementation is very different from later ones, without the later
17307 * safeguards, so would require extra work to deal with */
17308 #if (PERL_BCDVERSION >= 0x5006001) && ! defined(utf8_to_uvchr_buf)
17309 /* Choose which underlying implementation to use. At least one must be
17310 * present or the perl is too early to handle this function */
17311 # if defined(utf8n_to_uvchr) || defined(utf8_to_uvchr) || defined(utf8_to_uv)
17312 # if defined(utf8n_to_uvchr) /* This is the preferred implementation */
17313 # define D_PPP_utf8_to_uvchr_buf_callee utf8n_to_uvchr
17314 # elif /* Must be at least 5.6.1 from #if above; \
17315 If have both regular and _simple, regular has all args */ \
17316 defined(utf8_to_uv) && defined(utf8_to_uv_simple)
17317 # define D_PPP_utf8_to_uvchr_buf_callee utf8_to_uv
17318 # elif defined(utf8_to_uvchr) /* The below won't work well on error input */
17319 # define D_PPP_utf8_to_uvchr_buf_callee(s, curlen, retlen, flags) \
17320 utf8_to_uvchr((U8 *)(s), (retlen))
17322 # define D_PPP_utf8_to_uvchr_buf_callee(s, curlen, retlen, flags) \
17323 utf8_to_uv((U8 *)(s), (retlen))
17327 # if defined(NEED_utf8_to_uvchr_buf)
17328 static UV DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 * s, const U8 * send, STRLEN * retlen);
17331 extern UV DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 * s, const U8 * send, STRLEN * retlen);
17334 #if defined(NEED_utf8_to_uvchr_buf) || defined(NEED_utf8_to_uvchr_buf_GLOBAL)
17336 #ifdef utf8_to_uvchr_buf
17337 # undef utf8_to_uvchr_buf
17339 #define utf8_to_uvchr_buf(a,b,c) DPPP_(my_utf8_to_uvchr_buf)(aTHX_ a,b,c)
17340 #define Perl_utf8_to_uvchr_buf DPPP_(my_utf8_to_uvchr_buf)
17344 DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
17348 bool overflows = 0;
17349 const U8 *cur_s = s;
17350 const bool do_warnings = ckWARN_d(WARN_UTF8);
17351 # if (PERL_BCDVERSION < 0x5026000) && ! defined(EBCDIC)
17352 STRLEN overflow_length = 0;
17359 assert(0); /* Modern perls die under this circumstance */
17361 if (! do_warnings) { /* Handle empty here if no warnings needed */
17362 if (retlen) *retlen = 0;
17363 return UNICODE_REPLACEMENT;
17367 # if (PERL_BCDVERSION < 0x5026000) && ! defined(EBCDIC)
17369 /* Perl did not properly detect overflow for much of its history on
17370 * non-EBCDIC platforms, often returning an overlong value which may or may
17371 * not have been tolerated in the call. Also, earlier versions, when they
17372 * did detect overflow, may have disallowed it completely. Modern ones can
17373 * replace it with the REPLACEMENT CHARACTER, depending on calling
17374 * parameters. Therefore detect it ourselves in releases it was
17375 * problematic in. */
17377 if (curlen > 0 && UNLIKELY(*s >= 0xFE)) {
17379 /* First, on a 32-bit machine the first byte being at least \xFE
17380 * automatically is overflow, as it indicates something requiring more
17382 if (sizeof(ret) < 8) {
17384 overflow_length = (*s == 0xFE) ? 7 : 13;
17387 const U8 highest[] = /* 2*63-1 */
17388 "\xFF\x80\x87\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF";
17389 const U8 *cur_h = highest;
17391 for (cur_s = s; cur_s < send; cur_s++, cur_h++) {
17392 if (UNLIKELY(*cur_s == *cur_h)) {
17396 /* If this byte is larger than the corresponding highest UTF-8
17397 * byte, the sequence overflows; otherwise the byte is less
17398 * than (as we handled the equality case above), and so the
17399 * sequence doesn't overflow */
17400 overflows = *cur_s > *cur_h;
17405 /* Here, either we set the bool and broke out of the loop, or got
17406 * to the end and all bytes are the same which indicates it doesn't
17407 * overflow. If it did overflow, it would be this number of bytes
17409 overflow_length = 13;
17413 if (UNLIKELY(overflows)) {
17416 if (! do_warnings && retlen) {
17417 *retlen = overflow_length;
17422 # endif /* < 5.26 */
17424 /* Here, we are either in a release that properly detects overflow, or
17425 * we have checked for overflow and the next statement is executing as
17426 * part of the above conditional where we know we don't have overflow.
17428 * The modern versions allow anything that evaluates to a legal UV, but
17429 * not overlongs nor an empty input */
17430 ret = D_PPP_utf8_to_uvchr_buf_callee(
17431 (U8 *) /* Early perls: no const */
17432 s, curlen, retlen, (UTF8_ALLOW_ANYUV
17433 & ~(UTF8_ALLOW_LONG|UTF8_ALLOW_EMPTY)));
17435 # if (PERL_BCDVERSION >= 0x5026000) && (PERL_BCDVERSION < 0x5028000)
17437 /* But actually, more modern versions restrict the UV to being no more than
17438 * what an IV can hold, so it could still have gotten it wrong about
17440 if (UNLIKELY(ret > IV_MAX)) {
17446 if (UNLIKELY(overflows)) {
17447 if (! do_warnings) {
17449 *retlen = D_PPP_MIN(*retlen, UTF8SKIP(s));
17450 *retlen = D_PPP_MIN(*retlen, curlen);
17452 return UNICODE_REPLACEMENT;
17456 /* We use the error message in use from 5.8-5.26 */
17457 Perl_warner(aTHX_ packWARN(WARN_UTF8),
17458 "Malformed UTF-8 character (overflow at 0x%" UVxf
17459 ", byte 0x%02x, after start byte 0x%02x)",
17462 *retlen = (STRLEN) -1;
17468 /* Here, did not overflow, but if it failed for some other reason, and
17469 * warnings are off, to emulate the behavior of the real utf8_to_uvchr(),
17470 * try again, allowing anything. (Note a return of 0 is ok if the input
17472 if (UNLIKELY(ret == 0 && (curlen == 0 || *s != '\0'))) {
17474 /* If curlen is 0, we already handled the case where warnings are
17475 * disabled, so this 'if' will be true, and so later on, we know that
17476 * 's' is dereferencible */
17479 *retlen = (STRLEN) -1;
17483 ret = D_PPP_utf8_to_uvchr_buf_callee(
17484 (U8 *) /* Early perls: no const */
17485 s, curlen, retlen, UTF8_ALLOW_ANY);
17486 /* Override with the REPLACEMENT character, as that is what the
17487 * modern version of this function returns */
17488 ret = UNICODE_REPLACEMENT;
17490 # if (PERL_BCDVERSION < 0x5016000)
17492 /* Versions earlier than this don't necessarily return the proper
17493 * length. It should not extend past the end of string, nor past
17494 * what the first byte indicates the length is, nor past the
17495 * continuation characters */
17496 if (retlen && (IV) *retlen >= 0) {
17497 unsigned int i = 1;
17499 *retlen = D_PPP_MIN(*retlen, curlen);
17500 *retlen = D_PPP_MIN(*retlen, UTF8SKIP(s));
17502 # ifdef UTF8_IS_CONTINUATION
17503 if (! UTF8_IS_CONTINUATION(s[i]))
17504 # else /* Versions without the above don't support EBCDIC anyway */
17505 if (s[i] < 0x80 || s[i] > 0xBF)
17511 } while (++i < *retlen);
17525 #if defined(UTF8SKIP) && defined(utf8_to_uvchr_buf)
17526 #undef utf8_to_uvchr /* Always redefine this unsafe function so that it refuses
17527 to read past a NUL, making it much less likely to read
17528 off the end of the buffer. A NUL indicates the start
17529 of the next character anyway. If the input isn't
17530 NUL-terminated, the function remains unsafe, as it
17531 always has been. */
17532 #ifndef utf8_to_uvchr
17533 # define utf8_to_uvchr(s, lp) \
17535 ? utf8_to_uvchr_buf(s,((s)+1), lp) /* Handle single NUL specially */ \
17536 : utf8_to_uvchr_buf(s, (s) + UTF8_CHK_SKIP(s), (lp)))
17541 /* Hint: utf8_to_uvchr
17542 Use utf8_to_uvchr_buf() instead. But ONLY if you KNOW the upper bound
17543 of the input string (not resorting to using UTF8SKIP, etc., to infer it).
17544 The backported utf8_to_uvchr() will do a better job to prevent most cases
17545 of trying to read beyond the end of the buffer */
17547 /* Replace utf8_to_uvchr with utf8_to_uvchr_buf */
17550 /* Older Perl versions have broken sv_len_utf8() when passed sv does not have SVf_UTF8 flag set */
17551 /* Also note that SvGETMAGIC() may change presence of SVf_UTF8 flag */
17552 # if (PERL_BCDVERSION < 0x5017005)
17553 # undef sv_len_utf8
17554 # if defined(PERL_USE_GCC_BRACE_GROUPS)
17555 # define sv_len_utf8_nomg(sv) ({ SV *_sv2 = (sv); (SvUTF8(_sv2) ? Perl_sv_len_utf8(aTHX_ (!SvGMAGICAL(_sv2) ? _sv2 : sv_mortalcopy_flags(_sv2, SV_NOSTEAL))) : ({ STRLEN _len; SvPV_nomg(_sv2, _len); _len; })); })
17556 # define sv_len_utf8(sv) ({ SV *_sv1 = (sv); SvGETMAGIC(_sv1); sv_len_utf8_nomg(_sv1); })
17558 # define sv_len_utf8_nomg(sv) (PL_Sv = (sv), (SvUTF8(PL_Sv) ? Perl_sv_len_utf8(aTHX_ (!SvGMAGICAL(PL_Sv) ? PL_Sv : sv_mortalcopy_flags(PL_Sv, SV_NOSTEAL))) : (SvPV_nomg(PL_Sv, PL_na), PL_na)))
17559 # define sv_len_utf8(sv) (PL_Sv = (sv), SvGETMAGIC(PL_Sv), sv_len_utf8_nomg(PL_Sv))
17562 # if defined(PERL_USE_GCC_BRACE_GROUPS)
17563 #ifndef sv_len_utf8_nomg
17564 # define sv_len_utf8_nomg(sv) ({ SV *_sv = (sv); sv_len_utf8(!SvGMAGICAL(_sv) ? _sv : sv_mortalcopy_flags(_sv, SV_NOSTEAL)); })
17568 #ifndef sv_len_utf8_nomg
17569 # define sv_len_utf8_nomg(sv) ((PL_Sv = (sv)), sv_len_utf8(!SvGMAGICAL(PL_Sv) ? PL_Sv : sv_mortalcopy_flags(PL_Sv, SV_NOSTEAL)))
17574 #ifndef PERL_PV_ESCAPE_QUOTE
17575 # define PERL_PV_ESCAPE_QUOTE 0x0001
17578 #ifndef PERL_PV_PRETTY_QUOTE
17579 # define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE
17582 #ifndef PERL_PV_PRETTY_ELLIPSES
17583 # define PERL_PV_PRETTY_ELLIPSES 0x0002
17586 #ifndef PERL_PV_PRETTY_LTGT
17587 # define PERL_PV_PRETTY_LTGT 0x0004
17590 #ifndef PERL_PV_ESCAPE_FIRSTCHAR
17591 # define PERL_PV_ESCAPE_FIRSTCHAR 0x0008
17594 #ifndef PERL_PV_ESCAPE_UNI
17595 # define PERL_PV_ESCAPE_UNI 0x0100
17598 #ifndef PERL_PV_ESCAPE_UNI_DETECT
17599 # define PERL_PV_ESCAPE_UNI_DETECT 0x0200
17602 #ifndef PERL_PV_ESCAPE_ALL
17603 # define PERL_PV_ESCAPE_ALL 0x1000
17606 #ifndef PERL_PV_ESCAPE_NOBACKSLASH
17607 # define PERL_PV_ESCAPE_NOBACKSLASH 0x2000
17610 #ifndef PERL_PV_ESCAPE_NOCLEAR
17611 # define PERL_PV_ESCAPE_NOCLEAR 0x4000
17614 #ifndef PERL_PV_ESCAPE_RE
17615 # define PERL_PV_ESCAPE_RE 0x8000
17618 #ifndef PERL_PV_PRETTY_NOCLEAR
17619 # define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR
17621 #ifndef PERL_PV_PRETTY_DUMP
17622 # define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
17625 #ifndef PERL_PV_PRETTY_REGPROP
17626 # define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE
17630 * Note that unicode functionality is only backported to
17631 * those perl versions that support it. For older perl
17632 * versions, the implementation will fall back to bytes.
17636 #if defined(NEED_pv_escape)
17637 static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags);
17640 extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags);
17643 #if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL)
17648 #define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f)
17649 #define Perl_pv_escape DPPP_(my_pv_escape)
17653 DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str,
17654 const STRLEN count, const STRLEN max,
17655 STRLEN * const escaped, const U32 flags)
17657 const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\';
17658 const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc;
17659 char octbuf[32] =
"%123456789ABCDF";
17662 STRLEN readsize = 1;
17663 #if defined(is_utf8_string) && defined(utf8_to_uvchr_buf)
17666 const char *pv =
str;
17667 const char *
const end = pv + count;
17673 #if defined(is_utf8_string) && defined(utf8_to_uvchr_buf)
17678 for (; pv < end && (!max || wrote < max) ; pv += readsize) {
17680 #if defined(is_utf8_string) && defined(utf8_to_uvchr_buf)
17681 isuni ? utf8_to_uvchr_buf((U8*)pv, end, &readsize) :
17684 const U8
c = (U8)u & 0xFF;
17688 chsize = my_snprintf(octbuf,
sizeof octbuf,
17691 chsize = my_snprintf(octbuf,
sizeof octbuf,
17692 "%cx{%" UVxf "}", esc, u);
17700 case '%' :
if (
c == esc)
17705 case '\v' : octbuf[1] =
'v';
break;
17706 case '\t' : octbuf[1] =
't';
break;
17707 case '\r' : octbuf[1] =
'r';
break;
17708 case '\n' : octbuf[1] =
'n';
break;
17709 case '\f' : octbuf[1] =
'f';
break;
17710 case '"' :
if (dq ==
'"')
17715 default: chsize = my_snprintf(octbuf,
sizeof octbuf,
17716 pv < end &&
isDIGIT((U8)*(pv+readsize))
17717 ?
"%c%03o" :
"%c%o", esc,
c);
17723 if (max && wrote + chsize > max) {
17725 }
else if (chsize > 1) {
17726 sv_catpvn(dsv, octbuf, chsize);
17730 my_snprintf(tmp,
sizeof tmp,
"%c",
c);
17731 sv_catpvn(dsv, tmp, 1);
17737 if (escaped != NULL)
17738 *escaped= pv -
str;
17746 #if defined(NEED_pv_pretty)
17747 static char *
DPPP_(
my_pv_pretty)(
pTHX_ SV * dsv,
char const *
const str,
const STRLEN count,
const STRLEN max,
char const *
const start_color,
char const *
const end_color,
const U32 flags);
17750 extern char *
DPPP_(
my_pv_pretty)(
pTHX_ SV * dsv,
char const *
const str,
const STRLEN count,
const STRLEN max,
char const *
const start_color,
char const *
const end_color,
const U32 flags);
17753 #if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL)
17758 #define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g)
17759 #define Perl_pv_pretty DPPP_(my_pv_pretty)
17764 const STRLEN max,
char const *
const start_color,
char const *
const end_color,
17778 if (start_color != NULL)
17783 if (end_color != NULL)
17801 #if defined(NEED_pv_display)
17808 #if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL)
17813 #define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e)
17814 #define Perl_pv_display DPPP_(my_pv_display)
17829 #if PERL_VERSION_LT(5,27,9)
17830 #ifndef LC_NUMERIC_LOCK
17831 # define LC_NUMERIC_LOCK
17834 #ifndef LC_NUMERIC_UNLOCK
17835 # define LC_NUMERIC_UNLOCK
17838 # if PERL_VERSION_LT(5,19,0)
17839 # undef STORE_LC_NUMERIC_SET_STANDARD
17840 # undef RESTORE_LC_NUMERIC
17841 # undef DECLARATION_FOR_LC_NUMERIC_MANIPULATION
17843 #ifndef DECLARATION_FOR_LC_NUMERIC_MANIPULATION
17844 # define DECLARATION_FOR_LC_NUMERIC_MANIPULATION char *LoC_
17847 #ifndef STORE_NUMERIC_SET_STANDARD
17848 # define STORE_NUMERIC_SET_STANDARD() \
17849 LoC_ = savepv(setlocale(LC_NUMERIC, NULL)); \
17850 SAVEFREEPV(LoC_); \
17851 setlocale(LC_NUMERIC, "C");
17854 #ifndef RESTORE_LC_NUMERIC
17855 # define RESTORE_LC_NUMERIC() \
17856 setlocale(LC_NUMERIC, LoC_);
17860 #ifndef DECLARATION_FOR_LC_NUMERIC_MANIPULATION
17861 # define DECLARATION_FOR_LC_NUMERIC_MANIPULATION
17864 #ifndef STORE_LC_NUMERIC_SET_STANDARD
17865 # define STORE_LC_NUMERIC_SET_STANDARD()
17868 #ifndef RESTORE_LC_NUMERIC
17869 # define RESTORE_LC_NUMERIC()
17876 #ifndef LOCK_NUMERIC_STANDARD
17877 # define LOCK_NUMERIC_STANDARD()
17880 #ifndef UNLOCK_NUMERIC_STANDARD
17881 # define UNLOCK_NUMERIC_STANDARD()
17885 #ifndef LOCK_LC_NUMERIC_STANDARD
17886 # define LOCK_LC_NUMERIC_STANDARD LOCK_NUMERIC_STANDARD
17889 #ifndef UNLOCK_LC_NUMERIC_STANDARD
17890 # define UNLOCK_LC_NUMERIC_STANDARD UNLOCK_NUMERIC_STANDARD
17894 #ifndef switch_to_global_locale
17895 # define switch_to_global_locale()
17903 # if (PERL_BCDVERSION < 0x5027009)
17904 # if (PERL_BCDVERSION >= 0x5021003)
17905 # undef sync_locale
17906 # define sync_locale() (Perl_sync_locale(aTHX), 1)
17907 # elif defined(sync_locale)
17908 # undef sync_locale
17909 # define sync_locale() (new_ctype(setlocale(LC_CTYPE, NULL)), \
17910 new_collate(setlocale(LC_COLLATE, NULL)), \
17911 set_numeric_local(), \
17912 new_numeric(setlocale(LC_NUMERIC, NULL)), \
17914 # elif defined(new_ctype) && defined(LC_CTYPE)
17915 # define sync_locale() (new_ctype(setlocale(LC_CTYPE, NULL)), 1)
17919 #ifndef sync_locale
17920 # define sync_locale() 1
char *DPPP_() my_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
#define PERL_PV_PRETTY_QUOTE
#define D_PPP_CONSTPV_ARG(x)
#define sv_catpvs(sv, str)
#define PERL_PV_ESCAPE_ALL
#define PERL_PV_PRETTY_DUMP
#define PERL_PV_ESCAPE_UNI
#define D_PPP_PERL_SIGNALS_INIT
static CV *DPPP_() my_newCONSTSUB(HV *stash, const char *name, SV *sv)
#define PERL_PV_PRETTY_ELLIPSES
#define PERL_PV_ESCAPE_FIRSTCHAR
#define start_subparse(a, b)
char *DPPP_() my_pv_pretty(pTHX_ SV *dsv, char const *const str, const STRLEN count, const STRLEN max, char const *const start_color, char const *const end_color, const U32 flags)
OP *CPERLscope Perl_check_t(pTHX_ OP *)
#define PERL_PV_PRETTY_LTGT
#define PERL_PV_PRETTY_NOCLEAR
#define PERL_PV_ESCAPE_NOCLEAR
#define PERL_PV_ESCAPE_UNI_DETECT
#define sv_setpvs(sv, str)
#define PERL_PV_ESCAPE_NOBACKSLASH
OP *CPERLscope Perl_ppaddr_t(pTHX)