X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a02a5408b2f199007c4dcb74559cc79066307ada..ac56e7de46621c6f2e373d11984c0a0fe4839b0b:/handy.h diff --git a/handy.h b/handy.h index d0366c3..bbeb1ff 100644 --- a/handy.h +++ b/handy.h @@ -1,7 +1,7 @@ /* handy.h * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1999, - * 2000, 2001, 2002, 2004, 2005 by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1999, 2000, + * 2001, 2002, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -19,23 +19,25 @@ #endif #endif -#define Null(type) ((type)NULL) +#ifndef PERL_CORE +# define Null(type) ((type)NULL) /* =head1 Handy Values -=for apidoc AmU||Nullch -Null character pointer. +=for apidoc AmU||Nullch +Null character pointer. (No longer available when C is defined.) =for apidoc AmU||Nullsv -Null SV pointer. +Null SV pointer. (No longer available when C is defined.) =cut */ -#define Nullch Null(char*) -#define Nullfp Null(PerlIO*) -#define Nullsv Null(SV*) +# define Nullch Null(char*) +# define Nullfp Null(PerlIO*) +# define Nullsv Null(SV*) +#endif #ifdef TRUE #undef TRUE @@ -46,6 +48,27 @@ Null SV pointer. #define TRUE (1) #define FALSE (0) +/* The MUTABLE_*() macros cast pointers to the types shown, in such a way + * (compiler permitting) that casting away const-ness will give a warning; + * e.g.: + * + * const SV *sv = ...; + * AV *av1 = (AV*)sv; <== BAD: the const has been silently cast away + * AV *av2 = MUTABLE_AV(sv); <== GOOD: it may warn + */ + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +# define MUTABLE_PTR(p) ({ void *_p = (p); _p; }) +#else +# define MUTABLE_PTR(p) ((void *) (p)) +#endif + +#define MUTABLE_AV(p) ((AV *)MUTABLE_PTR(p)) +#define MUTABLE_CV(p) ((CV *)MUTABLE_PTR(p)) +#define MUTABLE_GV(p) ((GV *)MUTABLE_PTR(p)) +#define MUTABLE_HV(p) ((HV *)MUTABLE_PTR(p)) +#define MUTABLE_IO(p) ((IO *)MUTABLE_PTR(p)) +#define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p)) /* XXX Configure ought to have a test for a boolean type, if I can just figure out all the headers such a test needs. @@ -59,7 +82,7 @@ Null SV pointer. g++ can be identified by __GNUG__. Andy Dougherty February 2000 */ -#ifdef __GNUG__ /* GNU g++ has bool built-in */ +#ifdef __GNUG__ /* GNU g++ has bool built-in */ # ifndef HAS_BOOL # define HAS_BOOL 1 # endif @@ -87,6 +110,27 @@ Null SV pointer. # define HAS_BOOL 1 #endif +/* a simple (bool) cast may not do the right thing: if bool is defined + * as char for example, then the cast from int is implementation-defined + */ + +#define cBOOL(cbool) ((bool)!!(cbool)) + +/* Try to figure out __func__ or __FUNCTION__ equivalent, if any. + * XXX Should really be a Configure probe, with HAS__FUNCTION__ + * and FUNCTION__ as results. + * XXX Similarly, a Configure probe for __FILE__ and __LINE__ is needed. */ +#if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || (defined(__SUNPRO_C)) /* C99 or close enough. */ +# define FUNCTION__ __func__ +#else +# if (defined(_MSC_VER) && _MSC_VER < 1300) || /* Pre-MSVC 7.0 has neither __func__ nor __FUNCTION and no good workarounds, either. */ \ + (defined(__DECC_VER)) /* Tru64 or VMS, and strict C89 being used, but not modern enough cc (in Tur64, -c99 not known, only -std1). */ +# define FUNCTION__ "" +# else +# define FUNCTION__ __FUNCTION__ /* Common extension. */ +# endif +#endif + /* XXX A note on the perl source internal type system. The original intent was that I32 be *exactly* 32 bits. @@ -107,11 +151,11 @@ Null SV pointer. For dealing with issues that may arise from various 32/64-bit systems, we will ask Configure to check out - SHORTSIZE == sizeof(short) - INTSIZE == sizeof(int) - LONGSIZE == sizeof(long) + SHORTSIZE == sizeof(short) + INTSIZE == sizeof(int) + LONGSIZE == sizeof(long) LONGLONGSIZE == sizeof(long long) (if HAS_LONG_LONG) - PTRSIZE == sizeof(void *) + PTRSIZE == sizeof(void *) DOUBLESIZE == sizeof(double) LONG_DOUBLESIZE == sizeof(long double) (if HAS_LONG_DOUBLE). @@ -152,17 +196,27 @@ typedef U64TYPE U64; # define INT64_C(c) CAT2(c,L) # define UINT64_C(c) CAT2(c,UL) # else -# define INT64_C(c) ((I64TYPE)(c)) -# define UINT64_C(c) ((U64TYPE)(c)) +# if defined(_WIN64) && defined(_MSC_VER) +# define INT64_C(c) CAT2(c,I64) +# define UINT64_C(c) CAT2(c,UI64) +# else +# define INT64_C(c) ((I64TYPE)(c)) +# define UINT64_C(c) ((U64TYPE)(c)) +# endif # endif # endif # endif #endif -/* HMB H.Merijn Brand - a placeholder for preparing Configure patches */ -#if defined(LIBM_LIB_VERSION) -/* Not (yet) used at top level, but mention them for metaconfig */ -#endif +/* HMB H.Merijn Brand - a placeholder for preparing Configure patches: + * + * USE_DTRACE HAS_PSEUDOFORK HAS_TIMEGM LOCALTIME_R_NEEDS_TZSET + * GMTIME_MAX GMTIME_MIN LOCALTIME_MAX LOCALTIME_MIN + * HAS_CTIME64 HAS_LOCALTIME64 HAS_GMTIME64 HAS_DIFFTIME64 + * HAS_MKTIME64 HAS_ASCTIME64 HAS_GETADDRINFO HAS_GETNAMEINFO + * HAS_INETNTOP HAS_INETPTON CHARBITS HAS_PRCTL + * Not (yet) used at top level, but mention them for metaconfig + */ /* Mention I8SIZE, U8SIZE, I16SIZE, U16SIZE, I32SIZE, U32SIZE, I64SIZE, and U64SIZE here so that metaconfig pulls them in. */ @@ -222,6 +276,87 @@ typedef U64TYPE U64; #define Ctl(ch) ((ch) & 037) /* +=head1 SV-Body Allocation + +=for apidoc Ama|SV*|newSVpvs|const char* s +Like C, but takes a literal string instead of a string/length pair. + +=for apidoc Ama|SV*|newSVpvs_flags|const char* s|U32 flags +Like C, but takes a literal string instead of a string/length +pair. + +=for apidoc Ama|SV*|newSVpvs_share|const char* s +Like C, but takes a literal string instead of a string/length +pair and omits the hash parameter. + +=for apidoc Am|void|sv_catpvs|SV* sv|const char* s +Like C, but takes a literal string instead of a string/length pair. + +=for apidoc Am|void|sv_setpvs|SV* sv|const char* s +Like C, but takes a literal string instead of a string/length pair. + +=head1 Memory Management + +=for apidoc Ama|char*|savepvs|const char* s +Like C, but takes a literal string instead of a string/length pair. + +=head1 GV Functions + +=for apidoc Am|HV*|gv_stashpvs|const char* name|I32 create +Like C, but takes a literal string instead of a string/length pair. + +=head1 Hash Manipulation Functions + +=for apidoc Am|SV**|hv_fetchs|HV* tb|const char* key|I32 lval +Like C, but takes a literal string instead of a string/length pair. + +=for apidoc Am|SV**|hv_stores|HV* tb|const char* key|NULLOK SV* val +Like C, but takes a literal string instead of a string/length pair +and omits the hash parameter. + +=head1 Lexer interface + +=for apidoc Amx|void|lex_stuff_pvs|const char *pv|U32 flags + +Like L, but takes a literal string instead of a +string/length pair. + +=cut +*/ + +/* concatenating with "" ensures that only literal strings are accepted as argument */ +#define STR_WITH_LEN(s) ("" s ""), (sizeof(s)-1) + +/* note that STR_WITH_LEN() can't be used as argument to macros or functions that + * under some configurations might be macros, which means that it requires the full + * Perl_xxx(aTHX_ ...) form for any API calls where it's used. + */ + +/* STR_WITH_LEN() shortcuts */ +#define newSVpvs(str) Perl_newSVpvn(aTHX_ STR_WITH_LEN(str)) +#define newSVpvs_flags(str,flags) \ + Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN(str), flags) +#define newSVpvs_share(str) Perl_newSVpvn_share(aTHX_ STR_WITH_LEN(str), 0) +#define sv_catpvs(sv, str) Perl_sv_catpvn_flags(aTHX_ sv, STR_WITH_LEN(str), SV_GMAGIC) +#define sv_setpvs(sv, str) Perl_sv_setpvn(aTHX_ sv, STR_WITH_LEN(str)) +#define savepvs(str) Perl_savepvn(aTHX_ STR_WITH_LEN(str)) +#define gv_stashpvs(str, create) Perl_gv_stashpvn(aTHX_ STR_WITH_LEN(str), create) +#define gv_fetchpvs(namebeg, add, sv_type) Perl_gv_fetchpvn_flags(aTHX_ STR_WITH_LEN(namebeg), add, sv_type) +#define hv_fetchs(hv,key,lval) \ + ((SV **)Perl_hv_common(aTHX_ (hv), NULL, STR_WITH_LEN(key), 0, \ + (lval) ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) \ + : HV_FETCH_JUST_SV, NULL, 0)) + +#define hv_stores(hv,key,val) \ + ((SV **)Perl_hv_common(aTHX_ (hv), NULL, STR_WITH_LEN(key), 0, \ + (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), (val), 0)) + +#define lex_stuff_pvs(pv,flags) Perl_lex_stuff_pvn(aTHX_ STR_WITH_LEN(pv), flags) + +#define get_cvs(str, flags) \ + Perl_get_cvn_flags(aTHX_ STR_WITH_LEN(str), (flags)) + +/* =head1 Miscellaneous Functions =for apidoc Am|bool|strNE|char* s1|char* s2 @@ -277,6 +412,10 @@ C). # define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) #endif +#define memEQs(s1, l, s2) \ + (sizeof(s2)-1 == l && memEQ(s1, ("" s2 ""), (sizeof(s2)-1))) +#define memNEs(s1, l, s2) !memEQs(s1, l, s2) + /* * Character classes. * @@ -301,40 +440,63 @@ C). =head1 Character classes =for apidoc Am|bool|isALNUM|char ch -Returns a boolean indicating whether the C C is an ASCII alphanumeric -character (including underscore) or digit. +Returns a boolean indicating whether the C C is a US-ASCII (Basic Latin) +alphanumeric character (including underscore) or digit. =for apidoc Am|bool|isALPHA|char ch -Returns a boolean indicating whether the C C is an ASCII alphabetic -character. +Returns a boolean indicating whether the C C is a US-ASCII (Basic Latin) +alphabetic character. =for apidoc Am|bool|isSPACE|char ch -Returns a boolean indicating whether the C C is whitespace. +Returns a boolean indicating whether the C C is a US-ASCII (Basic Latin) +whitespace. =for apidoc Am|bool|isDIGIT|char ch -Returns a boolean indicating whether the C C is an ASCII +Returns a boolean indicating whether the C C is a US-ASCII (Basic Latin) digit. =for apidoc Am|bool|isUPPER|char ch -Returns a boolean indicating whether the C C is an uppercase -character. +Returns a boolean indicating whether the C C is a US-ASCII (Basic Latin) +uppercase character. =for apidoc Am|bool|isLOWER|char ch -Returns a boolean indicating whether the C C is a lowercase -character. +Returns a boolean indicating whether the C C is a US-ASCII (Basic Latin) +lowercase character. =for apidoc Am|char|toUPPER|char ch -Converts the specified character to uppercase. +Converts the specified character to uppercase. Characters outside the +US-ASCII (Basic Latin) range are viewed as not having any case. =for apidoc Am|char|toLOWER|char ch -Converts the specified character to lowercase. +Converts the specified character to lowercase. Characters outside the +US-ASCII (Basic Latin) range are viewed as not having any case. =cut + +NOTE: Since some of these are macros, there is no check in those that the +parameter is a char or U8. This means that if called with a larger width +parameter, casts can silently truncate and yield wrong results. + +Also note that these macros are repeated in Devel::PPPort, so should also be +patched there. The file as of this writing is cpan/Devel-PPPort/parts/inc/misc + */ #define isALNUM(c) (isALPHA(c) || isDIGIT(c) || (c) == '_') #define isIDFIRST(c) (isALPHA(c) || (c) == '_') #define isALPHA(c) (isUPPER(c) || isLOWER(c)) +/* ALPHAU includes Unicode semantics for latin1 characters. It has an extra + * >= AA test to speed up ASCII-only tests at the expense of the others */ +#define isALPHAU(c) (isALPHA(c) || (NATIVE_TO_UNI((U8) c) >= 0xAA \ + && ((NATIVE_TO_UNI((U8) c) >= 0xC0 \ + && NATIVE_TO_UNI((U8) c) != 0xD7 && NATIVE_TO_UNI((U8) c) != 0xF7) \ + || NATIVE_TO_UNI((U8) c) == 0xAA \ + || NATIVE_TO_UNI((U8) c) == 0xB5 \ + || NATIVE_TO_UNI((U8) c) == 0xBA))) +#define isALNUMU(c) (isDIGIT(c) || isALPHAU(c) || (c) == '_') + +/* continuation character for legal NAME in \N{NAME} */ +#define isCHARNAME_CONT(c) (isALNUMU(c) || (c) == ' ' || (c) == '-' || (c) == '(' || (c) == ')' || (c) == ':' || NATIVE_TO_UNI((U8) c) == 0xA0) #define isSPACE(c) \ ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) =='\r' || (c) == '\f') #define isPSXSPC(c) (isSPACE(c) || (c) == '\v') @@ -352,17 +514,28 @@ Converts the specified character to lowercase. # define isPUNCT(c) ispunct(c) # define isXDIGIT(c) isxdigit(c) # define toUPPER(c) toupper(c) +# define toUPPER_LATIN1_MOD(c) UNI_TO_NATIVE(PL_mod_latin1_uc[(U8) NATIVE_TO_UNI(c)]) # define toLOWER(c) tolower(c) +# define toLOWER_LATIN1(c) UNI_TO_NATIVE(PL_latin1_lc[(U8) NATIVE_TO_UNI(c)]) #else # define isUPPER(c) ((c) >= 'A' && (c) <= 'Z') # define isLOWER(c) ((c) >= 'a' && (c) <= 'z') # define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) -# define isASCII(c) ((c) <= 127) -# define isCNTRL(c) ((c) < ' ' || (c) == 127) +# define isASCII(c) ((U8) (c) <= 127) +# define isCNTRL(c) ((U8) (c) < ' ' || (c) == 127) # define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) -# define isPRINT(c) (((c) > 32 && (c) < 127) || (c) == ' ') +# define isPRINT(c) (((c) >= 32 && (c) < 127)) # define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) # define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) + +/* Use table lookup for speed */ +# define toLOWER_LATIN1(c) (PL_latin1_lc[(U8) c]) + +/* Modified uc. Is correct uc except for three non-ascii chars which are + * all mapped to one of them, and these need special handling */ +# define toUPPER_LATIN1_MOD(c) (PL_mod_latin1_uc[(U8) c]) + +/* ASCII casing. */ # define toUPPER(c) (isLOWER(c) ? (c) - ('a' - 'A') : (c)) # define toLOWER(c) (isUPPER(c) ? (c) + ('a' - 'A') : (c)) #endif @@ -407,7 +580,7 @@ Converts the specified character to lowercase. # else -# define isALNUM_LC(c) (isascii(c) && (isalnum(c) || (c) == '_')) +# define isALNUM_LC(c) (isascii(c) && (isalnum(c) || (c) == '_')) # define isIDFIRST_LC(c) (isascii(c) && (isalpha(c) || (c) == '_')) # define isALPHA_LC(c) (isascii(c) && isalpha(c)) # define isSPACE_LC(c) (isascii(c) && isspace(c)) @@ -435,7 +608,6 @@ Converts the specified character to lowercase. #define isDIGIT_uni(c) is_uni_digit(c) #define isUPPER_uni(c) is_uni_upper(c) #define isLOWER_uni(c) is_uni_lower(c) -#define isALNUMC_uni(c) is_uni_alnumc(c) #define isASCII_uni(c) is_uni_ascii(c) #define isCNTRL_uni(c) is_uni_cntrl(c) #define isGRAPH_uni(c) is_uni_graph(c) @@ -457,7 +629,6 @@ Converts the specified character to lowercase. #define isDIGIT_LC_uvchr(c) (c < 256 ? isDIGIT_LC(c) : is_uni_digit_lc(c)) #define isUPPER_LC_uvchr(c) (c < 256 ? isUPPER_LC(c) : is_uni_upper_lc(c)) #define isLOWER_LC_uvchr(c) (c < 256 ? isLOWER_LC(c) : is_uni_lower_lc(c)) -#define isALNUMC_LC_uvchr(c) (c < 256 ? isALNUMC_LC(c) : is_uni_alnumc_lc(c)) #define isCNTRL_LC_uvchr(c) (c < 256 ? isCNTRL_LC(c) : is_uni_cntrl_lc(c)) #define isGRAPH_LC_uvchr(c) (c < 256 ? isGRAPH_LC(c) : is_uni_graph_lc(c)) #define isPRINT_LC_uvchr(c) (c < 256 ? isPRINT_LC(c) : is_uni_print_lc(c)) @@ -476,7 +647,6 @@ Converts the specified character to lowercase. #define isDIGIT_utf8(p) is_utf8_digit(p) #define isUPPER_utf8(p) is_utf8_upper(p) #define isLOWER_utf8(p) is_utf8_lower(p) -#define isALNUMC_utf8(p) is_utf8_alnumc(p) #define isASCII_utf8(p) is_utf8_ascii(p) #define isCNTRL_utf8(p) is_utf8_cntrl(p) #define isGRAPH_utf8(p) is_utf8_graph(p) @@ -506,49 +676,46 @@ Converts the specified character to lowercase. #define isPSXSPC_LC_utf8(c) (isSPACE_LC_utf8(c) ||(c) == '\f') #define isBLANK_LC_utf8(c) isBLANK(c) /* could be wrong */ -#ifdef EBCDIC -# ifdef PERL_IMPLICIT_CONTEXT -# define toCTRL(c) Perl_ebcdic_control(aTHX_ c) -# else -# define toCTRL Perl_ebcdic_control -# endif -#else - /* This conversion works both ways, strangely enough. */ -# define toCTRL(c) (toUPPER(c) ^ 64) -#endif +/* This conversion works both ways, strangely enough. On EBCDIC platforms, + * CTRL-@ is 0, CTRL-A is 1, etc, just like on ASCII */ +# define toCTRL(c) (toUPPER(NATIVE_TO_UNI(c)) ^ 64) /* Line numbers are unsigned, 32 bits. */ typedef U32 line_t; #define NOLINE ((line_t) 4294967295UL) +/* Helpful alias for version prescan */ +#define is_LAX_VERSION(a,b) \ + (a != Perl_prescan_version(aTHX_ a, FALSE, b, NULL, NULL, NULL, NULL)) -/* -=head1 SV Manipulation Functions +#define is_STRICT_VERSION(a,b) \ + (a != Perl_prescan_version(aTHX_ a, TRUE, b, NULL, NULL, NULL, NULL)) -=for apidoc Am|SV*|NEWSV|int id|STRLEN len -Creates a new SV. A non-zero C parameter indicates the number of -bytes of preallocated string space the SV should have. An extra byte for a -tailing NUL is also reserved. (SvPOK is not set for the SV even if string -space is allocated.) The reference count for the new SV is set to 1. -C is an integer id between 0 and 1299 (used to identify leaks). +#define BADVERSION(a,b,c) \ + if (b) { \ + *b = c; \ + } \ + return a; +/* =head1 Memory Management =for apidoc Am|void|Newx|void* ptr|int nitems|type The XSUB-writer's interface to the C C function. +In 5.9.3, Newx() and friends replace the older New() API, and drops +the first parameter, I, a debug aid which allowed callers to identify +themselves. This aid has been superseded by a new build option, +PERL_MEM_LOG (see L). The older API is still +there for use in XS modules supporting older perls. + =for apidoc Am|void|Newxc|void* ptr|int nitems|type|cast The XSUB-writer's interface to the C C function, with -cast. +cast. See also C. =for apidoc Am|void|Newxz|void* ptr|int nitems|type The XSUB-writer's interface to the C C function. The allocated -memory is zeroed with C. - -In 5.9.3, we removed the 1st parameter, a debug aid, from the api. It -was used to uniquely identify each usage of these allocation -functions, but was deemed unnecessary with the availability of better -memory tracking tools, valgrind for example. +memory is zeroed with C. See also C. =for apidoc Am|void|Renew|void* ptr|int nitems|type The XSUB-writer's interface to the C C function. @@ -592,25 +759,42 @@ optimise. =for apidoc Am|void|StructCopy|type src|type dest|type This is an architecture-independent macro to copy one structure to another. +=for apidoc Am|void|PoisonWith|void* dest|int nitems|type|U8 byte + +Fill up memory with a byte pattern (a byte repeated over and over +again) that hopefully catches attempts to access uninitialized memory. + +=for apidoc Am|void|PoisonNew|void* dest|int nitems|type + +PoisonWith(0xAB) for catching access to allocated but uninitialized memory. + +=for apidoc Am|void|PoisonFree|void* dest|int nitems|type + +PoisonWith(0xEF) for catching access to freed memory. + =for apidoc Am|void|Poison|void* dest|int nitems|type -Fill up memory with a pattern (byte 0xAB over and over again) that -hopefully catches attempts to access uninitialized memory. +PoisonWith(0xEF) for catching access to freed memory. =cut */ +/* Maintained for backwards-compatibility only. Use newSV() instead. */ +#ifndef PERL_CORE #define NEWSV(x,len) newSV(len) +#endif +#define MEM_SIZE_MAX ((MEM_SIZE)~0) + +/* The +0.0 in MEM_WRAP_CHECK_ is an attempt to foil + * overly eager compilers that will bleat about e.g. + * (U16)n > (size_t)~0/sizeof(U16) always being false. */ #ifdef PERL_MALLOC_WRAP -#define MEM_WRAP_CHECK(n,t) \ - (void)((sizeof(t)>1?n:1)>((MEM_SIZE)~0)/sizeof(t)?(Perl_croak_nocontext(PL_memory_wrap),0):0) +#define MEM_WRAP_CHECK(n,t) MEM_WRAP_CHECK_1(n,t,PL_memory_wrap) #define MEM_WRAP_CHECK_1(n,t,a) \ - (void)((n)>((MEM_SIZE)~0)/sizeof(t)?(Perl_croak_nocontext(a),0):0) -#define MEM_WRAP_CHECK_2(n,t,a,b) \ - (void)((n)>((MEM_SIZE)~0)/sizeof(t)?(Perl_croak_nocontext(a,b),0):0) + (void)(sizeof(t) > 1 && ((MEM_SIZE)(n)+0.0) > MEM_SIZE_MAX/sizeof(t) && (Perl_croak_nocontext("%s",(a)),0)) #define MEM_WRAP_CHECK_(n,t) MEM_WRAP_CHECK(n,t), -#define PERL_STRLEN_ROUNDUP(n) ((void)(((n) > (MEM_SIZE)~0 - 2 * PERL_STRLEN_ROUNDUP_QUANTUM) ? (Perl_croak_nocontext(PL_memory_wrap),0):0),((n-1+PERL_STRLEN_ROUNDUP_QUANTUM)&~((MEM_SIZE)PERL_STRLEN_ROUNDUP_QUANTUM-1))) +#define PERL_STRLEN_ROUNDUP(n) ((void)(((n) > MEM_SIZE_MAX - 2 * PERL_STRLEN_ROUNDUP_QUANTUM) ? (Perl_croak_nocontext("%s",PL_memory_wrap),0):0),((n-1+PERL_STRLEN_ROUNDUP_QUANTUM)&~((MEM_SIZE)PERL_STRLEN_ROUNDUP_QUANTUM-1))) #else @@ -623,25 +807,100 @@ hopefully catches attempts to access uninitialized memory. #endif -#define Newx(v,n,t) (v = (MEM_WRAP_CHECK_(n,t) (t*)safemalloc((MEM_SIZE)((n)*sizeof(t))))) -#define Newxc(v,n,t,c) (v = (MEM_WRAP_CHECK_(n,t) (c*)safemalloc((MEM_SIZE)((n)*sizeof(t))))) -#define Newxz(v,n,t) (v = (MEM_WRAP_CHECK_(n,t) (t*)safemalloc((MEM_SIZE)((n)*sizeof(t))))), \ - memzero((char*)(v), (n)*sizeof(t)) +#ifdef PERL_MEM_LOG +/* + * If PERL_MEM_LOG is defined, all Newx()s, Renew()s, and Safefree()s + * go through functions, which are handy for debugging breakpoints, but + * which more importantly get the immediate calling environment (file and + * line number, and C function name if available) passed in. This info can + * then be used for logging the calls, for which one gets a sample + * implementation unless -DPERL_MEM_LOG_NOIMPL is also defined. + * + * Known problems: + * - not all memory allocs get logged, only those + * that go through Newx() and derivatives (while all + * Safefrees do get logged) + * - __FILE__ and __LINE__ do not work everywhere + * - __func__ or __FUNCTION__ even less so + * - I think more goes on after the perlio frees but + * the thing is that STDERR gets closed (as do all + * the file descriptors) + * - no deeper calling stack than the caller of the Newx() + * or the kind, but do I look like a C reflection/introspection + * utility to you? + * - the function prototypes for the logging functions + * probably should maybe be somewhere else than handy.h + * - one could consider inlining (macrofying) the logging + * for speed, but I am too lazy + * - one could imagine recording the allocations in a hash, + * (keyed by the allocation address?), and maintain that + * through reallocs and frees, but how to do that without + * any News() happening...? + * - lots of -Ddefines to get useful/controllable output + * - lots of ENV reads + */ + +PERL_EXPORT_C Malloc_t Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname); + +PERL_EXPORT_C Malloc_t Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname); + +PERL_EXPORT_C Malloc_t Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname); + +# ifdef PERL_CORE +# ifndef PERL_MEM_LOG_NOIMPL +enum mem_log_type { + MLT_ALLOC, + MLT_REALLOC, + MLT_FREE, + MLT_NEW_SV, + MLT_DEL_SV +}; +# endif +# if defined(PERL_IN_SV_C) /* those are only used in sv.c */ +void Perl_mem_log_new_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname); +void Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname); +# endif +# endif + +#endif + +#ifdef PERL_MEM_LOG +#define MEM_LOG_ALLOC(n,t,a) Perl_mem_log_alloc(n,sizeof(t),STRINGIFY(t),a,__FILE__,__LINE__,FUNCTION__) +#define MEM_LOG_REALLOC(n,t,v,a) Perl_mem_log_realloc(n,sizeof(t),STRINGIFY(t),v,a,__FILE__,__LINE__,FUNCTION__) +#define MEM_LOG_FREE(a) Perl_mem_log_free(a,__FILE__,__LINE__,FUNCTION__) +#endif + +#ifndef MEM_LOG_ALLOC +#define MEM_LOG_ALLOC(n,t,a) (a) +#endif +#ifndef MEM_LOG_REALLOC +#define MEM_LOG_REALLOC(n,t,v,a) (a) +#endif +#ifndef MEM_LOG_FREE +#define MEM_LOG_FREE(a) (a) +#endif + +#define Newx(v,n,t) (v = (MEM_WRAP_CHECK_(n,t) (t*)MEM_LOG_ALLOC(n,t,safemalloc((MEM_SIZE)((n)*sizeof(t)))))) +#define Newxc(v,n,t,c) (v = (MEM_WRAP_CHECK_(n,t) (c*)MEM_LOG_ALLOC(n,t,safemalloc((MEM_SIZE)((n)*sizeof(t)))))) +#define Newxz(v,n,t) (v = (MEM_WRAP_CHECK_(n,t) (t*)MEM_LOG_ALLOC(n,t,safecalloc((n),sizeof(t))))) + +#ifndef PERL_CORE /* pre 5.9.x compatibility */ #define New(x,v,n,t) Newx(v,n,t) #define Newc(x,v,n,t,c) Newxc(v,n,t,c) -#define Newc(x,v,n,t,c) Newxc(v,n,t,c) +#define Newz(x,v,n,t) Newxz(v,n,t) +#endif #define Renew(v,n,t) \ - (v = (MEM_WRAP_CHECK_(n,t) (t*)saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t))))) + (v = (MEM_WRAP_CHECK_(n,t) (t*)MEM_LOG_REALLOC(n,t,v,saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))))) #define Renewc(v,n,t,c) \ - (v = (MEM_WRAP_CHECK_(n,t) (c*)saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t))))) + (v = (MEM_WRAP_CHECK_(n,t) (c*)MEM_LOG_REALLOC(n,t,v,saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))))) #ifdef PERL_POISON #define Safefree(d) \ - ((d) ? (void)(safefree((Malloc_t)(d)), Poison(&(d), 1, Malloc_t)) : (void) 0) + ((d) ? (void)(safefree(MEM_LOG_FREE((Malloc_t)(d))), Poison(&(d), 1, Malloc_t)) : (void) 0) #else -#define Safefree(d) safefree((Malloc_t)(d)) +#define Safefree(d) safefree(MEM_LOG_FREE((Malloc_t)(d))) #endif #define Move(s,d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memmove((char*)(d),(const char*)(s), (n) * sizeof(t))) @@ -657,7 +916,10 @@ hopefully catches attempts to access uninitialized memory. #define ZeroD(d,n,t) (MEM_WRAP_CHECK_(n,t) memzero((char*)(d), (n) * sizeof(t)),d) #endif -#define Poison(d,n,t) (MEM_WRAP_CHECK_(n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t))) +#define PoisonWith(d,n,t,b) (MEM_WRAP_CHECK_(n,t) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t))) +#define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) +#define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) +#define Poison(d,n,t) PoisonFree(d,n,t) #ifdef USE_STRUCT_COPY #define StructCopy(s,d,t) (*((t*)(d)) = *((t*)(s))) @@ -666,6 +928,7 @@ hopefully catches attempts to access uninitialized memory. #endif #define C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0])) +#define C_ARRAY_END(a) (a) + (sizeof(a)/sizeof((a)[0])) #ifdef NEED_VA_COPY # ifdef va_copy @@ -688,10 +951,27 @@ hopefully catches attempts to access uninitialized memory. #define pTHX__VALUE_ ,(void *)my_perl, #define pTHX__VALUE ,(void *)my_perl #else -#define pTHX_FORMAT +#define pTHX_FORMAT #define pTHX__FORMAT -#define pTHX_VALUE_ +#define pTHX_VALUE_ #define pTHX_VALUE -#define pTHX__VALUE_ +#define pTHX__VALUE_ #define pTHX__VALUE #endif /* USE_ITHREADS */ + +/* Perl_deprecate was not part of the public API, and did not have a deprecate() + shortcut macro defined without -DPERL_CORE. Neither codesearch.google.com nor + CPAN::Unpack show any users outside the core. */ +#ifdef PERL_CORE +# define deprecate(s) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "Use of " s " is deprecated") +#endif + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */