use cBOOL for bool casts

[perl5.git] / handy.h

diff --git a/handy.h b/handy.h
index 69ee8d3..ebe523f 100644 (file)
--- a/handy.h
+++ b/handy.h
@@ -1,7 +1,7 @@
 /*    handy.h
  *
 /*    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.
  *
  *    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
 
 #endif
 #endif
 

-#define Null(type) ((type)NULL)
+#ifndef PERL_CORE
+#  define Null(type) ((type)NULL)

 
 /*
 =head1 Handy Values
 
 =for apidoc AmU||Nullch
 
 /*
 =head1 Handy Values
 
 =for apidoc AmU||Nullch

-Null character pointer.
+Null character pointer. (No longer available when C<PERL_CORE> is defined.)

 
 =for apidoc AmU||Nullsv
 
 =for apidoc AmU||Nullsv

-Null SV pointer.
+Null SV pointer. (No longer available when C<PERL_CORE> is defined.)

 
 =cut
 */
 
 
 =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
 
 #ifdef TRUE
 #undef TRUE


@@ -46,6 +48,27 @@ Null SV pointer.
 #define TRUE (1)
 #define FALSE (0)
 
 #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.
 
 /* XXX Configure ought to have a test for a boolean type, if I can
    just figure out all the headers such a test needs.


@@ -87,6 +110,12 @@ Null SV pointer.
 # define HAS_BOOL 1
 #endif
 
 # 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.
 /* Try to figure out __func__ or __FUNCTION__ equivalent, if any.
  * XXX Should really be a Configure probe, with HAS__FUNCTION__
  *     and FUNCTION__ as results.


@@ -167,17 +196,28 @@ typedef U64TYPE U64;
 #               define INT64_C(c)      CAT2(c,L)
 #               define UINT64_C(c)     CAT2(c,UL)
 #           else
 #               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
 
 #           endif
 #       endif
 #   endif
 #endif
 

-/* HMB H.Merijn Brand - a placeholder for preparing Configure patches */
-#if defined(HAS_MALLOC_SIZE) && defined(HAS_MALLOC_GOOD_SIZE)
-/* 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_SET_NAME
+ * 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. */
 
 /* Mention I8SIZE, U8SIZE, I16SIZE, U16SIZE, I32SIZE, U32SIZE,
    I64SIZE, and U64SIZE here so that metaconfig pulls them in. */


@@ -237,6 +277,78 @@ typedef U64TYPE U64;
 #define Ctl(ch) ((ch) & 037)
 
 /*
 #define Ctl(ch) ((ch) & 037)
 
 /*

+=head1 SV-Body Allocation
+
+=for apidoc Ama|SV*|newSVpvs|const char* s
+Like C<newSVpvn>, but takes a literal string instead of a string/length pair.
+
+=for apidoc Ama|SV*|newSVpvs_flags|const char* s|U32 flags
+Like C<newSVpvn_flags>, but takes a literal string instead of a string/length
+pair.
+
+=for apidoc Ama|SV*|newSVpvs_share|const char* s
+Like C<newSVpvn_share>, 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<sv_catpvn>, but takes a literal string instead of a string/length pair.
+
+=for apidoc Am|void|sv_setpvs|SV* sv|const char* s
+Like C<sv_setpvn>, but takes a literal string instead of a string/length pair.
+
+=head1 Memory Management
+
+=for apidoc Ama|char*|savepvs|const char* s
+Like C<savepvn>, 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<gv_stashpvn>, 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<hv_fetch>, 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<hv_store>, but takes a literal string instead of a string/length pair
+and omits the hash parameter.
+
+=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 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
 =head1 Miscellaneous Functions
 
 =for apidoc Am|bool|strNE|char* s1|char* s2


@@ -292,6 +404,10 @@ C<strncmp>).
 #  define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
 #endif
 
 #  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.
  *
 /*
  * Character classes.
  *


@@ -316,33 +432,36 @@ C<strncmp>).
 =head1 Character classes
 
 =for apidoc Am|bool|isALNUM|char ch
 =head1 Character classes
 
 =for apidoc Am|bool|isALNUM|char ch

-Returns a boolean indicating whether the C C<char> is an ASCII alphanumeric
-character (including underscore) or digit.
+Returns a boolean indicating whether the C C<char> is a US-ASCII (Basic Latin)
+alphanumeric character (including underscore) or digit.

 
 =for apidoc Am|bool|isALPHA|char ch
 
 =for apidoc Am|bool|isALPHA|char ch

-Returns a boolean indicating whether the C C<char> is an ASCII alphabetic
-character.
+Returns a boolean indicating whether the C C<char> is a US-ASCII (Basic Latin)
+alphabetic character.

 
 =for apidoc Am|bool|isSPACE|char ch
 
 =for apidoc Am|bool|isSPACE|char ch

-Returns a boolean indicating whether the C C<char> is whitespace.
+Returns a boolean indicating whether the C C<char> is a US-ASCII (Basic Latin)
+whitespace.

 
 =for apidoc Am|bool|isDIGIT|char ch
 
 =for apidoc Am|bool|isDIGIT|char ch

-Returns a boolean indicating whether the C C<char> is an ASCII
+Returns a boolean indicating whether the C C<char> is a US-ASCII (Basic Latin)

 digit.
 
 =for apidoc Am|bool|isUPPER|char ch
 digit.
 
 =for apidoc Am|bool|isUPPER|char ch

-Returns a boolean indicating whether the C C<char> is an uppercase
-character.
+Returns a boolean indicating whether the C C<char> is a US-ASCII (Basic Latin)
+uppercase character.

 
 =for apidoc Am|bool|isLOWER|char ch
 
 =for apidoc Am|bool|isLOWER|char ch

-Returns a boolean indicating whether the C C<char> is a lowercase
-character.
+Returns a boolean indicating whether the C C<char> is a US-ASCII (Basic Latin)
+lowercase character.

 
 =for apidoc Am|char|toUPPER|char ch
 
 =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
 
 =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
 */
 
 =cut
 */


@@ -350,6 +469,18 @@ Converts the specified character to lowercase.
 #define isALNUM(c)     (isALPHA(c) || isDIGIT(c) || (c) == '_')
 #define isIDFIRST(c)   (isALPHA(c) || (c) == '_')
 #define isALPHA(c)     (isUPPER(c) || isLOWER(c))
 #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')
 #define isSPACE(c) \
        ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) =='\r' || (c) == '\f')
 #define isPSXSPC(c)    (isSPACE(c) || (c) == '\v')


@@ -367,7 +498,9 @@ Converts the specified character to lowercase.
 #   define isPUNCT(c)  ispunct(c)
 #   define isXDIGIT(c) isxdigit(c)
 #   define toUPPER(c)  toupper(c)
 #   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(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')
 #else
 #   define isUPPER(c)  ((c) >= 'A' && (c) <= 'Z')
 #   define isLOWER(c)  ((c) >= 'a' && (c) <= 'z')


@@ -375,9 +508,18 @@ Converts the specified character to lowercase.
 #   define isASCII(c)  ((c) <= 127)
 #   define isCNTRL(c)  ((c) < ' ' || (c) == 127)
 #   define isGRAPH(c)  (isALNUM(c) || isPUNCT(c))
 #   define isASCII(c)  ((c) <= 127)
 #   define isCNTRL(c)  ((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'))
 #   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
 #   define toUPPER(c)  (isLOWER(c) ? (c) - ('a' - 'A') : (c))
 #   define toLOWER(c)  (isUPPER(c) ? (c) + ('a' - 'A') : (c))
 #endif


@@ -450,7 +592,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 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)
 #define isASCII_uni(c)         is_uni_ascii(c)
 #define isCNTRL_uni(c)         is_uni_cntrl(c)
 #define isGRAPH_uni(c)         is_uni_graph(c)


@@ -472,7 +613,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 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))
 #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))


@@ -491,7 +631,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 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)
 #define isASCII_utf8(p)                is_utf8_ascii(p)
 #define isCNTRL_utf8(p)                is_utf8_cntrl(p)
 #define isGRAPH_utf8(p)                is_utf8_graph(p)


@@ -536,17 +675,20 @@ Converts the specified character to lowercase.
 typedef U32 line_t;
 #define NOLINE ((line_t) 4294967295UL)
 
 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<len> 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<id> 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
 =head1 Memory Management
 
 =for apidoc Am|void|Newx|void* ptr|int nitems|type


@@ -554,7 +696,7 @@ The XSUB-writer's interface to the C C<malloc> function.
 
 In 5.9.3, Newx() and friends replace the older New() API, and drops
 the first parameter, I<x>, a debug aid which allowed callers to identify
 
 In 5.9.3, Newx() and friends replace the older New() API, and drops
 the first parameter, I<x>, a debug aid which allowed callers to identify

-themselves.  This aid has been superceded by a new build option,
+themselves.  This aid has been superseded by a new build option,

 PERL_MEM_LOG (see L<perlhack/PERL_MEM_LOG>).  The older API is still
 there for use in XS modules supporting older perls.
 
 PERL_MEM_LOG (see L<perlhack/PERL_MEM_LOG>).  The older API is still
 there for use in XS modules supporting older perls.
 


@@ -608,25 +750,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|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
 
 =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 */
 
 
 =cut */
 

+/* Maintained for backwards-compatibility only. Use newSV() instead. */
+#ifndef PERL_CORE

 #define NEWSV(x,len)   newSV(len)
 #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
 #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) \
 #define MEM_WRAP_CHECK_1(n,t,a) \

-       (void)((sizeof(t)>1?(n):1)>((MEM_SIZE)~0)/sizeof(t)?(Perl_croak_nocontext(a),0):0)
-#define MEM_WRAP_CHECK_2(n,t,a,b) \
-       (void)((sizeof(t)>1?(n):1)>((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 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
 
 
 #else
 


@@ -646,12 +805,12 @@ hopefully catches attempts to access uninitialized memory.
  * 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
  * 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 if PERL_MEM_LOG_STDERR is defined.
+ * implementation unless -DPERL_MEM_LOG_NOIMPL is also defined.

  *
  * Known problems:
  *
  * Known problems:

- * - all memory allocs do not get logged, only those
+ * - not all memory allocs get logged, only those

  *   that go through Newx() and derivatives (while all
  *   that go through Newx() and derivatives (while all

- *  Safefrees do get logged)
+ *   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
  * - __FILE__ and __LINE__ do not work everywhere
  * - __func__ or __FUNCTION__ even less so
  * - I think more goes on after the perlio frees but


@@ -668,13 +827,31 @@ hopefully catches attempts to access uninitialized memory.
  *   (keyed by the allocation address?), and maintain that
  *   through reallocs and frees, but how to do that without
  *   any News() happening...?
  *   (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

  */
 
  */
 

-Malloc_t Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname);
+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);

 
 

-Malloc_t Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, 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);

 
 

-Malloc_t Perl_mem_log_free(Malloc_t oldalloc, 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
 
 
 #endif
 


@@ -694,10 +871,9 @@ Malloc_t Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int li
 #define MEM_LOG_FREE(a)          (a)
 #endif
 
 #define MEM_LOG_FREE(a)          (a)
 #endif
 

-#define Newx(v,n,t)    (v = (MEM_WRAP_CHECK_(n,t) MEM_LOG_ALLOC(n,t,(t*)safemalloc((MEM_SIZE)((n)*sizeof(t))))))
-#define Newxc(v,n,t,c) (v = (MEM_WRAP_CHECK_(n,t) MEM_LOG_ALLOC(n,t,(c*)safemalloc((MEM_SIZE)((n)*sizeof(t))))))
-#define Newxz(v,n,t)   (v = (MEM_WRAP_CHECK_(n,t) MEM_LOG_ALLOC(n,t,(t*)safemalloc((MEM_SIZE)((n)*sizeof(t)))))), \
-                       memzero((char*)(v), (n)*sizeof(t))
+#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 */
 
 #ifndef PERL_CORE
 /* pre 5.9.x compatibility */


@@ -707,13 +883,13 @@ Malloc_t Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int li
 #endif
 
 #define Renew(v,n,t) \
 #endif
 
 #define Renew(v,n,t) \

-         (v = (MEM_WRAP_CHECK_(n,t) MEM_LOG_REALLOC(n,t,v,(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) \
 #define Renewc(v,n,t,c) \

-         (v = (MEM_WRAP_CHECK_(n,t) MEM_LOG_REALLOC(n,t,v,(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) \
 
 #ifdef PERL_POISON
 #define Safefree(d) \

-  ((d) ? (void)(safefree(MEM_LOG_FREE((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(MEM_LOG_FREE((Malloc_t)(d)))
 #endif
 #else
 #define Safefree(d)    safefree(MEM_LOG_FREE((Malloc_t)(d)))
 #endif


@@ -731,7 +907,10 @@ Malloc_t Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int li
 #define ZeroD(d,n,t)   (MEM_WRAP_CHECK_(n,t) memzero((char*)(d), (n) * sizeof(t)),d)
 #endif
 
 #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)))
 
 #ifdef USE_STRUCT_COPY
 #define StructCopy(s,d,t) (*((t*)(d)) = *((t*)(s)))


@@ -770,3 +949,19 @@ Malloc_t Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int li
 #define pTHX__VALUE
 #endif /* USE_ITHREADS */
 
 #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:
+ */