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))
11314# define dTHXa(x) dNOOP
11341#if (PERL_BCDVERSION < 0x5006000)
11344# define aTHXR_ thr,
11352# define aTHXR_ aTHX_
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)
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)
11545# define PERL_QUAD_MIN ((long long)MINLONGLONG)
11547# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
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
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
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
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)
11814static yy_parser
DPPP_(dummy_PL_parser);
11815#elif defined(NEED_PL_parser_GLOBAL)
11816yy_parser
DPPP_(dummy_PL_parser);
11818extern 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)
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)
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
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
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)(
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)
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))
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)
12635# undef isALPHANUMERIC
12636# undef isALPHANUMERIC_A
12637# undef isALPHANUMERIC_L1
12658# undef isIDFIRST_L1
12678# undef isWORDCHAR_A
12679# undef isWORDCHAR_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)
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)
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)
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)
12895# define isIDCONT_L1(c) isWORDCHAR_L1(c)
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)
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'))
13013# define isXDIGIT_L1(c) isXDIGIT(c)
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)
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]))
13686# define C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a))
13689# define LIKELY(x) (x)
13693# define UNLIKELY(x) (x)
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)
13745static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...);
13748extern 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)
13757DPPP_(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)
13772static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * const sv, const char * const pat, ...);
13775extern 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)
13785DPPP_(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)
13818static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...);
13821extern 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)
13830DPPP_(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)
13845static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * const sv, const char * const pat, ...);
13848extern 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)
13858DPPP_(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)))
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), "")
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
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
14199# define WARN_REGEXP 20
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
14219# define WARN_MALLOC 25
14223# define WARN_SIGNAL 26
14227# define WARN_SUBSTR 27
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
14255# define WARN_PRINTF 34
14258#ifndef WARN_PROTOTYPE
14259# define WARN_PROTOTYPE 35
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
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)
14370static void DPPP_(my_warner)(U32 err, const char * pat, ...);
14373extern 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)
14382DPPP_(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)
14399static void DPPP_(my_ck_warner)(pTHX_ U32 err, const char * pat, ...);
14402extern 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)
14411DPPP_(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)
14434static void DPPP_(my_ck_warner_d)(pTHX_ U32 err, const char * pat, ...);
14437extern 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)
14446DPPP_(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)) )
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)
14577static Size_t DPPP_(my_my_strnlen)(const char * str, Size_t maxlen);
14580extern 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)
14590DPPP_(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)
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)
14720static OP * DPPP_(my_die_sv)(pTHX_ SV * baseex);
14723extern 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)
14735DPPP_(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)
14753static SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args);
14756extern 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)
14769DPPP_(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)
14783static SV * DPPP_(my_mess_nocontext)(const char * pat, ...);
14786extern 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)
14795DPPP_(my_mess_nocontext)(const char* pat, ...)
14800 va_start(args, pat);
14801 sv = vmess(pat, &args);
14809#if defined(NEED_mess)
14810static SV * DPPP_(my_mess)(pTHX_ const char * pat, ...);
14813extern SV * DPPP_(my_mess)(pTHX_ const char * pat, ...);
14816#if defined(NEED_mess) || defined(NEED_mess_GLOBAL)
14818#define Perl_mess DPPP_(my_mess)
14821DPPP_(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)
14840static SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume);
14843extern 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)
14855DPPP_(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)
14906static void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params);
14909extern 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)
14921DPPP_(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))
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
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)
15103static SV * DPPP_(my_eval_pv)(const char * p, I32 croak_on_error);
15106extern 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)
15119DPPP_(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)
15142static void DPPP_(my_vload_module)(U32 flags, SV * name, SV * ver, va_list * args);
15145extern 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)
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)
15158DPPP_(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;
15212#if defined(NEED_load_module)
15213static void DPPP_(my_load_module)(U32 flags, SV * name, SV * ver, ...);
15216extern void DPPP_(my_load_module)(U32 flags, SV * name, SV * ver, ...);
15219#if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL)
15224#define load_module DPPP_(my_load_module)
15225#define Perl_load_module DPPP_(my_load_module)
15229DPPP_(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 */
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)
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)))
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)
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
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
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)
15642static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char * s, I32 len, U32 hash);
15645extern 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)
15658DPPP_(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)
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)
15752# define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt)
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
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)))
15817# define SvTRUE_nomg(sv) (!SvGMAGICAL((sv)) ? SvTRUE((sv)) : SvTRUEx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
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); \
15839# define sv_catsv_mg(dsv, ssv) \
15841 SV *TeMpSv = dsv; \
15842 sv_catsv(TeMpSv,ssv); \
15843 SvSETMAGIC(TeMpSv); \
15848# define sv_setiv_mg(sv, i) \
15851 sv_setiv(TeMpSv,i); \
15852 SvSETMAGIC(TeMpSv); \
15857# define sv_setnv_mg(sv, num) \
15860 sv_setnv(TeMpSv,num); \
15861 SvSETMAGIC(TeMpSv); \
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); \
15884# define sv_setsv_mg(dsv, ssv) \
15886 SV *TeMpSv = dsv; \
15887 sv_setsv(TeMpSv,ssv); \
15888 SvSETMAGIC(TeMpSv); \
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)
15956static MAGIC * DPPP_(my_mg_findext)(const SV * sv, int type, const MGVTBL * vtbl);
15959extern 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)
15969DPPP_(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)
15991static int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl);
15994extern 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)
16007DPPP_(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;
16052# define CopFILE(c) ((c)->cop_file)
16056# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv)
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)
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))
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))
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)
16145DPPP_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)
16165static const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 level, const PERL_CONTEXT * * dbcxp);
16168extern 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)
16180const PERL_CONTEXT *
16181DPPP_(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)
16283static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char * * sp, const char * send);
16286extern 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)
16298DPPP_(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
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 == '.') {
16339#if defined(NEED_grok_number)
16340static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
16343extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
16346#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL)
16351#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c)
16352#define Perl_grok_number DPPP_(my_grok_number)
16355DPPP_(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)
16555static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
16558extern 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)
16570DPPP_(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)
16658static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
16661extern 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)
16673DPPP_(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)
16761static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
16764extern 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)
16776DPPP_(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)
16855static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
16858extern 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)
16868DPPP_(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)
16890static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...);
16893extern 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 */
16908DPPP_(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)
16938static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size);
16941extern 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)
16951DPPP_(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)
16969static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size);
16972extern 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)
16982DPPP_(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 */
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)
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)
17328static UV DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 * s, const U8 * send, STRLEN * retlen);
17331extern 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)
17344DPPP_(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)
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)
17637static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags);
17640extern 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)
17653DPPP_(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)
17747static 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);
17750extern 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)
17906# define sync_locale() (Perl_sync_locale(aTHX), 1)
17907# elif defined(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)
17920# define sync_locale() 1
#define PERL_PV_PRETTY_QUOTE
#define D_PPP_CONSTPV_ARG(x)
#define sv_catpvs(sv, str)
#define PERL_PV_ESCAPE_ALL
OP *CPERLscope Perl_ppaddr_t(pTHX)
#define PERL_PV_PRETTY_DUMP
#define PERL_PV_ESCAPE_UNI
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)
#define D_PPP_PERL_SIGNALS_INIT
char *DPPP_() my_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
OP *CPERLscope Perl_check_t(pTHX_ OP *)
#define PERL_PV_PRETTY_ELLIPSES
#define PERL_PV_ESCAPE_FIRSTCHAR
#define start_subparse(a, b)
#define PERL_PV_PRETTY_LTGT
#define PERL_PV_PRETTY_NOCLEAR
#define PERL_PV_ESCAPE_NOCLEAR
#define PERL_PV_ESCAPE_UNI_DETECT
static CV *DPPP_() my_newCONSTSUB(HV *stash, const char *name, SV *sv)
#define sv_setpvs(sv, str)
#define PERL_PV_ESCAPE_NOBACKSLASH