X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=b72f263dc5775de75f23598a8b95108b7d393af7;hb=fb35b2c24f8da5fb8fa1a50fbab1868d072191db;hp=f670bb8baa3d14a0bfa049ebdbe9572e28689157;hpb=19a94d75aea23d860dc398284bf0810d3e2bbfa2;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/util.c b/util.c
index f670bb8..b72f263 100644
--- a/util.c
+++ b/util.c
@@ -1,7 +1,7 @@
 /*    util.c
  *
- *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
+ *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+ *    2002, 2003, 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.
@@ -9,8 +9,10 @@
  */
 
 /*
- * "Very useful, no doubt, that was to Saruman; yet it seems that he was
- * not content."  --Gandalf
+ * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
+ *  not content.'                                    --Gandalf to Pippin
+ *
+ *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
  */
 
 /* This file contains assorted utility routines.
@@ -178,11 +180,11 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     ptr = (Malloc_t)PerlMem_realloc(where,size);
     PERL_ALLOC_CHECK(ptr);
 
-    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
-    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
-
-    if (ptr != NULL) {
+    /* MUST do this fixup first, before doing ANYTHING else, as anything else
+       might allocate memory/free/move memory, and until we do the fixup, it
+       may well be chasing (and writing to) free memory.  */
 #ifdef PERL_TRACK_MEMPOOL
+    if (ptr != NULL) {
 	struct perl_memory_debug_header *const header
 	    = (struct perl_memory_debug_header *)ptr;
 
@@ -198,7 +200,17 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 	header->prev->next = header;
 
         ptr = (Malloc_t)((char*)ptr+sTHX);
+    }
 #endif
+
+    /* In particular, must do that fixup above before logging anything via
+     *printf(), as it can reallocate memory, which can cause SEGVs.  */
+
+    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
+    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
+
+
+    if (ptr != NULL) {
 	return ptr;
     }
     else if (PL_nomemok)
@@ -264,12 +276,12 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
     if (size && (count <= MEM_SIZE_MAX / size))
 	total_size = size * count;
     else
-	Perl_croak_nocontext(PL_memory_wrap);
+	Perl_croak_nocontext("%s", PL_memory_wrap);
 #ifdef PERL_TRACK_MEMPOOL
     if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
 	total_size += sTHX;
     else
-	Perl_croak_nocontext(PL_memory_wrap);
+	Perl_croak_nocontext("%s", PL_memory_wrap);
 #endif
 #ifdef HAS_64K_LIMIT
     if (total_size > 0xffff) {
@@ -357,10 +369,11 @@ Free_t   Perl_mfree (Malloc_t where)
 /* copy a string up to some (non-backslashed) delimiter, if any */
 
 char *
-Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
+Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
 {
     register I32 tolen;
-    PERL_UNUSED_CONTEXT;
+
+    PERL_ARGS_ASSERT_DELIMCPY;
 
     for (tolen = 0; from < fromend; from++, tolen++) {
 	if (*from == '\\') {
@@ -386,10 +399,11 @@ Perl_delimcpy(pTHX_ register char *to, register const char *toend, register cons
 /* This routine was donated by Corey Satten. */
 
 char *
-Perl_instr(pTHX_ register const char *big, register const char *little)
+Perl_instr(register const char *big, register const char *little)
 {
     register I32 first;
-    PERL_UNUSED_CONTEXT;
+
+    PERL_ARGS_ASSERT_INSTR;
 
     if (!little)
 	return (char*)big;
@@ -419,15 +433,15 @@ Perl_instr(pTHX_ register const char *big, register const char *little)
 /* same as instr but allow embedded nulls */
 
 char *
-Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
+Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
 {
-    PERL_UNUSED_CONTEXT;
+    PERL_ARGS_ASSERT_NINSTR;
     if (little >= lend)
         return (char*)big;
     {
-        char first = *little++;
+        const char first = *little;
         const char *s, *x;
-        bigend -= lend - little;
+        bigend -= lend - little++;
     OUTER:
         while (big <= bigend) {
             if (*big++ == first) {
@@ -445,12 +459,13 @@ Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const
 /* reverse of the above--find last substring */
 
 char *
-Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
+Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
 {
     register const char *bigbeg;
     register const I32 first = *little;
     register const char * const littleend = lend;
-    PERL_UNUSED_CONTEXT;
+
+    PERL_ARGS_ASSERT_RNINSTR;
 
     if (little >= littleend)
 	return (char*)bigend;
@@ -501,6 +516,8 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
     U32 rarest = 0;
     U32 frequency = 256;
 
+    PERL_ARGS_ASSERT_FBM_COMPILE;
+
     if (flags & FBMcf_TAIL) {
 	MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
 	sv_catpvs(sv, "\n");		/* Taken into account in fbm_instr() */
@@ -578,6 +595,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
     register STRLEN littlelen = l;
     register const I32 multiline = flags & FBMrf_MULTILINE;
 
+    PERL_ARGS_ASSERT_FBM_INSTR;
+
     if ((STRLEN)(bigend - big) < littlelen) {
 	if ( SvTAIL(littlestr)
 	     && ((STRLEN)(bigend - big) == littlelen - 1)
@@ -781,6 +800,8 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
     register const unsigned char *littleend;
     I32 found = 0;
 
+    PERL_ARGS_ASSERT_SCREAMINSTR;
+
     assert(SvTYPE(littlestr) == SVt_PVGV);
     assert(SvVALID(littlestr));
 
@@ -858,11 +879,12 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
 }
 
 I32
-Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_ibcmp(const char *s1, const char *s2, register I32 len)
 {
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
-    PERL_UNUSED_CONTEXT;
+
+    PERL_ARGS_ASSERT_IBCMP;
 
     while (len--) {
 	if (*a != *b && *a != PL_fold[*b])
@@ -873,12 +895,13 @@ Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
 }
 
 I32
-Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_ibcmp_locale(const char *s1, const char *s2, register I32 len)
 {
     dVAR;
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
-    PERL_UNUSED_CONTEXT;
+
+    PERL_ARGS_ASSERT_IBCMP_LOCALE;
 
     while (len--) {
 	if (*a != *b && *a != PL_fold_locale[*b])
@@ -985,7 +1008,9 @@ char *
 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
 {
     char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
-    assert(pv);
+
+    PERL_ARGS_ASSERT_SAVESHAREDPVN;
+
     if (!newaddr) {
 	return write_no_mem();
     }
@@ -1009,6 +1034,8 @@ Perl_savesvpv(pTHX_ SV *sv)
     const char * const pv = SvPV_const(sv, len);
     register char *newaddr;
 
+    PERL_ARGS_ASSERT_SAVESVPV;
+
     ++len;
     Newx(newaddr,len,char);
     return (char *) CopyD(pv,newaddr,len,char);
@@ -1025,7 +1052,7 @@ S_mess_alloc(pTHX)
     XPVMG *any;
 
     if (!PL_dirty)
-	return sv_2mortal(newSVpvs(""));
+	return newSVpvs_flags("", SVs_TEMP);
 
     if (PL_mess_sv)
 	return PL_mess_sv;
@@ -1048,6 +1075,7 @@ Perl_form_nocontext(const char* pat, ...)
     dTHX;
     char *retval;
     va_list args;
+    PERL_ARGS_ASSERT_FORM_NOCONTEXT;
     va_start(args, pat);
     retval = vform(pat, &args);
     va_end(args);
@@ -1080,6 +1108,7 @@ Perl_form(pTHX_ const char* pat, ...)
 {
     char *retval;
     va_list args;
+    PERL_ARGS_ASSERT_FORM;
     va_start(args, pat);
     retval = vform(pat, &args);
     va_end(args);
@@ -1090,6 +1119,7 @@ char *
 Perl_vform(pTHX_ const char *pat, va_list *args)
 {
     SV * const sv = mess_alloc();
+    PERL_ARGS_ASSERT_VFORM;
     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     return SvPVX(sv);
 }
@@ -1101,6 +1131,7 @@ Perl_mess_nocontext(const char *pat, ...)
     dTHX;
     SV *retval;
     va_list args;
+    PERL_ARGS_ASSERT_MESS_NOCONTEXT;
     va_start(args, pat);
     retval = vmess(pat, &args);
     va_end(args);
@@ -1113,6 +1144,7 @@ Perl_mess(pTHX_ const char *pat, ...)
 {
     SV *retval;
     va_list args;
+    PERL_ARGS_ASSERT_MESS;
     va_start(args, pat);
     retval = vmess(pat, &args);
     va_end(args);
@@ -1125,6 +1157,8 @@ S_closest_cop(pTHX_ const COP *cop, const OP *o)
     dVAR;
     /* Look for PL_op starting from o.  cop is the last COP we've seen. */
 
+    PERL_ARGS_ASSERT_CLOSEST_COP;
+
     if (!o || o == PL_op)
 	return cop;
 
@@ -1158,6 +1192,8 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
     dVAR;
     SV * const sv = mess_alloc();
 
+    PERL_ARGS_ASSERT_VMESS;
+
     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
 	/*
@@ -1199,9 +1235,11 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
     IO *io;
     MAGIC *mg;
 
+    PERL_ARGS_ASSERT_WRITE_TO_STDERR;
+
     if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
 	&& (io = GvIO(PL_stderrgv))
-	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 
+	&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 
     {
 	dSP;
 	ENTER;
@@ -1215,8 +1253,8 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
 
 	PUSHMARK(SP);
 	EXTEND(SP,2);
-	PUSHs(SvTIED_obj((SV*)io, mg));
-	PUSHs(sv_2mortal(newSVpvn(message, msglen)));
+	PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
+	mPUSHp(message, msglen);
 	PUTBACK;
 	call_method("PRINT", G_SCALAR);
 
@@ -1227,14 +1265,14 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
     else {
 #ifdef USE_SFIO
 	/* SFIO can really mess with your errno */
-	const int e = errno;
+	dSAVED_ERRNO;
 #endif
 	PerlIO * const serr = Perl_error_log;
 
 	PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
 	(void)PerlIO_flush(serr);
 #ifdef USE_SFIO
-	errno = e;
+	RESTORE_ERRNO;
 #endif
     }
 }
@@ -1270,8 +1308,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
 	    *hook = NULL;
 	}
 	if (warn || message) {
-	    msg = newSVpvn(message, msglen);
-	    SvFLAGS(msg) |= utf8;
+	    msg = newSVpvn_flags(message, msglen, utf8);
 	    SvREADONLY_on(msg);
 	    SAVEFREESV(msg);
 	}
@@ -1283,7 +1320,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
 	PUSHMARK(SP);
 	XPUSHs(msg);
 	PUTBACK;
-	call_sv((SV*)cv, G_DISCARD);
+	call_sv(MUTABLE_SV(cv), G_DISCARD);
 	POPSTACK;
 	LEAVE;
 	return TRUE;
@@ -1313,17 +1350,14 @@ S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
 	message = NULL;
     }
 
-    DEBUG_S(PerlIO_printf(Perl_debug_log,
-			  "%p: die/croak: message = %s\ndiehook = %p\n",
-			  (void*)thr, message, (void*)PL_diehook));
     if (PL_diehook) {
 	S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
     }
     return message;
 }
 
-OP *
-Perl_vdie(pTHX_ const char* pat, va_list *args)
+static OP *
+S_vdie(pTHX_ const char* pat, va_list *args)
 {
     dVAR;
     const char *message;
@@ -1331,17 +1365,10 @@ Perl_vdie(pTHX_ const char* pat, va_list *args)
     STRLEN msglen;
     I32 utf8 = 0;
 
-    DEBUG_S(PerlIO_printf(Perl_debug_log,
-			  "%p: die: curstack = %p, mainstack = %p\n",
-			  (void*)thr, (void*)PL_curstack, (void*)PL_mainstack));
-
     message = vdie_croak_common(pat, args, &msglen, &utf8);
 
     PL_restartop = die_where(message, msglen);
     SvFLAGS(ERRSV) |= utf8;
-    DEBUG_S(PerlIO_printf(Perl_debug_log,
-	  "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
-	  (void*)thr, (void*)PL_restartop, was_in_eval, (void*)PL_top_env));
     if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
 	JMPENV_JUMP(3);
     return PL_restartop;
@@ -1420,7 +1447,7 @@ sidestepping the normal C order of execution. See C<warn>.
 If you want to throw an exception object, assign the object to
 C<$@> and then pass C<NULL> to croak():
 
-   errsv = get_sv("@", TRUE);
+   errsv = get_sv("@", GV_ADD);
    sv_setsv(errsv, exception_object);
    croak(NULL);
 
@@ -1446,6 +1473,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
     const I32 utf8 = SvUTF8(msv);
     const char * const message = SvPV_const(msv, msglen);
 
+    PERL_ARGS_ASSERT_VWARN;
+
     if (PL_warnhook) {
 	if (vdie_common(message, msglen, utf8, TRUE))
 	    return;
@@ -1460,6 +1489,7 @@ Perl_warn_nocontext(const char *pat, ...)
 {
     dTHX;
     va_list args;
+    PERL_ARGS_ASSERT_WARN_NOCONTEXT;
     va_start(args, pat);
     vwarn(pat, &args);
     va_end(args);
@@ -1479,6 +1509,7 @@ void
 Perl_warn(pTHX_ const char *pat, ...)
 {
     va_list args;
+    PERL_ARGS_ASSERT_WARN;
     va_start(args, pat);
     vwarn(pat, &args);
     va_end(args);
@@ -1490,6 +1521,7 @@ Perl_warner_nocontext(U32 err, const char *pat, ...)
 {
     dTHX; 
     va_list args;
+    PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
     va_start(args, pat);
     vwarner(err, pat, &args);
     va_end(args);
@@ -1497,9 +1529,36 @@ Perl_warner_nocontext(U32 err, const char *pat, ...)
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 void
+Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
+{
+    PERL_ARGS_ASSERT_CK_WARNER_D;
+
+    if (Perl_ckwarn_d(aTHX_ err)) {
+	va_list args;
+	va_start(args, pat);
+	vwarner(err, pat, &args);
+	va_end(args);
+    }
+}
+
+void
+Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
+{
+    PERL_ARGS_ASSERT_CK_WARNER;
+
+    if (Perl_ckwarn(aTHX_ err)) {
+	va_list args;
+	va_start(args, pat);
+	vwarner(err, pat, &args);
+	va_end(args);
+    }
+}
+
+void
 Perl_warner(pTHX_ U32  err, const char* pat,...)
 {
     va_list args;
+    PERL_ARGS_ASSERT_WARNER;
     va_start(args, pat);
     vwarner(err, pat, &args);
     va_end(args);
@@ -1509,6 +1568,7 @@ void
 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 {
     dVAR;
+    PERL_ARGS_ASSERT_VWARNER;
     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
 	SV * const msv = vmess(pat, args);
 	STRLEN msglen;
@@ -1538,26 +1598,11 @@ bool
 Perl_ckwarn(pTHX_ U32 w)
 {
     dVAR;
-    return
-	(
-	       isLEXWARN_on
-	    && PL_curcop->cop_warnings != pWARN_NONE
-	    && (
-		   PL_curcop->cop_warnings == pWARN_ALL
-		|| isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
-		|| (unpackWARN2(w) &&
-		     isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
-		|| (unpackWARN3(w) &&
-		     isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
-		|| (unpackWARN4(w) &&
-		     isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
-		)
-	)
-	||
-	(
-	    isLEXWARN_off && PL_dowarn & G_WARN_ON
-	)
-	;
+    /* If lexical warnings have not been set, use $^W.  */
+    if (isLEXWARN_off)
+	return PL_dowarn & G_WARN_ON;
+
+    return ckwarn_common(w);
 }
 
 /* implements the ckWARN?_d macro */
@@ -1566,22 +1611,42 @@ bool
 Perl_ckwarn_d(pTHX_ U32 w)
 {
     dVAR;
-    return
-	   isLEXWARN_off
-	|| PL_curcop->cop_warnings == pWARN_ALL
-	|| (
-	      PL_curcop->cop_warnings != pWARN_NONE 
-	   && (
-		   isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
-	      || (unpackWARN2(w) &&
-		   isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
-	      || (unpackWARN3(w) &&
-		   isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
-	      || (unpackWARN4(w) &&
-		   isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
-	      )
-	   )
-	;
+    /* If lexical warnings have not been set then default classes warn.  */
+    if (isLEXWARN_off)
+	return TRUE;
+
+    return ckwarn_common(w);
+}
+
+static bool
+S_ckwarn_common(pTHX_ U32 w)
+{
+    if (PL_curcop->cop_warnings == pWARN_ALL)
+	return TRUE;
+
+    if (PL_curcop->cop_warnings == pWARN_NONE)
+	return FALSE;
+
+    /* Check the assumption that at least the first slot is non-zero.  */
+    assert(unpackWARN1(w));
+
+    /* Check the assumption that it is valid to stop as soon as a zero slot is
+       seen.  */
+    if (!unpackWARN2(w)) {
+	assert(!unpackWARN3(w));
+	assert(!unpackWARN4(w));
+    } else if (!unpackWARN3(w)) {
+	assert(!unpackWARN4(w));
+    }
+	
+    /* Right, dealt with all the special cases, which are implemented as non-
+       pointers, so there is a pointer to a real warnings mask.  */
+    do {
+	if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
+	    return TRUE;
+    } while (w >>= WARNshift);
+
+    return FALSE;
 }
 
 /* Set buffer=NULL to get a new one.  */
@@ -1590,6 +1655,7 @@ Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
 			   STRLEN size) {
     const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
     PERL_UNUSED_CONTEXT;
+    PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
 
     buffer = (STRLEN*)
 	(specialWARN(buffer) ?
@@ -1625,9 +1691,16 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
 #ifndef PERL_USE_SAFE_PUTENV
     if (!PL_use_safe_putenv) {
     /* most putenv()s leak, so we manipulate environ directly */
-    register I32 i=setenv_getix(nam);          /* where does it go? */
+    register I32 i;
+    register const I32 len = strlen(nam);
     int nlen, vlen;
 
+    /* where does it go? */
+    for (i = 0; environ[i]; i++) {
+        if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
+            break;
+    }
+
     if (environ == PL_origenviron) {   /* need we copy environment? */
        I32 j;
        I32 max;
@@ -1731,28 +1804,6 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
 
 #endif /* WIN32 || NETWARE */
 
-#ifndef PERL_MICRO
-I32
-Perl_setenv_getix(pTHX_ const char *nam)
-{
-    register I32 i;
-    register const I32 len = strlen(nam);
-    PERL_UNUSED_CONTEXT;
-
-    for (i = 0; environ[i]; i++) {
-	if (
-#ifdef WIN32
-	    strnicmp(environ[i],nam,len) == 0
-#else
-	    strnEQ(environ[i],nam,len)
-#endif
-	    && environ[i][len] == '=')
-	    break;			/* strnEQ must come first to avoid */
-    }					/* potential SEGV's */
-    return i;
-}
-#endif /* !PERL_MICRO */
-
 #endif /* !VMS && !EPOC*/
 
 #ifdef UNLINK_ALL_VERSIONS
@@ -1761,6 +1812,8 @@ Perl_unlnk(pTHX_ const char *f)	/* unlink all versions of a file */
 {
     I32 retries = 0;
 
+    PERL_ARGS_ASSERT_UNLNK;
+
     while (PerlLIO_unlink(f) >= 0)
 	retries++;
     return retries ? 0 : -1;
@@ -1774,6 +1827,8 @@ Perl_my_bcopy(register const char *from,register char *to,register I32 len)
 {
     char * const retval = to;
 
+    PERL_ARGS_ASSERT_MY_BCOPY;
+
     if (from - to >= 0) {
 	while (len--)
 	    *to++ = *from++;
@@ -1795,6 +1850,8 @@ Perl_my_memset(register char *loc, register I32 ch, register I32 len)
 {
     char * const retval = loc;
 
+    PERL_ARGS_ASSERT_MY_MEMSET;
+
     while (len--)
 	*loc++ = ch;
     return retval;
@@ -1808,6 +1865,8 @@ Perl_my_bzero(register char *loc, register I32 len)
 {
     char * const retval = loc;
 
+    PERL_ARGS_ASSERT_MY_BZERO;
+
     while (len--)
 	*loc++ = 0;
     return retval;
@@ -1823,6 +1882,8 @@ Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
     register const U8 *b = (const U8 *)s2;
     register I32 tmp;
 
+    PERL_ARGS_ASSERT_MY_MEMCMP;
+
     while (len--) {
         if ((tmp = *a++ - *b++))
 	    return tmp;
@@ -1832,24 +1893,51 @@ Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
 
 #ifndef HAS_VPRINTF
+/* This vsprintf replacement should generally never get used, since
+   vsprintf was available in both System V and BSD 2.11.  (There may
+   be some cross-compilation or embedded set-ups where it is needed,
+   however.)
+
+   If you encounter a problem in this function, it's probably a symptom
+   that Configure failed to detect your system's vprintf() function.
+   See the section on "item vsprintf" in the INSTALL file.
+
+   This version may compile on systems with BSD-ish <stdio.h>,
+   but probably won't on others.
+*/
 
 #ifdef USE_CHAR_VSPRINTF
 char *
 #else
 int
 #endif
-vsprintf(char *dest, const char *pat, char *args)
+vsprintf(char *dest, const char *pat, void *args)
 {
     FILE fakebuf;
 
+#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
+    FILE_ptr(&fakebuf) = (STDCHAR *) dest;
+    FILE_cnt(&fakebuf) = 32767;
+#else
+    /* These probably won't compile -- If you really need
+       this, you'll have to figure out some other method. */
     fakebuf._ptr = dest;
     fakebuf._cnt = 32767;
+#endif
 #ifndef _IOSTRG
 #define _IOSTRG 0
 #endif
     fakebuf._flag = _IOWRT|_IOSTRG;
     _doprnt(pat, args, &fakebuf);	/* what a kludge */
-    (void)putc('\0', &fakebuf);
+#if defined(STDIO_PTR_LVALUE)
+    *(FILE_ptr(&fakebuf)++) = '\0';
+#else
+    /* PerlIO has probably #defined away fputc, but we want it here. */
+#  ifdef fputc
+#    undef fputc  /* XXX Should really restore it later */
+#  endif
+    (void)fputc('\0', &fakebuf);
+#endif
 #ifdef USE_CHAR_VSPRINTF
     return(dest);
 #else
@@ -1882,7 +1970,10 @@ Perl_my_htonl(pTHX_ long l)
 	char c[sizeof(long)];
     } u;
 
-#if BYTEORDER == 0x1234
+#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
+#if BYTEORDER == 0x12345678
+    u.result = 0; 
+#endif 
     u.c[0] = (l >> 24) & 255;
     u.c[1] = (l >> 16) & 255;
     u.c[2] = (l >> 8) & 255;
@@ -2176,6 +2267,8 @@ Perl_my_swabn(void *ptr, int n)
     register char *e = s + (n-1);
     register char tc;
 
+    PERL_ARGS_ASSERT_MY_SWABN;
+
     for (n /= 2; n > 0; s++, e--, n--) {
       tc = *s;
       *s = *e;
@@ -2184,9 +2277,9 @@ Perl_my_swabn(void *ptr, int n)
 }
 
 PerlIO *
-Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
+Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 {
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
     dVAR;
     int p[2];
     register I32 This, that;
@@ -2195,6 +2288,8 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
     I32 did_pipes = 0;
     int pp[2];
 
+    PERL_ARGS_ASSERT_MY_POPEN_LIST;
+
     PERL_FLUSHALL_FOR_CHILD;
     This = (*mode == 'w');
     that = !This;
@@ -2217,6 +2312,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
 	    }
 	    return NULL;
 	}
+	Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
 	sleep(5);
     }
     if (pid == 0) {
@@ -2274,9 +2370,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
     else
 	PerlLIO_close(p[that]);		/* close child's end of pipe */
 
-    LOCK_FDPID_MUTEX;
     sv = *av_fetch(PL_fdpid,p[This],TRUE);
-    UNLOCK_FDPID_MUTEX;
     SvUPGRADE(sv,SVt_IV);
     SvIV_set(sv, pid);
     PL_forkprocess = pid;
@@ -2313,7 +2407,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
     return PerlIO_fdopen(p[This], mode);
 #else
 #  ifdef OS2	/* Same, without fork()ing and all extra overhead... */
-    return my_syspopen4(aTHX_ Nullch, mode, n, args);
+    return my_syspopen4(aTHX_ NULL, mode, n, args);
 #  else
     Perl_croak(aTHX_ "List form of piped open not implemented");
     return (PerlIO *) NULL;
@@ -2322,7 +2416,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
 }
 
     /* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
 PerlIO *
 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
@@ -2335,6 +2429,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
     I32 did_pipes = 0;
     int pp[2];
 
+    PERL_ARGS_ASSERT_MY_POPEN;
+
     PERL_FLUSHALL_FOR_CHILD;
 #ifdef OS2
     if (doexec) {
@@ -2360,9 +2456,10 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 		PerlLIO_close(pp[1]);
 	    }
 	    if (!doexec)
-		Perl_croak(aTHX_ "Can't fork");
+		Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
 	    return NULL;
 	}
+	Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
 	sleep(5);
     }
     if (pid == 0) {
@@ -2440,9 +2537,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
     else
 	PerlLIO_close(p[that]);
 
-    LOCK_FDPID_MUTEX;
     sv = *av_fetch(PL_fdpid,p[This],TRUE);
-    UNLOCK_FDPID_MUTEX;
     SvUPGRADE(sv,SVt_IV);
     SvIV_set(sv, pid);
     PL_forkprocess = pid;
@@ -2481,8 +2576,9 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 #if defined(atarist) || defined(EPOC)
 FILE *popen();
 PerlIO *
-Perl_my_popen((pTHX_ const char *cmd, const char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
+    PERL_ARGS_ASSERT_MY_POPEN;
     PERL_FLUSHALL_FOR_CHILD;
     /* Call system's popen() to get a FILE *, then import it.
        used 0 for 2nd parameter to PerlIO_importFILE;
@@ -2494,7 +2590,7 @@ Perl_my_popen((pTHX_ const char *cmd, const char *mode)
 #if defined(DJGPP)
 FILE *djgpp_popen();
 PerlIO *
-Perl_my_popen((pTHX_ const char *cmd, const char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
     PERL_FLUSHALL_FOR_CHILD;
     /* Call system's popen() to get a FILE *, then import it.
@@ -2503,6 +2599,14 @@ Perl_my_popen((pTHX_ const char *cmd, const char *mode)
     */
     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
 }
+#else
+#if defined(__LIBCATAMOUNT__)
+PerlIO *
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
+{
+    return NULL;
+}
+#endif
 #endif
 #endif
 
@@ -2560,11 +2664,13 @@ Perl_my_fork(void)
 
 #ifdef DUMP_FDS
 void
-Perl_dump_fds(pTHX_ char *s)
+Perl_dump_fds(pTHX_ const char *const s)
 {
     int fd;
     Stat_t tmpstatbuf;
 
+    PERL_ARGS_ASSERT_DUMP_FDS;
+
     PerlIO_printf(Perl_debug_log,"%s", s);
     for (fd = 0; fd < 32; fd++) {
 	if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
@@ -2612,11 +2718,6 @@ dup2(int oldfd, int newfd)
 #ifndef PERL_MICRO
 #ifdef HAS_SIGACTION
 
-#ifdef MACOS_TRADITIONAL
-/* We don't want restart behavior on MacOS */
-#undef SA_RESTART
-#endif
-
 Sighandler_t
 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
 {
@@ -2664,6 +2765,8 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
     dVAR;
     struct sigaction act;
 
+    PERL_ARGS_ASSERT_RSIGNAL_SAVE;
+
 #ifdef USE_ITHREADS
     /* only "parent" interpreter can diddle signals */
     if (PL_curinterp != aTHX)
@@ -2765,7 +2868,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
 #endif /* !PERL_MICRO */
 
     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
 I32
 Perl_my_pclose(pTHX_ PerlIO *ptr)
 {
@@ -2776,14 +2879,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     Pid_t pid;
     Pid_t pid2;
     bool close_failed;
-    int saved_errno = 0;
-#ifdef WIN32
-    int saved_win32_errno;
-#endif
+    dSAVEDERRNO;
 
-    LOCK_FDPID_MUTEX;
     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
-    UNLOCK_FDPID_MUTEX;
     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
     SvREFCNT_dec(*svp);
     *svp = &PL_sv_undef;
@@ -2792,12 +2890,8 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 	return my_syspclose(ptr);
     }
 #endif
-    if ((close_failed = (PerlIO_close(ptr) == EOF))) {
-	saved_errno = errno;
-#ifdef WIN32
-	saved_win32_errno = GetLastError();
-#endif
-    }
+    close_failed = (PerlIO_close(ptr) == EOF);
+    SAVE_ERRNO;
 #ifdef UTS
     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
 #endif
@@ -2815,19 +2909,28 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     rsignal_restore(SIGQUIT, &qstat);
 #endif
     if (close_failed) {
-	SETERRNO(saved_errno, 0);
+	RESTORE_ERRNO;
 	return -1;
     }
     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
 }
+#else
+#if defined(__LIBCATAMOUNT__)
+I32
+Perl_my_pclose(pTHX_ PerlIO *ptr)
+{
+    return -1;
+}
+#endif
 #endif /* !DOSISH */
 
-#if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
+#if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
 I32
 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 {
     dVAR;
     I32 result = 0;
+    PERL_ARGS_ASSERT_WAIT4PID;
     if (!pid)
 	return -1;
 #ifdef PERL_USES_PL_PIDSTATUS
@@ -2900,6 +3003,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 #endif
     if (result < 0 && errno == EINTR) {
 	PERL_ASYNC_CHECK();
+	errno = EINTR; /* reset in case a signal handler changed $! */
     }
     return result;
 }
@@ -2907,7 +3011,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 
 #ifdef PERL_USES_PL_PIDSTATUS
 void
-Perl_pidgone(pTHX_ Pid_t pid, int status)
+S_pidgone(pTHX_ Pid_t pid, int status)
 {
     register SV *sv;
 
@@ -2951,24 +3055,36 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 }
 #endif
 
+#define PERL_REPEATCPY_LINEAR 4
 void
-Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
-{
-    register I32 todo;
-    register const char * const frombase = from;
-    PERL_UNUSED_CONTEXT;
+Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
+{
+    PERL_ARGS_ASSERT_REPEATCPY;
+
+    if (len == 1)
+	memset(to, *from, count);
+    else if (count) {
+	register char *p = to;
+	I32 items, linear, half;
+
+	linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
+	for (items = 0; items < linear; ++items) {
+	    register const char *q = from;
+	    I32 todo;
+	    for (todo = len; todo > 0; todo--)
+		*p++ = *q++;
+        }
 
-    if (len == 1) {
-	register const char c = *from;
-	while (count-- > 0)
-	    *to++ = c;
-	return;
-    }
-    while (count-- > 0) {
-	for (todo = len; todo > 0; todo--) {
-	    *to++ = *from++;
+	half = count / 2;
+	while (items <= half) {
+	    I32 size = items * len;
+	    memcpy(p, to, size);
+	    p     += size;
+	    items *= 2;
 	}
-	from = frombase;
+
+	if (count > items)
+	    memcpy(p, to, (count - items) * len);
     }
 }
 
@@ -2982,6 +3098,8 @@ Perl_same_dirent(pTHX_ const char *a, const char *b)
     Stat_t tmpstatbuf2;
     SV * const tmpsv = sv_newmortal();
 
+    PERL_ARGS_ASSERT_SAME_DIRENT;
+
     if (fa)
 	fa++;
     else
@@ -2993,13 +3111,13 @@ Perl_same_dirent(pTHX_ const char *a, const char *b)
     if (strNE(a,b))
 	return FALSE;
     if (fa == a)
-	sv_setpvn(tmpsv, ".", 1);
+	sv_setpvs(tmpsv, ".");
     else
 	sv_setpvn(tmpsv, a, fa - a);
     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
 	return FALSE;
     if (fb == b)
-	sv_setpvn(tmpsv, ".", 1);
+	sv_setpvs(tmpsv, ".");
     else
 	sv_setpvn(tmpsv, b, fb - b);
     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
@@ -3020,6 +3138,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
     register char *s;
     I32 len = 0;
     int retval;
+    char *bufend;
 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
 #  define SEARCH_EXTS ".bat", ".cmd", NULL
 #  define MAX_EXT_LEN 4
@@ -3043,6 +3162,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 #  define MAX_EXT_LEN 0
 #endif
 
+    PERL_ARGS_ASSERT_FIND_SCRIPT;
+
     /*
      * If dosearch is true and if scriptname does not contain path
      * delimiters, search the PATH for scriptname.
@@ -3131,26 +3252,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
     }
 #endif
 
-#ifdef MACOS_TRADITIONAL
-    if (dosearch && !strchr(scriptname, ':') &&
-	(s = PerlEnv_getenv("Commands")))
-#else
     if (dosearch && !strchr(scriptname, '/')
 #ifdef DOSISH
 		 && !strchr(scriptname, '\\')
 #endif
 		 && (s = PerlEnv_getenv("PATH")))
-#endif
     {
 	bool seen_dot = 0;
 
-	PL_bufend = s + strlen(s);
-	while (s < PL_bufend) {
-#ifdef MACOS_TRADITIONAL
-	    s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
-			',',
-			&len);
-#else
+	bufend = s + strlen(s);
+	while (s < bufend) {
 #if defined(atarist) || defined(DOSISH)
 	    for (len = 0; *s
 #  ifdef atarist
@@ -3163,21 +3274,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 	    if (len < sizeof tmpbuf)
 		tmpbuf[len] = '\0';
 #else  /* ! (atarist || DOSISH) */
-	    s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
+	    s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
 			':',
 			&len);
 #endif /* ! (atarist || DOSISH) */
-#endif /* MACOS_TRADITIONAL */
-	    if (s < PL_bufend)
+	    if (s < bufend)
 		s++;
 	    if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
 		continue;	/* don't search dir with too-long name */
-#ifdef MACOS_TRADITIONAL
-	    if (len && tmpbuf[len - 1] != ':')
-	    	tmpbuf[len++] = ':';
-#else
 	    if (len
-#  if defined(atarist) || defined(__MINT__) || defined(DOSISH)
+#  if defined(atarist) || defined(DOSISH)
 		&& tmpbuf[len - 1] != '/'
 		&& tmpbuf[len - 1] != '\\'
 #  endif
@@ -3185,7 +3291,6 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 		tmpbuf[len++] = '/';
 	    if (len == 2 && tmpbuf[0] == '.')
 		seen_dot = 1;
-#endif
 	    (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
 #endif  /* !VMS */
 
@@ -3210,7 +3315,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 		continue;
 	    if (S_ISREG(PL_statbuf.st_mode)
 		&& cando(S_IRUSR,TRUE,&PL_statbuf)
-#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
+#if !defined(DOSISH)
 		&& cando(S_IXUSR,TRUE,&PL_statbuf)
 #endif
 		)
@@ -3271,6 +3376,7 @@ void
 Perl_set_context(void *t)
 {
     dVAR;
+    PERL_ARGS_ASSERT_SET_CONTEXT;
 #if defined(USE_ITHREADS)
 #  ifdef I_MACH_CTHREADS
     cthread_set_data(cthread_self(), t);
@@ -3335,6 +3441,7 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
 {
     char * const env_trans = PerlEnv_getenv(env_elem);
     PERL_UNUSED_CONTEXT;
+    PERL_ARGS_ASSERT_GETENV_LEN;
     if (env_trans)
 	*len = strlen(env_trans);
     return env_trans;
@@ -3632,11 +3739,13 @@ Perl_init_tm(pTHX_ struct tm *ptm)	/* see mktime, strftime and asctime */
 #ifdef HAS_TM_TM_ZONE
     Time_t now;
     const struct tm* my_tm;
+    PERL_ARGS_ASSERT_INIT_TM;
     (void)time(&now);
     my_tm = localtime(&now);
     if (my_tm)
         Copy(my_tm, ptm, 1, struct tm);
 #else
+    PERL_ARGS_ASSERT_INIT_TM;
     PERL_UNUSED_ARG(ptm);
 #endif
 }
@@ -3654,6 +3763,8 @@ Perl_mini_mktime(pTHX_ struct tm *ptm)
     int odd_cent, odd_year;
     PERL_UNUSED_CONTEXT;
 
+    PERL_ARGS_ASSERT_MINI_MKTIME;
+
 #define	DAYS_PER_YEAR	365
 #define	DAYS_PER_QYEAR	(4*DAYS_PER_YEAR+1)
 #define	DAYS_PER_CENT	(25*DAYS_PER_QYEAR-1)
@@ -3848,6 +3959,8 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
   struct tm mytm;
   int len;
 
+  PERL_ARGS_ASSERT_MY_STRFTIME;
+
   init_tm(&mytm);	/* XXX workaround - see init_tm() above */
   mytm.tm_sec = sec;
   mytm.tm_min = min;
@@ -3955,6 +4068,8 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
     SvTAINTED_on(sv);
 #endif
 
+    PERL_ARGS_ASSERT_GETCWD_SV;
+
 #ifdef HAS_GETCWD
     {
 	char buf[MAXPATHLEN];
@@ -3992,6 +4107,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 
     for (;;) {
 	DIR *dir;
+	int namelen;
 	odev = cdev;
 	oino = cino;
 
@@ -4014,9 +4130,9 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 
 	while ((dp = PerlDir_read(dir)) != NULL) {
 #ifdef DIRNAMLEN
-	    const int namelen = dp->d_namlen;
+	    namelen = dp->d_namlen;
 #else
-	    const int namelen = strlen(dp->d_name);
+	    namelen = strlen(dp->d_name);
 #endif
 	    /* skip . and .. */
 	    if (SV_CWD_ISDOT(dp)) {
@@ -4092,6 +4208,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 #endif
 }
 
+#define VERSION_MAX 0x7FFFFFFF
 /*
 =for apidoc scan_version
 
@@ -4123,26 +4240,28 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     int saw_period = 0;
     int alpha = 0;
     int width = 3;
+    bool vinf = FALSE;
     AV * const av = newAV();
     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
-    (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
 
-#ifndef NODEFAULT_SHAREKEYS
-    HvSHAREKEYS_on(hv);         /* key-sharing on by default */
-#endif
+    PERL_ARGS_ASSERT_SCAN_VERSION;
+
+    (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
 
     while (isSPACE(*s)) /* leading whitespace is OK */
 	s++;
 
+    start = last = s;
+
     if (*s == 'v') {
 	s++;  /* get past 'v' */
 	qv = 1; /* force quoted version processing */
     }
 
-    start = last = pos = s;
+    pos = s;
 
     /* pre-scan the input string to check for decimals/underbars */
-    while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
+    while ( *pos == '.' || *pos == '_' || *pos == ',' || isDIGIT(*pos) )
     {
 	if ( *pos == '.' )
 	{
@@ -4158,6 +4277,12 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 	    alpha = 1;
 	    width = pos - last - 1; /* natural width of sub-version */
 	}
+	else if ( *pos == ',' && isDIGIT(pos[1]) )
+	{
+	    saw_period++ ;
+	    last = pos;
+	}
+
 	pos++;
     }
 
@@ -4170,14 +4295,15 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     if ( saw_period > 1 )
 	qv = 1; /* force quoted version processing */
 
+    last = pos;
     pos = s;
 
     if ( qv )
-	hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
+	(void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
     if ( alpha )
-	hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
+	(void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
     if ( !qv && width < 3 )
-	hv_store((HV *)hv, "width", 5, newSViv(width), 0);
+	(void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
     
     while (isDIGIT(*pos))
 	pos++;
@@ -4190,7 +4316,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
   		/* this is atoi() that delimits on underscores */
   		const char *end = pos;
   		I32 mult = 1;
- 		I32 orev;
+		I32 orev;
 
 		/* the following if() will only be true after the decimal
 		 * point of a version originally created with a bare
@@ -4199,11 +4325,17 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
  		if ( !qv && s > start && saw_period == 1 ) {
 		    mult *= 100;
  		    while ( s < end ) {
- 			orev = rev;
+			orev = rev;
  			rev += (*s - '0') * mult;
  			mult /= 10;
- 			if ( PERL_ABS(orev) > PERL_ABS(rev) )
- 			    Perl_croak(aTHX_ "Integer overflow in version");
+			if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
+			    || (PERL_ABS(rev) > VERSION_MAX )) {
+			    Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
+					   "Integer overflow in version %d",VERSION_MAX);
+			    s = end - 1;
+			    rev = VERSION_MAX;
+			    vinf = 1;
+			}
  			s++;
 			if ( *s == '_' )
 			    s++;
@@ -4211,21 +4343,33 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
   		}
  		else {
  		    while (--end >= s) {
- 			orev = rev;
+			orev = rev;
  			rev += (*end - '0') * mult;
  			mult *= 10;
- 			if ( PERL_ABS(orev) > PERL_ABS(rev) )
- 			    Perl_croak(aTHX_ "Integer overflow in version");
+			if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
+			    || (PERL_ABS(rev) > VERSION_MAX )) {
+			    Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
+					   "Integer overflow in version");
+			    end = s - 1;
+			    rev = VERSION_MAX;
+			    vinf = 1;
+			}
  		    }
  		} 
   	    }
 
   	    /* Append revision */
 	    av_push(av, newSViv(rev));
-	    if ( *pos == '.' )
+	    if ( vinf ) {
+		s = last;
+		break;
+	    }
+	    else if ( *pos == '.' )
 		s = ++pos;
 	    else if ( *pos == '_' && isDIGIT(pos[1]) )
 		s = ++pos;
+	    else if ( *pos == ',' && isDIGIT(pos[1]) )
+		s = ++pos;
 	    else if ( isDIGIT(*pos) )
 		s = pos;
 	    else {
@@ -4253,23 +4397,40 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 	   Compiler in question is:
 	   gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
 	   for ( len = 2 - len; len > 0; len-- )
-	   av_push((AV *)sv, newSViv(0));
+	   av_push(MUTABLE_AV(sv), newSViv(0));
 	*/
 	len = 2 - len;
 	while (len-- > 0)
 	    av_push(av, newSViv(0));
     }
 
-    if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
+    /* need to save off the current version string for later */
+    if ( vinf ) {
+	SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
+	(void)hv_stores(MUTABLE_HV(hv), "original", orig);
+	(void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
+    }
+    else if ( s > start ) {
+	SV * orig = newSVpvn(start,s-start);
+	if ( qv && saw_period == 1 && *start != 'v' ) {
+	    /* need to insert a v to be consistent */
+	    sv_insert(orig, 0, 0, "v", 1);
+	}
+	(void)hv_stores(MUTABLE_HV(hv), "original", orig);
+    }
+    else {
+	(void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
 	av_push(av, newSViv(0));
+    }
+
+    /* And finally, store the AV in the hash */
+    (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
 
     /* fix RT#19517 - special case 'undef' as string */
     if ( *s == 'u' && strEQ(s,"undef") ) {
 	s += 5;
     }
 
-    /* And finally, store the AV in the hash */
-    hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
     return s;
 }
 
@@ -4291,6 +4452,7 @@ Perl_new_version(pTHX_ SV *ver)
 {
     dVAR;
     SV * const rv = newSV(0);
+    PERL_ARGS_ASSERT_NEW_VERSION;
     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
     {
 	I32 key;
@@ -4299,27 +4461,30 @@ Perl_new_version(pTHX_ SV *ver)
 	/* This will get reblessed later if a derived class*/
 	SV * const hv = newSVrv(rv, "version"); 
 	(void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
-#ifndef NODEFAULT_SHAREKEYS
-	HvSHAREKEYS_on(hv);         /* key-sharing on by default */
-#endif
 
 	if ( SvROK(ver) )
 	    ver = SvRV(ver);
 
 	/* Begin copying all of the elements */
-	if ( hv_exists((HV *)ver, "qv", 2) )
-	    hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
+	if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
+	    (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
 
-	if ( hv_exists((HV *)ver, "alpha", 5) )
-	    hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
+	if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
+	    (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
 	
-	if ( hv_exists((HV*)ver, "width", 5 ) )
+	if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
 	{
-	    const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
-	    hv_store((HV *)hv, "width", 5, newSViv(width), 0);
+	    const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
+	    (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
 	}
 
-	sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
+	if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
+	{
+	    SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
+	    (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
+	}
+
+	sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
 	/* This will get reblessed later if a derived class*/
 	for ( key = 0; key <= av_len(sav); key++ )
 	{
@@ -4327,7 +4492,7 @@ Perl_new_version(pTHX_ SV *ver)
 	    av_push(av, newSViv(rev));
 	}
 
-	hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
+	(void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
 	return rv;
     }
 #ifdef SvVOK
@@ -4337,6 +4502,9 @@ Perl_new_version(pTHX_ SV *ver)
 	    const STRLEN len = mg->mg_len;
 	    char * const version = savepvn( (const char*)mg->mg_ptr, len);
 	    sv_setpvn(rv,version,len);
+	    /* this is for consistency with the pure Perl class */
+	    if ( *version != 'v' ) 
+		sv_insert(rv, 0, 0, "v", 1);
 	    Safefree(version);
 	}
 	else {
@@ -4370,6 +4538,8 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
     const MAGIC *mg;
 #endif
 
+    PERL_ARGS_ASSERT_UPG_VERSION;
+
     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
     {
 	/* may get too much accuracy */ 
@@ -4382,6 +4552,7 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 	setlocale(LC_NUMERIC, loc);
 #endif
 	while (tbuf[len-1] == '0' && len > 0) len--;
+	if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
 	version = savepvn(tbuf, len);
     }
 #ifdef SvVOK
@@ -4403,10 +4574,11 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 	    const char *nver;
 	    const char *pos;
 	    int saw_period = 0;
-	    sv_setpvf(nsv,"%vd",ver);
+	    sv_setpvf(nsv,"v%vd",ver);
 	    pos = nver = savepv(SvPV_nolen(nsv));
 
 	    /* scan the resulting formatted string */
+	    pos++; /* skip the leading 'v' */
 	    while ( *pos == '.' || isDIGIT(*pos) ) {
 		if ( *pos == '.' )
 		    saw_period++ ;
@@ -4425,10 +4597,9 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 
     s = scan_version(version, ver, qv);
     if ( *s != '\0' ) 
-	if(ckWARN(WARN_MISC))
-	    Perl_warner(aTHX_ packWARN(WARN_MISC), 
-		"Version string '%s' contains invalid data; "
-		"ignoring: '%s'", version, s);
+	Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 
+		       "Version string '%s' contains invalid data; "
+		       "ignoring: '%s'", version, s);
     Safefree(version);
     return ver;
 }
@@ -4460,13 +4631,16 @@ bool
 Perl_vverify(pTHX_ SV *vs)
 {
     SV *sv;
+
+    PERL_ARGS_ASSERT_VVERIFY;
+
     if ( SvROK(vs) )
 	vs = SvRV(vs);
 
     /* see if the appropriate elements exist */
     if ( SvTYPE(vs) == SVt_PVHV
-	 && hv_exists((HV*)vs, "version", 7)
-	 && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
+	 && hv_exists(MUTABLE_HV(vs), "version", 7)
+	 && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
 	 && SvTYPE(sv) == SVt_PVAV )
 	return TRUE;
     else
@@ -4495,6 +4669,9 @@ Perl_vnumify(pTHX_ SV *vs)
     bool alpha = FALSE;
     SV * const sv = newSV(0);
     AV *av;
+
+    PERL_ARGS_ASSERT_VNUMIFY;
+
     if ( SvROK(vs) )
 	vs = SvRV(vs);
 
@@ -4502,16 +4679,16 @@ Perl_vnumify(pTHX_ SV *vs)
 	Perl_croak(aTHX_ "Invalid version object");
 
     /* see if various flags exist */
-    if ( hv_exists((HV*)vs, "alpha", 5 ) )
+    if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
 	alpha = TRUE;
-    if ( hv_exists((HV*)vs, "width", 5 ) )
-	width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
+    if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
+	width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
     else
 	width = 3;
 
 
     /* attempt to retrieve the version array */
-    if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
+    if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
 	sv_catpvs(sv,"0");
 	return sv;
     }
@@ -4573,15 +4750,18 @@ Perl_vnormal(pTHX_ SV *vs)
     bool alpha = FALSE;
     SV * const sv = newSV(0);
     AV *av;
+
+    PERL_ARGS_ASSERT_VNORMAL;
+
     if ( SvROK(vs) )
 	vs = SvRV(vs);
 
     if ( !vverify(vs) )
 	Perl_croak(aTHX_ "Invalid version object");
 
-    if ( hv_exists((HV*)vs, "alpha", 5 ) )
+    if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
 	alpha = TRUE;
-    av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
+    av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
 
     len = av_len(av);
     if ( len == -1 )
@@ -4627,16 +4807,28 @@ the original version contained 1 or more dots, respectively
 SV *
 Perl_vstringify(pTHX_ SV *vs)
 {
+    PERL_ARGS_ASSERT_VSTRINGIFY;
+
     if ( SvROK(vs) )
 	vs = SvRV(vs);
-    
+
     if ( !vverify(vs) )
 	Perl_croak(aTHX_ "Invalid version object");
 
-    if ( hv_exists((HV *)vs, "qv", 2) )
-	return vnormal(vs);
-    else
-	return vnumify(vs);
+    if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
+	SV *pv;
+	pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
+	if ( SvPOK(pv) )
+	    return newSVsv(pv);
+	else
+	    return &PL_sv_undef;
+    }
+    else {
+	if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
+	    return vnormal(vs);
+	else
+	    return vnumify(vs);
+    }
 }
 
 /*
@@ -4657,6 +4849,9 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
     I32 left = 0;
     I32 right = 0;
     AV *lav, *rav;
+
+    PERL_ARGS_ASSERT_VCMP;
+
     if ( SvROK(lhv) )
 	lhv = SvRV(lhv);
     if ( SvROK(rhv) )
@@ -4669,13 +4864,13 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
 	Perl_croak(aTHX_ "Invalid version object");
 
     /* get the left hand term */
-    lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
-    if ( hv_exists((HV*)lhv, "alpha", 5 ) )
+    lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
+    if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
 	lalpha = TRUE;
 
     /* and the right hand term */
-    rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
-    if ( hv_exists((HV*)rhv, "alpha", 5 ) )
+    rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
+    if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
 	ralpha = TRUE;
 
     l = av_len(lav);
@@ -4865,12 +5060,12 @@ S_socketpair_udp (int fd[2]) {
     errno = ECONNABORTED;
   tidy_up_and_fail:
     {
-	const int save_errno = errno;
+	dSAVE_ERRNO;
 	if (sockets[0] != -1)
 	    PerlLIO_close(sockets[0]);
 	if (sockets[1] != -1)
 	    PerlLIO_close(sockets[1]);
-	errno = save_errno;
+	RESTORE_ERRNO;
 	return -1;
     }
 }
@@ -4969,14 +5164,14 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
 #endif
   tidy_up_and_fail:
     {
-	const int save_errno = errno;
+	dSAVE_ERRNO;
 	if (listener != -1)
 	    PerlLIO_close(listener);
 	if (connector != -1)
 	    PerlLIO_close(connector);
 	if (acceptor != -1)
 	    PerlLIO_close(acceptor);
-	errno = save_errno;
+	RESTORE_ERRNO;
 	return -1;
     }
 }
@@ -5012,12 +5207,34 @@ Perl_sv_nosharing(pTHX_ SV *sv)
     PERL_UNUSED_ARG(sv);
 }
 
+/*
+
+=for apidoc sv_destroyable
+
+Dummy routine which reports that object can be destroyed when there is no
+sharing module present.  It ignores its single SV argument, and returns
+'true'.  Exists to avoid test for a NULL function pointer and because it
+could potentially warn under some level of strict-ness.
+
+=cut
+*/
+
+bool
+Perl_sv_destroyable(pTHX_ SV *sv)
+{
+    PERL_UNUSED_CONTEXT;
+    PERL_UNUSED_ARG(sv);
+    return TRUE;
+}
+
 U32
 Perl_parse_unicode_opts(pTHX_ const char **popt)
 {
   const char *p = *popt;
   U32 opt = 0;
 
+  PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
+
   if (*p) {
        if (isDIGIT(*p)) {
 	    opt = (U32) atoi(p);
@@ -5197,6 +5414,7 @@ Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
     const char * const stashpv = CopSTASHPV(c);
     const char * const name = HvNAME_get(hv);
     PERL_UNUSED_CONTEXT;
+    PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
 
     if (stashpv == name)
 	return TRUE;
@@ -5273,6 +5491,7 @@ Perl_init_global_struct(pTHX)
 void
 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
 {
+    PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
 # ifdef PERL_GLOBAL_STRUCT
 #  ifdef PERL_UNSET_VARS
     PERL_UNSET_VARS(plvarsp);
@@ -5289,172 +5508,194 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
 
 #ifdef PERL_MEM_LOG
 
-/*
- * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
+/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
+ * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
+ * given, and you supply your own implementation.
+ *
+ * The default implementation reads a single env var, PERL_MEM_LOG,
+ * expecting one or more of the following:
  *
- * PERL_MEM_LOG_ENV: if defined, during run time the environment
- * variable PERL_MEM_LOG will be consulted, and if the integer value
- * of that is true, the logging will happen.  (The default is to
- * always log if the PERL_MEM_LOG define was in effect.)
+ *    \d+ - fd		fd to write to		: must be 1st (atoi)
+ *    'm' - memlog	was PERL_MEM_LOG=1
+ *    's' - svlog	was PERL_SV_LOG=1
+ *    't' - timestamp	was PERL_MEM_LOG_TIMESTAMP=1
+ *
+ * This makes the logger controllable enough that it can reasonably be
+ * added to the system perl.
  */
 
-/*
- * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
+/* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
  */
 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
 
-/*
- * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
- * log to.  You can also define in compile time PERL_MEM_LOG_ENV_FD,
- * in which case the environment variable PERL_MEM_LOG_FD will be
- * consulted for the file descriptor number to use.
+/* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
+ * writes to.  In the default logger, this is settable at runtime.
  */
 #ifndef PERL_MEM_LOG_FD
 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
 #endif
 
-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)
-{
-#ifdef PERL_MEM_LOG_STDERR
-# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
-    char *s;
-# endif
-# ifdef PERL_MEM_LOG_ENV
-    s = getenv("PERL_MEM_LOG");
-    if (s ? atoi(s) : 0)
+#ifndef PERL_MEM_LOG_NOIMPL
+
+# ifdef DEBUG_LEAKING_SCALARS
+#   define SV_LOG_SERIAL_FMT	    " [%lu]"
+#   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
+# else
+#   define SV_LOG_SERIAL_FMT
+#   define _SV_LOG_SERIAL_ARG(sv)
 # endif
+
+static void
+S_mem_log_common(enum mem_log_type mlt, const UV n, 
+		 const UV typesize, const char *type_name, const SV *sv,
+		 Malloc_t oldalloc, Malloc_t newalloc,
+		 const char *filename, const int linenumber,
+		 const char *funcname)
+{
+    const char *pmlenv;
+
+    PERL_ARGS_ASSERT_MEM_LOG_COMMON;
+
+    pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
+    if (!pmlenv)
+	return;
+    if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
     {
 	/* We can't use SVs or PerlIO for obvious reasons,
 	 * so we'll use stdio and low-level IO instead. */
 	char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-# ifdef PERL_MEM_LOG_TIMESTAMP
-	struct timeval tv;
+
 #   ifdef HAS_GETTIMEOFDAY
+#     define MEM_LOG_TIME_FMT	"%10d.%06d: "
+#     define MEM_LOG_TIME_ARG	(int)tv.tv_sec, (int)tv.tv_usec
+	struct timeval tv;
 	gettimeofday(&tv, 0);
+#   else
+#     define MEM_LOG_TIME_FMT	"%10d: "
+#     define MEM_LOG_TIME_ARG	(int)when
+        Time_t when;
+        (void)time(&when);
 #   endif
 	/* If there are other OS specific ways of hires time than
-	 * gettimeofday() (see ext/Time/HiRes), the easiest way is
+	 * gettimeofday() (see ext/Time-HiRes), the easiest way is
 	 * probably that they would be used to fill in the struct
 	 * timeval. */
-# endif
 	{
-	    const STRLEN len =
-		my_snprintf(buf,
-			    sizeof(buf),
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-			    "%10d.%06d: "
-# endif
-			    "alloc: %s:%d:%s: %"IVdf" %"UVuf
-			    " %s = %"IVdf": %"UVxf"\n",
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-			    (int)tv.tv_sec, (int)tv.tv_usec,
-# endif
-			    filename, linenumber, funcname, n, typesize,
-			    typename, n * typesize, PTR2UV(newalloc));
-# ifdef PERL_MEM_LOG_ENV_FD
-	    s = PerlEnv_getenv("PERL_MEM_LOG_FD");
-	    PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
-# else
-	    PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
-#endif
+	    STRLEN len;
+	    int fd = atoi(pmlenv);
+	    if (!fd)
+		fd = PERL_MEM_LOG_FD;
+
+	    if (strchr(pmlenv, 't')) {
+		len = my_snprintf(buf, sizeof(buf),
+				MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
+		PerlLIO_write(fd, buf, len);
+	    }
+	    switch (mlt) {
+	    case MLT_ALLOC:
+		len = my_snprintf(buf, sizeof(buf),
+			"alloc: %s:%d:%s: %"IVdf" %"UVuf
+			" %s = %"IVdf": %"UVxf"\n",
+			filename, linenumber, funcname, n, typesize,
+			type_name, n * typesize, PTR2UV(newalloc));
+		break;
+	    case MLT_REALLOC:
+		len = my_snprintf(buf, sizeof(buf),
+			"realloc: %s:%d:%s: %"IVdf" %"UVuf
+			" %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
+			filename, linenumber, funcname, n, typesize,
+			type_name, n * typesize, PTR2UV(oldalloc),
+			PTR2UV(newalloc));
+		break;
+	    case MLT_FREE:
+		len = my_snprintf(buf, sizeof(buf),
+			"free: %s:%d:%s: %"UVxf"\n",
+			filename, linenumber, funcname,
+			PTR2UV(oldalloc));
+		break;
+	    case MLT_NEW_SV:
+	    case MLT_DEL_SV:
+		len = my_snprintf(buf, sizeof(buf),
+			"%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
+			mlt == MLT_NEW_SV ? "new" : "del",
+			filename, linenumber, funcname,
+			PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
+		break;
+	    default:
+		len = 0;
+	    }
+	    PerlLIO_write(fd, buf, len);
 	}
     }
+}
+#endif /* !PERL_MEM_LOG_NOIMPL */
+
+#ifndef PERL_MEM_LOG_NOIMPL
+# define \
+    mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
+    mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
+#else
+/* this is suboptimal, but bug compatible.  User is providing their
+   own implemenation, but is getting these functions anyway, and they
+   do nothing. But _NOIMPL users should be able to cope or fix */
+# define \
+    mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
+    /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
 #endif
+
+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)
+{
+    mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
+		      NULL, NULL, newalloc,
+		      filename, linenumber, funcname);
     return newalloc;
 }
 
 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)
-{
-#ifdef PERL_MEM_LOG_STDERR
-# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
-    char *s;
-# endif
-# ifdef PERL_MEM_LOG_ENV
-    s = PerlEnv_getenv("PERL_MEM_LOG");
-    if (s ? atoi(s) : 0)
-# endif
-    {
-	/* We can't use SVs or PerlIO for obvious reasons,
-	 * so we'll use stdio and low-level IO instead. */
-	char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-	struct timeval tv;
-	gettimeofday(&tv, 0);
-# endif
-	{
-	    const STRLEN len =
-		my_snprintf(buf,
-			    sizeof(buf),
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-			    "%10d.%06d: "
-# endif
-			    "realloc: %s:%d:%s: %"IVdf" %"UVuf
-			    " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-			    (int)tv.tv_sec, (int)tv.tv_usec,
-# endif
-			    filename, linenumber, funcname, n, typesize,
-			    typename, n * typesize, PTR2UV(oldalloc),
-			    PTR2UV(newalloc));
-# ifdef PERL_MEM_LOG_ENV_FD
-	    s = PerlEnv_getenv("PERL_MEM_LOG_FD");
-	    PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
-# else
-	    PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
-# endif
-	}
-    }
-#endif
+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)
+{
+    mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
+		      NULL, oldalloc, newalloc, 
+		      filename, linenumber, funcname);
     return newalloc;
 }
 
 Malloc_t
-Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
+Perl_mem_log_free(Malloc_t oldalloc, 
+		  const char *filename, const int linenumber, 
+		  const char *funcname)
 {
-#ifdef PERL_MEM_LOG_STDERR
-# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
-    char *s;
-# endif
-# ifdef PERL_MEM_LOG_ENV
-    s = PerlEnv_getenv("PERL_MEM_LOG");
-    if (s ? atoi(s) : 0)
-# endif
-    {
-	/* We can't use SVs or PerlIO for obvious reasons,
-	 * so we'll use stdio and low-level IO instead. */
-	char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-	struct timeval tv;
-	gettimeofday(&tv, 0);
-# endif
-	{
-	    const STRLEN len =
-		my_snprintf(buf,
-			    sizeof(buf),
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-			    "%10d.%06d: "
-# endif
-			    "free: %s:%d:%s: %"UVxf"\n",
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-			    (int)tv.tv_sec, (int)tv.tv_usec,
-# endif
-			    filename, linenumber, funcname,
-			    PTR2UV(oldalloc));
-# ifdef PERL_MEM_LOG_ENV_FD
-	    s = PerlEnv_getenv("PERL_MEM_LOG_FD");
-	    PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
-# else
-	    PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
-# endif
-	}
-    }
-#endif
+    mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, 
+		      filename, linenumber, funcname);
     return oldalloc;
 }
 
+void
+Perl_mem_log_new_sv(const SV *sv, 
+		    const char *filename, const int linenumber,
+		    const char *funcname)
+{
+    mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
+		      filename, linenumber, funcname);
+}
+
+void
+Perl_mem_log_del_sv(const SV *sv,
+		    const char *filename, const int linenumber, 
+		    const char *funcname)
+{
+    mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, 
+		      filename, linenumber, funcname);
+}
+
 #endif /* PERL_MEM_LOG */
 
 /*
@@ -5471,6 +5712,7 @@ int
 Perl_my_sprintf(char *buffer, const char* pat, ...)
 {
     va_list args;
+    PERL_ARGS_ASSERT_MY_SPRINTF;
     va_start(args, pat);
     vsprintf(buffer, pat, args);
     va_end(args);
@@ -5496,6 +5738,7 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
     dTHX;
     int retval;
     va_list ap;
+    PERL_ARGS_ASSERT_MY_SNPRINTF;
     va_start(ap, format);
 #ifdef HAS_VSNPRINTF
     retval = vsnprintf(buffer, len, format, ap);
@@ -5527,6 +5770,9 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap
     int retval;
 #ifdef NEED_VA_COPY
     va_list apc;
+
+    PERL_ARGS_ASSERT_MY_VSNPRINTF;
+
     Perl_va_copy(ap, apc);
 # ifdef HAS_VSNPRINTF
     retval = vsnprintf(buffer, len, format, apc);
@@ -5585,7 +5831,8 @@ Perl_my_clearenv(pTHX)
         bsiz = l + 1; /* + 1 for the \0. */
         buf = (char*)safesysmalloc(bufsiz);
       } 
-      my_strlcpy(buf, *environ, l + 1);
+      memcpy(buf, *environ, l);
+      buf[l] = '\0';
       (void)unsetenv(buf);
     }
     (void)safesysfree(buf);
@@ -5615,6 +5862,7 @@ Perl_my_cxt_init(pTHX_ int *index, size_t size)
 {
     dVAR;
     void *p;
+    PERL_ARGS_ASSERT_MY_CXT_INIT;
     if (*index == -1) {
 	/* this module hasn't been allocated an index yet */
 	MUTEX_LOCK(&PL_my_ctx_mutex);
@@ -5649,6 +5897,8 @@ Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
     dVAR;
     int index;
 
+    PERL_ARGS_ASSERT_MY_CXT_INDEX;
+
     for (index = 0; index < PL_my_cxt_index; index++) {
 	const char *key = PL_my_cxt_keys[index];
 	/* try direct pointer compare first - there are chances to success,
@@ -5667,6 +5917,8 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
     void *p;
     int index;
 
+    PERL_ARGS_ASSERT_MY_CXT_INIT;
+
     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
     if (index == -1) {
 	/* this module hasn't been allocated an index yet */
@@ -5753,6 +6005,8 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
      * it's for informational purposes only.
      */
 
+    PERL_ARGS_ASSERT_GET_DB_SUB;
+
     save_item(dbsv);
     if (!PERLDB_SUB_NN) {
 	GV * const gv = CvGV(cv);
@@ -5760,10 +6014,11 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
 	if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
 	     || strEQ(GvNAME(gv), "END")
 	     || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
-		 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) {
+		 !( (SvTYPE(*svp) == SVt_PVGV)
+		    && (GvCV((const GV *)*svp) == cv) )))) {
 	    /* Use GV from the stack as a fallback. */
 	    /* GV is potentially non-unique, or contain different CV. */
-	    SV * const tmp = newRV((SV*)cv);
+	    SV * const tmp = newRV(MUTABLE_SV(cv));
 	    sv_setsv(dbsv, tmp);
 	    SvREFCNT_dec(tmp);
 	}
@@ -5780,6 +6035,41 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
     }
 }
 
+int
+Perl_my_dirfd(pTHX_ DIR * dir) {
+
+    /* Most dirfd implementations have problems when passed NULL. */
+    if(!dir)
+        return -1;
+#ifdef HAS_DIRFD
+    return dirfd(dir);
+#elif defined(HAS_DIR_DD_FD)
+    return dir->dd_fd;
+#else
+    Perl_die(aTHX_ PL_no_func, "dirfd");
+   /* NOT REACHED */
+    return 0;
+#endif 
+}
+
+REGEXP *
+Perl_get_re_arg(pTHX_ SV *sv) {
+    SV    *tmpsv;
+
+    if (sv) {
+        if (SvMAGICAL(sv))
+            mg_get(sv);
+        if (SvROK(sv) &&
+            (tmpsv = MUTABLE_SV(SvRV(sv))) &&            /* assign deliberate */
+            SvTYPE(tmpsv) == SVt_REGEXP)
+        {
+            return (REGEXP*) tmpsv;
+        }
+    }
+ 
+    return NULL;
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd