X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e8dda941161b48515d0da4da6e5157084cbd1df0..514612b7038f11927cade098ef794514f6c0f65b:/util.c

diff --git a/util.c b/util.c
index d344d1c..873d3cb 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, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 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.
@@ -60,11 +60,12 @@ int putenv(char *);
 static char *
 S_write_no_mem(pTHX)
 {
+    dVAR;
     /* Can't use PerlIO to write as it allocates memory */
     PerlLIO_write(PerlIO_fileno(Perl_error_log),
 		  PL_no_mem, strlen(PL_no_mem));
     my_exit(1);
-    return Nullch;
+    NORETURN_FUNCTION_END;
 }
 
 /* paranoid version of system's malloc() */
@@ -91,17 +92,34 @@ Perl_safesysmalloc(MEM_SIZE size)
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);	/* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
-    if (ptr != Nullch) {
+    if (ptr != NULL) {
 #ifdef PERL_TRACK_MEMPOOL
-        *(tTHX*)ptr = aTHX;
+	struct perl_memory_debug_header *const header
+	    = (struct perl_memory_debug_header *)ptr;
+#endif
+
+#ifdef PERL_POISON
+	PoisonNew(((char *)ptr), size, char);
+#endif
+
+#ifdef PERL_TRACK_MEMPOOL
+	header->interpreter = aTHX;
+	/* Link us into the list.  */
+	header->prev = &PL_memory_debug_header;
+	header->next = PL_memory_debug_header.next;
+	PL_memory_debug_header.next = header;
+	header->next->prev = header;
+#  ifdef PERL_POISON
+	header->size = size;
+#  endif
         ptr = (Malloc_t)((char*)ptr+sTHX);
 #endif
 	return ptr;
 }
     else if (PL_nomemok)
-	return Nullch;
+	return NULL;
     else {
-	return S_write_no_mem(aTHX);
+	return write_no_mem();
     }
     /*NOTREACHED*/
 }
@@ -134,9 +152,23 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 #ifdef PERL_TRACK_MEMPOOL
     where = (Malloc_t)((char*)where-sTHX);
     size += sTHX;
-    if (*(tTHX*)where != aTHX) {
-	/* int *nowhere = NULL; *nowhere = 0; */
-        Perl_croak_nocontext("panic: realloc from wrong pool");
+    {
+	struct perl_memory_debug_header *const header
+	    = (struct perl_memory_debug_header *)where;
+
+	if (header->interpreter != aTHX) {
+	    Perl_croak_nocontext("panic: realloc from wrong pool");
+	}
+	assert(header->next->prev == header);
+	assert(header->prev->next == header);
+#  ifdef PERL_POISON
+	if (header->size > size) {
+	    const MEM_SIZE freed_up = header->size - size;
+	    char *start_of_freed = ((char *)where) + size;
+	    PoisonFree(start_of_freed, freed_up, char);
+	}
+	header->size = size;
+#  endif
     }
 #endif
 #ifdef DEBUGGING
@@ -149,16 +181,30 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     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 != Nullch) {
+    if (ptr != NULL) {
 #ifdef PERL_TRACK_MEMPOOL
+	struct perl_memory_debug_header *const header
+	    = (struct perl_memory_debug_header *)ptr;
+
+#  ifdef PERL_POISON
+	if (header->size < size) {
+	    const MEM_SIZE fresh = size - header->size;
+	    char *start_of_fresh = ((char *)ptr) + size;
+	    PoisonNew(start_of_fresh, fresh, char);
+	}
+#  endif
+
+	header->next->prev = header;
+	header->prev->next = header;
+
         ptr = (Malloc_t)((char*)ptr+sTHX);
 #endif
 	return ptr;
     }
     else if (PL_nomemok)
-	return Nullch;
+	return NULL;
     else {
-	return S_write_no_mem(aTHX);
+	return write_no_mem();
     }
     /*NOTREACHED*/
 }
@@ -168,17 +214,37 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 Free_t
 Perl_safesysfree(Malloc_t where)
 {
-    dVAR;
 #if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
     dTHX;
+#else
+    dVAR;
 #endif
     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
     if (where) {
 #ifdef PERL_TRACK_MEMPOOL
         where = (Malloc_t)((char*)where-sTHX);
-        if (*(tTHX*)where != aTHX) {
-	    /* int *nowhere = NULL; *nowhere = 0; */
-            Perl_croak_nocontext("panic: free from wrong pool");
+	{
+	    struct perl_memory_debug_header *const header
+		= (struct perl_memory_debug_header *)where;
+
+	    if (header->interpreter != aTHX) {
+		Perl_croak_nocontext("panic: free from wrong pool");
+	    }
+	    if (!header->prev) {
+		Perl_croak_nocontext("panic: duplicate free");
+	    }
+	    if (!(header->next) || header->next->prev != header
+		|| header->prev->next != header) {
+		Perl_croak_nocontext("panic: bad free");
+	    }
+	    /* Unlink us from the chain.  */
+	    header->next->prev = header->prev;
+	    header->prev->next = header->next;
+#  ifdef PERL_POISON
+	    PoisonNew(where, header->size, char);
+#  endif
+	    /* Trigger the duplicate free warning.  */
+	    header->next = NULL;
 	}
 #endif
 	PerlMem_free(where);
@@ -211,20 +277,30 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);	/* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
-    if (ptr != Nullch) {
+    if (ptr != NULL) {
 	memset((void*)ptr, 0, size);
 #ifdef PERL_TRACK_MEMPOOL
-        *(tTHX*)ptr = aTHX;
-        ptr = (Malloc_t)((char*)ptr+sTHX);
+	{
+	    struct perl_memory_debug_header *const header
+		= (struct perl_memory_debug_header *)ptr;
+
+	    header->interpreter = aTHX;
+	    /* Link us into the list.  */
+	    header->prev = &PL_memory_debug_header;
+	    header->next = PL_memory_debug_header.next;
+	    PL_memory_debug_header.next = header;
+	    header->next->prev = header;
+#  ifdef PERL_POISON
+	    header->size = size;
+#  endif
+	    ptr = (Malloc_t)((char*)ptr+sTHX);
+	}
 #endif
 	return ptr;
     }
     else if (PL_nomemok)
-	return Nullch;
-    else {
-	return S_write_no_mem(aTHX);
-    }
-    /*NOTREACHED*/
+	return NULL;
+    return write_no_mem();
 }
 
 /* These must be defined when not using Perl's malloc for binary
@@ -264,6 +340,7 @@ char *
 Perl_delimcpy(pTHX_ 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;
     for (tolen = 0; from < fromend; from++, tolen++) {
 	if (*from == '\\') {
 	    if (from[1] == delim)
@@ -293,6 +370,7 @@ char *
 Perl_instr(pTHX_ register const char *big, register const char *little)
 {
     register I32 first;
+    PERL_UNUSED_CONTEXT;
 
     if (!little)
 	return (char*)big;
@@ -305,45 +383,44 @@ Perl_instr(pTHX_ register const char *big, register const char *little)
 	    continue;
 	for (x=big,s=little; *s; /**/ ) {
 	    if (!*x)
-		return Nullch;
-	    if (*s++ != *x++) {
-		s--;
+		return NULL;
+	    if (*s != *x)
 		break;
+	    else {
+		s++;
+		x++;
 	    }
 	}
 	if (!*s)
 	    return (char*)(big-1);
     }
-    return Nullch;
+    return NULL;
 }
 
 /* same as instr but allow embedded nulls */
 
 char *
-Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
+Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
 {
-    register const I32 first = *little;
-    register const char * const littleend = lend;
-
-    if (!first && little >= littleend)
-	return (char*)big;
-    if (bigend - big < littleend - little)
-	return Nullch;
-    bigend -= littleend - little++;
-    while (big <= bigend) {
-	register const char *s, *x;
-	if (*big++ != first)
-	    continue;
-	for (x=big,s=little; s < littleend; /**/ ) {
-	    if (*s++ != *x++) {
-		s--;
-		break;
-	    }
-	}
-	if (s >= littleend)
-	    return (char*)(big-1);
+    PERL_UNUSED_CONTEXT;
+    if (little >= lend)
+        return (char*)big;
+    {
+        char first = *little++;
+        const char *s, *x;
+        bigend -= lend - little;
+    OUTER:
+        while (big <= bigend) {
+            if (*big++ != first)
+                goto OUTER;
+            for (x=big,s=little; s < lend; x++,s++) {
+                if (*s != *x)
+                    goto OUTER;
+            }
+            return (char*)(big-1);
+        }
     }
-    return Nullch;
+    return NULL;
 }
 
 /* reverse of the above--find last substring */
@@ -354,8 +431,9 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit
     register const char *bigbeg;
     register const I32 first = *little;
     register const char * const littleend = lend;
+    PERL_UNUSED_CONTEXT;
 
-    if (!first && little >= littleend)
+    if (little >= littleend)
 	return (char*)bigend;
     bigbeg = big;
     big = bigend - (littleend - little++);
@@ -364,15 +442,17 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit
 	if (*big-- != first)
 	    continue;
 	for (x=big+2,s=little; s < littleend; /**/ ) {
-	    if (*s++ != *x++) {
-		s--;
+	    if (*s != *x)
 		break;
+	    else {
+		x++;
+		s++;
 	    }
 	}
 	if (s >= littleend)
 	    return (char*)(big+1);
     }
-    return Nullch;
+    return NULL;
 }
 
 #define FBM_TABLE_OFFSET 2	/* Number of bytes between EOS and table*/
@@ -397,6 +477,7 @@ Analyses the string in order to make fast searches on it using fbm_instr()
 void
 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 {
+    dVAR;
     register const U8 *s;
     register U32 i;
     STRLEN len;
@@ -405,7 +486,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 
     if (flags & FBMcf_TAIL) {
 	MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
-	sv_catpvn(sv, "\n", 1);		/* Taken into account in fbm_instr() */
+	sv_catpvs(sv, "\n");		/* Taken into account in fbm_instr() */
 	if (mg && mg->mg_len >= 0)
 	    mg->mg_len++;
     }
@@ -431,7 +512,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 	    s--, i++;
 	}
     }
-    sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0);	/* deep magic */
+    sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0);	/* deep magic */
     SvVALID_on(sv);
 
     s = (const unsigned char*)(SvPVX_const(sv));	/* deeper magic */
@@ -458,7 +539,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 =for apidoc fbm_instr
 
 Returns the location of the SV in the string delimited by C<str> and
-C<strend>.  It returns C<Nullch> if the string can't be found.  The C<sv>
+C<strend>.  It returns C<NULL> if the string can't be found.  The C<sv>
 does not have to be fbm_compiled, but the search will not be as fast
 then.
 
@@ -482,7 +563,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
 		 || (*big == *little &&
 		     memEQ((char *)big, (char *)little, littlelen - 1))))
 	    return (char*)big;
-	return Nullch;
+	return NULL;
     }
 
     if (littlelen <= 2) {		/* Special-cased */
@@ -502,7 +583,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
 	    }
 	    if (SvTAIL(littlestr))
 		return (char *) bigend;
-	    return Nullch;
+	    return NULL;
 	}
 	if (!littlelen)
 	    return (char*)big;		/* Cannot be SvTAIL! */
@@ -513,7 +594,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
 		return (char*)bigend - 2;
 	    if (bigend[-1] == *little)
 		return (char*)bigend - 1;
-	    return Nullch;
+	    return NULL;
 	}
 	{
 	    /* This should be better than FBM if c1 == c2, and almost
@@ -566,7 +647,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
       check_1char_anchor:		/* One char and anchor! */
 	if (SvTAIL(littlestr) && (*bigend == *little))
 	    return (char *)bigend;	/* bigend is already decremented. */
-	return Nullch;
+	return NULL;
     }
     if (SvTAIL(littlestr) && !multiline) {	/* tail anchored? */
 	s = bigend - littlelen;
@@ -581,7 +662,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
 	{
 	    return (char*)s + 1;	/* how sweet it is */
 	}
-	return Nullch;
+	return NULL;
     }
     if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
 	char * const b = ninstr((char*)big,(char*)bigend,
@@ -595,7 +676,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
 	    {
 		return (char*)s;
 	    }
-	    return Nullch;
+	    return NULL;
 	}
 	return b;
     }
@@ -605,7 +686,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
 	register const unsigned char *oldlittle;
 
 	if (littlelen > (STRLEN)(bigend - big))
-	    return Nullch;
+	    return NULL;
 	--littlelen;			/* Last char found by table lookup */
 
 	s = big + littlelen;
@@ -642,7 +723,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
 	     && memEQ((char *)(bigend - littlelen),
 		      (char *)(oldlittle - littlelen), littlelen) )
 	    return (char*)bigend - littlelen;
-	return Nullch;
+	return NULL;
     }
 }
 
@@ -664,6 +745,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
 char *
 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
 {
+    dVAR;
     register const unsigned char *big;
     register I32 pos;
     register I32 previous;
@@ -684,7 +766,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
 	    first = *little++;
 	    goto check_tail;
 	}
-	return Nullch;
+	return NULL;
     }
 
     little = (const unsigned char *)(SvPVX_const(littlestr));
@@ -704,7 +786,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
 	if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
 	    goto check_tail;
 #endif
-	return Nullch;
+	return NULL;
     }
     while (pos < previous + start_shift) {
 	if (!(pos += PL_screamnext[pos]))
@@ -732,7 +814,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
 	return (char *)(big+(*old_posp));
   check_tail:
     if (!SvTAIL(littlestr) || (end_shift > 0))
-	return Nullch;
+	return NULL;
     /* Ignore the trailing "\n".  This code is not microoptimized */
     big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
     stop_pos = littleend - little;	/* Actual littlestr len */
@@ -743,7 +825,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
 	&& ((stop_pos == 1) ||
 	    memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
 	return (char*)big;
-    return Nullch;
+    return NULL;
 }
 
 I32
@@ -751,6 +833,8 @@ Perl_ibcmp(pTHX_ 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;
+
     while (len--) {
 	if (*a != *b && *a != PL_fold[*b])
 	    return 1;
@@ -765,6 +849,8 @@ Perl_ibcmp_locale(pTHX_ 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;
+
     while (len--) {
 	if (*a != *b && *a != PL_fold_locale[*b])
 	    return 1;
@@ -791,15 +877,15 @@ be freed with the C<Safefree()> function.
 char *
 Perl_savepv(pTHX_ const char *pv)
 {
+    PERL_UNUSED_CONTEXT;
     if (!pv)
-	return Nullch;
+	return NULL;
     else {
 	char *newaddr;
 	const STRLEN pvlen = strlen(pv)+1;
 	Newx(newaddr,pvlen,char);
 	return memcpy(newaddr,pv,pvlen);
     }
-
 }
 
 /* same thing but with a known length */
@@ -809,8 +895,8 @@ Perl_savepv(pTHX_ const char *pv)
 
 Perl's version of what C<strndup()> would be if it existed. Returns a
 pointer to a newly allocated string which is a duplicate of the first
-C<len> bytes from C<pv>. The memory allocated for the new string can be
-freed with the C<Safefree()> function.
+C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
+the new string can be freed with the C<Safefree()> function.
 
 =cut
 */
@@ -819,6 +905,7 @@ char *
 Perl_savepvn(pTHX_ const char *pv, register I32 len)
 {
     register char *newaddr;
+    PERL_UNUSED_CONTEXT;
 
     Newx(newaddr,len+1,char);
     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
@@ -846,12 +933,12 @@ Perl_savesharedpv(pTHX_ const char *pv)
     register char *newaddr;
     STRLEN pvlen;
     if (!pv)
-	return Nullch;
+	return NULL;
 
     pvlen = strlen(pv)+1;
     newaddr = (char*)PerlMemShared_malloc(pvlen);
     if (!newaddr) {
-	return S_write_no_mem(aTHX);
+	return write_no_mem();
     }
     return memcpy(newaddr,pv,pvlen);
 }
@@ -883,11 +970,12 @@ Perl_savesvpv(pTHX_ SV *sv)
 STATIC SV *
 S_mess_alloc(pTHX)
 {
+    dVAR;
     SV *sv;
     XPVMG *any;
 
     if (!PL_dirty)
-	return sv_2mortal(newSVpvn("",0));
+	return sv_2mortal(newSVpvs(""));
 
     if (PL_mess_sv)
 	return PL_mess_sv;
@@ -897,7 +985,7 @@ S_mess_alloc(pTHX)
     Newxz(any, 1, XPVMG);
     SvFLAGS(sv) = SVt_PVMG;
     SvANY(sv) = (void*)any;
-    SvPV_set(sv, 0);
+    SvPV_set(sv, NULL);
     SvREFCNT(sv) = 1 << 30; /* practically infinite */
     PL_mess_sv = sv;
     return sv;
@@ -952,7 +1040,7 @@ char *
 Perl_vform(pTHX_ const char *pat, va_list *args)
 {
     SV * const sv = mess_alloc();
-    sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+    sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     return SvPVX(sv);
 }
 
@@ -981,46 +1069,47 @@ Perl_mess(pTHX_ const char *pat, ...)
     return retval;
 }
 
-STATIC COP*
-S_closest_cop(pTHX_ COP *cop, const OP *o)
+STATIC const COP*
+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. */
 
-    if (!o || o == PL_op) return cop;
+    if (!o || o == PL_op)
+	return cop;
 
     if (o->op_flags & OPf_KIDS) {
-	OP *kid;
-	for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
-	{
-	    COP *new_cop;
+	const OP *kid;
+	for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
+	    const COP *new_cop;
 
 	    /* If the OP_NEXTSTATE has been optimised away we can still use it
 	     * the get the file and line number. */
 
 	    if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
-		cop = (COP *)kid;
+		cop = (const COP *)kid;
 
 	    /* Keep searching, and return when we've found something. */
 
 	    new_cop = closest_cop(cop, kid);
-	    if (new_cop) return new_cop;
+	    if (new_cop)
+		return new_cop;
 	}
     }
 
     /* Nothing found. */
 
-    return Null(COP *);
+    return NULL;
 }
 
 SV *
 Perl_vmess(pTHX_ const char *pat, va_list *args)
 {
+    dVAR;
     SV * const sv = mess_alloc();
-    static const char dgd[] = " during global destruction.\n";
 
-    sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+    sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
-
 	/*
 	 * Try and find the file and line for PL_op.  This will usually be
 	 * PL_curcop, but it might be a cop that has been optimised away.  We
@@ -1029,7 +1118,8 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
 	 */
 
 	const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
-	if (!cop) cop = PL_curcop;
+	if (!cop)
+	    cop = PL_curcop;
 
 	if (CopLINE(cop))
 	    Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
@@ -1038,12 +1128,13 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
 	    const bool line_mode = (RsSIMPLE(PL_rs) &&
 			      SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
 	    Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
-			   PL_last_in_gv == PL_argvgv ?
-			   "" : GvNAME(PL_last_in_gv),
+			   PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
 			   line_mode ? "line" : "chunk",
 			   (IV)IoLINES(GvIOp(PL_last_in_gv)));
 	}
-	sv_catpv(sv, PL_dirty ? dgd : ".\n");
+	if (PL_dirty)
+	    sv_catpvs(sv, " during global destruction");
+	sv_catpvs(sv, ".\n");
     }
     return sv;
 }
@@ -1065,7 +1156,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
 
 	save_re_context();
 	SAVESPTR(PL_stderrgv);
-	PL_stderrgv = Nullgv;
+	PL_stderrgv = NULL;
 
 	PUSHSTACKi(PERLSI_MAGIC);
 
@@ -1095,22 +1186,25 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
     }
 }
 
-/* Common code used by vcroak, vdie and vwarner  */
+/* Common code used by vcroak, vdie, vwarn and vwarner  */
 
-STATIC void
-S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
+STATIC bool
+S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
 {
+    dVAR;
     HV *stash;
     GV *gv;
     CV *cv;
-    /* sv_2cv might call Perl_croak() */
-    SV * const olddiehook = PL_diehook;
+    SV **const hook = warn ? &PL_warnhook : &PL_diehook;
+    /* sv_2cv might call Perl_croak() or Perl_warner() */
+    SV * const oldhook = *hook;
+
+    assert(oldhook);
 
-    assert(PL_diehook);
     ENTER;
-    SAVESPTR(PL_diehook);
-    PL_diehook = Nullsv;
-    cv = sv_2cv(olddiehook, &stash, &gv, 0);
+    SAVESPTR(*hook);
+    *hook = NULL;
+    cv = sv_2cv(oldhook, &stash, &gv, 0);
     LEAVE;
     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
 	dSP;
@@ -1118,7 +1212,11 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
 
 	ENTER;
 	save_re_context();
-	if (message) {
+	if (warn) {
+	    SAVESPTR(*hook);
+	    *hook = NULL;
+	}
+	if (warn || message) {
 	    msg = newSVpvn(message, msglen);
 	    SvFLAGS(msg) |= utf8;
 	    SvREADONLY_on(msg);
@@ -1128,14 +1226,16 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
 	    msg = ERRSV;
 	}
 
-	PUSHSTACKi(PERLSI_DIEHOOK);
+	PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
 	PUSHMARK(SP);
 	XPUSHs(msg);
 	PUTBACK;
 	call_sv((SV*)cv, G_DISCARD);
 	POPSTACK;
 	LEAVE;
+	return TRUE;
     }
+    return FALSE;
 }
 
 STATIC const char *
@@ -1157,14 +1257,14 @@ S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
 	*utf8 = SvUTF8(msv);
     }
     else {
-	message = Nullch;
+	message = NULL;
     }
 
     DEBUG_S(PerlIO_printf(Perl_debug_log,
 			  "%p: die/croak: message = %s\ndiehook = %p\n",
 			  thr, message, PL_diehook));
     if (PL_diehook) {
-	S_vdie_common(aTHX_ message, *msglen, *utf8);
+	S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
     }
     return message;
 }
@@ -1172,6 +1272,7 @@ S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
 OP *
 Perl_vdie(pTHX_ const char* pat, va_list *args)
 {
+    dVAR;
     const char *message;
     const int was_in_eval = PL_in_eval;
     STRLEN msglen;
@@ -1221,6 +1322,7 @@ Perl_die(pTHX_ const char* pat, ...)
 void
 Perl_vcroak(pTHX_ const char* pat, va_list *args)
 {
+    dVAR;
     const char *message;
     STRLEN msglen;
     I32 utf8 = 0;
@@ -1263,11 +1365,11 @@ function.  Calling C<croak> returns control directly to Perl,
 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<Nullch> to croak():
+C<$@> and then pass C<NULL> to croak():
 
    errsv = get_sv("@", TRUE);
    sv_setsv(errsv, exception_object);
-   croak(Nullch);
+   croak(NULL);
 
 =cut
 */
@@ -1292,39 +1394,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
     const char * const message = SvPV_const(msv, msglen);
 
     if (PL_warnhook) {
-	/* sv_2cv might call Perl_warn() */
-	SV * const oldwarnhook = PL_warnhook;
-	CV * cv;
-	HV * stash;
-	GV * gv;
-
-	ENTER;
-	SAVESPTR(PL_warnhook);
-	PL_warnhook = Nullsv;
-	cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
-	LEAVE;
-	if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
-	    dSP;
-	    SV *msg;
-
-	    ENTER;
-	    SAVESPTR(PL_warnhook);
-	    PL_warnhook = Nullsv;
-	    save_re_context();
-	    msg = newSVpvn(message, msglen);
-	    SvFLAGS(msg) |= utf8;
-	    SvREADONLY_on(msg);
-	    SAVEFREESV(msg);
-
-	    PUSHSTACKi(PERLSI_WARNHOOK);
-	    PUSHMARK(SP);
-	    XPUSHs(msg);
-	    PUTBACK;
-	    call_sv((SV*)cv, G_DISCARD);
-	    POPSTACK;
-	    LEAVE;
+	if (vdie_common(message, msglen, utf8, TRUE))
 	    return;
-	}
     }
 
     write_to_stderr(message, msglen);
@@ -1393,7 +1464,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 
 	if (PL_diehook) {
 	    assert(message);
-	    S_vdie_common(aTHX_ message, msglen, utf8);
+	    S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
 	}
 	if (PL_in_eval) {
 	    PL_restartop = die_where(message, msglen);
@@ -1413,6 +1484,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 bool
 Perl_ckwarn(pTHX_ U32 w)
 {
+    dVAR;
     return
 	(
 	       isLEXWARN_on
@@ -1440,6 +1512,7 @@ Perl_ckwarn(pTHX_ U32 w)
 bool
 Perl_ckwarn_d(pTHX_ U32 w)
 {
+    dVAR;
     return
 	   isLEXWARN_off
 	|| PL_curcop->cop_warnings == pWARN_ALL
@@ -1458,7 +1531,18 @@ Perl_ckwarn_d(pTHX_ U32 w)
 	;
 }
 
-
+/* Set buffer=NULL to get a new one.  */
+STRLEN *
+Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
+			   STRLEN size) {
+    const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
+
+    buffer = specialWARN(buffer) ? PerlMemShared_malloc(len_wanted)
+	: PerlMemShared_realloc(buffer, len_wanted);
+    buffer[0] = size;
+    Copy(bits, (buffer + 1), size, char);
+    return buffer;
+}
 
 /* since we've already done strlen() for both nam and val
  * we can use that info to make things faster than
@@ -1500,7 +1584,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
 	    tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
 	    Copy(environ[j], tmpenv[j], len+1, char);
 	}
-	tmpenv[max] = Nullch;
+	tmpenv[max] = NULL;
 	environ = tmpenv;		/* tell exec where it is now */
     }
     if (!val) {
@@ -1513,19 +1597,19 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
     }
     if (!environ[i]) {			/* does not exist yet */
 	environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
-	environ[i+1] = Nullch;	/* make sure it's null terminated */
+	environ[i+1] = NULL;	/* make sure it's null terminated */
     }
     else
 	safesysfree(environ[i]);
-    nlen = strlen(nam);
-    vlen = strlen(val);
+	nlen = strlen(nam);
+	vlen = strlen(val);
 
-    environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
-    /* all that work just for this */
-    my_setenv_format(environ[i], nam, nlen, val, vlen);
+	environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
+	/* all that work just for this */
+	my_setenv_format(environ[i], nam, nlen, val, vlen);
     } else {
 # endif
-#   if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__)
+#   if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
 #       if defined(HAS_UNSETENV)
         if (val == NULL) {
             (void)unsetenv(nam);
@@ -1595,6 +1679,7 @@ 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 (
@@ -1809,8 +1894,8 @@ Perl_my_ntohl(pTHX_ long l)
 		type value;					\
 		char c[sizeof(type)];				\
 	    } u;						\
-	    register I32 i;					\
-	    register I32 s = 0;					\
+	    register U32 i;					\
+	    register U32 s = 0;					\
 	    for (i = 0; i < sizeof(u.c); i++, s += 8) {		\
 		u.c[i] = (n >> s) & 0xFF;			\
 	    }							\
@@ -1825,8 +1910,8 @@ Perl_my_ntohl(pTHX_ long l)
 		type value;					\
 		char c[sizeof(type)];				\
 	    } u;						\
-	    register I32 i;					\
-	    register I32 s = 0;					\
+	    register U32 i;					\
+	    register U32 s = 0;					\
 	    u.value = n;					\
 	    n = 0;						\
 	    for (i = 0; i < sizeof(u.c); i++, s += 8) {		\
@@ -1847,8 +1932,8 @@ Perl_my_ntohl(pTHX_ long l)
 		type value;					\
 		char c[sizeof(type)];				\
 	    } u;						\
-	    register I32 i;					\
-	    register I32 s = 8*(sizeof(u.c)-1);			\
+	    register U32 i;					\
+	    register U32 s = 8*(sizeof(u.c)-1);			\
 	    for (i = 0; i < sizeof(u.c); i++, s -= 8) {		\
 		u.c[i] = (n >> s) & 0xFF;			\
 	    }							\
@@ -1863,8 +1948,8 @@ Perl_my_ntohl(pTHX_ long l)
 		type value;					\
 		char c[sizeof(type)];				\
 	    } u;						\
-	    register I32 i;					\
-	    register I32 s = 8*(sizeof(u.c)-1);			\
+	    register U32 i;					\
+	    register U32 s = 8*(sizeof(u.c)-1);			\
 	    u.value = n;					\
 	    n = 0;						\
 	    for (i = 0; i < sizeof(u.c); i++, s -= 8) {		\
@@ -2043,6 +2128,7 @@ PerlIO *
 Perl_my_popen_list(pTHX_ 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)
+    dVAR;
     int p[2];
     register I32 This, that;
     register Pid_t pid;
@@ -2058,7 +2144,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
 	taint_proper("Insecure %s%s", "EXEC");
     }
     if (PerlProc_pipe(p) < 0)
-	return Nullfp;
+	return NULL;
     /* Try for another pipe pair for error return */
     if (PerlProc_pipe(pp) >= 0)
 	did_pipes = 1;
@@ -2070,7 +2156,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
 		PerlLIO_close(pp[0]);
 		PerlLIO_close(pp[1]);
 	    }
-	    return Nullfp;
+	    return NULL;
 	}
 	sleep(5);
     }
@@ -2111,7 +2197,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
 	    }
 	}
 #endif
-	do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
+	do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
 	PerlProc__exit(1);
 #undef THIS
 #undef THAT
@@ -2138,7 +2224,8 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
     /* If we managed to get status pipe check for exec fail */
     if (did_pipes && pid > 0) {
 	int errkid;
-	int n = 0, n1;
+	unsigned n = 0;
+	SSize_t n1;
 
 	while (n < sizeof(int)) {
 	    n1 = PerlLIO_read(pp[0],
@@ -2159,7 +2246,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
 		pid2 = wait4pid(pid, &status, 0);
 	    } while (pid2 == -1 && errno == EINTR);
 	    errno = errkid;		/* Propagate errno from kid */
-	    return Nullfp;
+	    return NULL;
 	}
     }
     if (did_pipes)
@@ -2176,6 +2263,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
 PerlIO *
 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
+    dVAR;
     int p[2];
     register I32 This, that;
     register Pid_t pid;
@@ -2197,7 +2285,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 	taint_proper("Insecure %s%s", "EXEC");
     }
     if (PerlProc_pipe(p) < 0)
-	return Nullfp;
+	return NULL;
     if (doexec && PerlProc_pipe(pp) >= 0)
 	did_pipes = 1;
     while ((pid = PerlProc_fork()) < 0) {
@@ -2210,7 +2298,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 	    }
 	    if (!doexec)
 		Perl_croak(aTHX_ "Can't fork");
-	    return Nullfp;
+	    return NULL;
 	}
 	sleep(5);
     }
@@ -2254,7 +2342,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 	    PerlProc__exit(1);
 	}
 #endif	/* defined OS2 */
-	if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
+	if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
 	    SvREADONLY_off(GvSV(tmpgv));
 	    sv_setiv(GvSV(tmpgv), PerlProc_getpid());
 	    SvREADONLY_on(GvSV(tmpgv));
@@ -2266,7 +2354,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 #ifdef PERL_USES_PL_PIDSTATUS
 	hv_clear(PL_pidstatus);	/* we have no children */
 #endif
-	return Nullfp;
+	return NULL;
 #undef THIS
 #undef THAT
     }
@@ -2289,7 +2377,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
     PL_forkprocess = pid;
     if (did_pipes && pid > 0) {
 	int errkid;
-	int n = 0, n1;
+	unsigned n = 0;
+	SSize_t n1;
 
 	while (n < sizeof(int)) {
 	    n1 = PerlLIO_read(pp[0],
@@ -2310,7 +2399,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 		pid2 = wait4pid(pid, &status, 0);
 	    } while (pid2 == -1 && errno == EINTR);
 	    errno = errkid;		/* Propagate errno from kid */
-	    return Nullfp;
+	    return NULL;
 	}
     }
     if (did_pipes)
@@ -2490,6 +2579,7 @@ Sighandler_t
 Perl_rsignal_state(pTHX_ int signo)
 {
     struct sigaction oact;
+    PERL_UNUSED_CONTEXT;
 
     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
 	return (Sighandler_t) SIG_ERR;
@@ -2550,8 +2640,7 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
     return PerlProc_signal(signo, handler);
 }
 
-static
-Signal_t
+static Signal_t
 sig_trap(int signo)
 {
     dVAR;
@@ -2609,6 +2698,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
 I32
 Perl_my_pclose(pTHX_ PerlIO *ptr)
 {
+    dVAR;
     Sigsave_t hstat, istat, qstat;
     int status;
     SV **svp;
@@ -2665,6 +2755,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 I32
 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 {
+    dVAR;
     I32 result = 0;
     if (!pid)
 	return -1;
@@ -2715,7 +2806,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
     goto finish;
 #endif
 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
-    result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
+    result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
     goto finish;
 #endif
 #ifdef PERL_USES_PL_PIDSTATUS
@@ -2794,6 +2885,7 @@ Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, regi
 {
     register I32 todo;
     register const char * const frombase = from;
+    PERL_UNUSED_CONTEXT;
 
     if (len == 1) {
 	register const char c = *from;
@@ -2850,8 +2942,9 @@ char*
 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 		 const char *const *const search_ext, I32 flags)
 {
-    const char *xfound = Nullch;
-    char *xfailed = Nullch;
+    dVAR;
+    const char *xfound = NULL;
+    char *xfailed = NULL;
     char tmpbuf[MAXPATHLEN];
     register char *s;
     I32 len = 0;
@@ -2873,7 +2966,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
     static const char *const exts[] = { SEARCH_EXTS };
     const char *const *const ext = search_ext ? search_ext : exts;
     int extidx = 0, i = 0;
-    const char *curext = Nullch;
+    const char *curext = NULL;
 #else
     PERL_UNUSED_ARG(search_ext);
 #  define MAX_EXT_LEN 0
@@ -2906,13 +2999,13 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 	int idx = 0, deftypes = 1;
 	bool seen_dot = 1;
 
-	const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch);
+	const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
 #  else
     if (dosearch) {
 	int idx = 0, deftypes = 1;
 	bool seen_dot = 1;
 
-	const int hasdir = (strpbrk(scriptname,":[</") != Nullch);
+	const int hasdir = (strpbrk(scriptname,":[</") != NULL);
 #  endif
 	/* The first time through, just add SEARCH_EXTS to whatever we
 	 * already have, so we can check for default file types. */
@@ -3022,9 +3115,13 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 	    if (len == 2 && tmpbuf[0] == '.')
 		seen_dot = 1;
 #endif
+#ifdef HAS_STRLCAT
+	    (void)strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
+#else
 	    /* FIXME? Convert to memcpy by storing previous strlen(scriptname)
 	     */
 	    (void)strcpy(tmpbuf + len, scriptname);
+#endif /* #ifdef HAS_STRLCAT */
 #endif  /* !VMS */
 
 #ifdef SEARCH_EXTS
@@ -3073,12 +3170,12 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 		      (xfailed ? "" : " on PATH"),
 		      (xfailed || seen_dot) ? "" : ", '.' not in PATH");
 	    }
-	    scriptname = Nullch;
+	    scriptname = NULL;
 	}
 	Safefree(xfailed);
 	scriptname = xfound;
     }
-    return (scriptname ? savepv(scriptname) : Nullch);
+    return (scriptname ? savepv(scriptname) : NULL);
 }
 
 #ifndef PERL_GET_CONTEXT_DEFINED
@@ -3134,32 +3231,37 @@ Perl_GetVars(pTHX)
 char **
 Perl_get_op_names(pTHX)
 {
- return (char **)PL_op_name;
+    PERL_UNUSED_CONTEXT;
+    return (char **)PL_op_name;
 }
 
 char **
 Perl_get_op_descs(pTHX)
 {
- return (char **)PL_op_desc;
+    PERL_UNUSED_CONTEXT;
+    return (char **)PL_op_desc;
 }
 
 const char *
 Perl_get_no_modify(pTHX)
 {
- return PL_no_modify;
+    PERL_UNUSED_CONTEXT;
+    return PL_no_modify;
 }
 
 U32 *
 Perl_get_opargs(pTHX)
 {
- return (U32 *)PL_opargs;
+    PERL_UNUSED_CONTEXT;
+    return (U32 *)PL_opargs;
 }
 
 PPADDR_t*
 Perl_get_ppaddr(pTHX)
 {
- dVAR;
- return (PPADDR_t*)PL_ppaddr;
+    dVAR;
+    PERL_UNUSED_CONTEXT;
+    return (PPADDR_t*)PL_ppaddr;
 }
 
 #ifndef HAS_GETENV_LEN
@@ -3167,6 +3269,7 @@ char *
 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
 {
     char * const env_trans = PerlEnv_getenv(env_elem);
+    PERL_UNUSED_CONTEXT;
     if (env_trans)
 	*len = strlen(env_trans);
     return env_trans;
@@ -3178,6 +3281,7 @@ MGVTBL*
 Perl_get_vtbl(pTHX_ int vtbl_id)
 {
     const MGVTBL* result;
+    PERL_UNUSED_CONTEXT;
 
     switch(vtbl_id) {
     case want_vtbl_sv:
@@ -3213,9 +3317,6 @@ Perl_get_vtbl(pTHX_ int vtbl_id)
     case want_vtbl_arylen:
 	result = &PL_vtbl_arylen;
 	break;
-    case want_vtbl_glob:
-	result = &PL_vtbl_glob;
-	break;
     case want_vtbl_mglob:
 	result = &PL_vtbl_mglob;
 	break;
@@ -3273,7 +3374,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id)
 	result = &PL_vtbl_utf8;
 	break;
     default:
-	result = Null(MGVTBL*);
+	result = NULL;
 	break;
     }
     return (MGVTBL*)result;
@@ -3332,14 +3433,6 @@ Perl_my_fflush_all(pTHX)
 void
 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
 {
-    const char * const func =
-	op == OP_READLINE   ? "readline"  :	/* "<HANDLE>" not nice */
-	op == OP_LEAVEWRITE ? "write" :		/* "write exit" not nice */
-	PL_op_desc[op];
-    const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
-    const char * const type = OP_IS_SOCKET(op)
-	    || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
-		?  "socket" : "filehandle";
     const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
 
     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
@@ -3368,6 +3461,15 @@ Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
 	}
 
 	if (ckWARN(warn_type)) {
+	    const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
+	    const char * const func =
+		op == OP_READLINE   ? "readline"  :	/* "<HANDLE>" not nice */
+		op == OP_LEAVEWRITE ? "write" :		/* "write exit" not nice */
+		op < 0              ? "" :              /* handle phoney cases */
+		PL_op_desc[op];
+	    const char * const type = OP_IS_SOCKET(op)
+		    || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
+			?  "socket" : "filehandle";
 	    if (name && *name) {
 		Perl_warner(aTHX_ packWARN(warn_type),
 			    "%s%s on %s %s %s", func, pars, vile, type, name);
@@ -3480,6 +3582,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm)
     int secs;
     int month, mday, year, jday;
     int odd_cent, odd_year;
+    PERL_UNUSED_CONTEXT;
 
 #define	DAYS_PER_YEAR	365
 #define	DAYS_PER_QYEAR	(4*DAYS_PER_YEAR+1)
@@ -3776,7 +3879,7 @@ int
 Perl_getcwd_sv(pTHX_ register SV *sv)
 {
 #ifndef PERL_MICRO
-
+    dVAR;
 #ifndef INCOMPLETE_TAINTS
     SvTAINTED_on(sv);
 #endif
@@ -3987,6 +4090,9 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 	pos++;
     }
 
+    if ( alpha && !saw_period )
+	Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
+
     if ( saw_period > 1 )
 	qv = 1; /* force quoted version processing */
 
@@ -4104,6 +4210,7 @@ want to upgrade the SV.
 SV *
 Perl_new_version(pTHX_ SV *ver)
 {
+    dVAR;
     SV * const rv = newSV(0);
     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
     {
@@ -4129,11 +4236,11 @@ Perl_new_version(pTHX_ SV *ver)
 	
 	if ( hv_exists((HV*)ver, "width", 5 ) )
 	{
-	    const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE));
+	    const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
 	    hv_store((HV *)hv, "width", 5, newSViv(width), 0);
 	}
 
-	sav = (AV *)SvRV(*hv_fetch((HV*)ver, "version", 7, FALSE));
+	sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
 	/* This will get reblessed later if a derived class*/
 	for ( key = 0; key <= av_len(sav); key++ )
 	{
@@ -4145,21 +4252,22 @@ Perl_new_version(pTHX_ SV *ver)
 	return rv;
     }
 #ifdef SvVOK
-    if ( SvVOK(ver) ) { /* already a v-string */
-	const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
-	const STRLEN len = mg->mg_len;
-	char * const version = savepvn( (const char*)mg->mg_ptr, len);
-	sv_setpvn(rv,version,len);
-	Safefree(version);
-    }
-    else {
+    {
+	const MAGIC* const mg = SvVOK(ver);
+	if ( mg ) { /* already a v-string */
+	    const STRLEN len = mg->mg_len;
+	    char * const version = savepvn( (const char*)mg->mg_ptr, len);
+	    sv_setpvn(rv,version,len);
+	    Safefree(version);
+	}
+	else {
 #endif
-    sv_setsv(rv,ver); /* make a duplicate */
+	sv_setsv(rv,ver); /* make a duplicate */
 #ifdef SvVOK
+	}
     }
 #endif
-    upg_version(rv);
-    return rv;
+    return upg_version(rv);
 }
 
 /*
@@ -4177,18 +4285,24 @@ Returns a pointer to the upgraded SV.
 SV *
 Perl_upg_version(pTHX_ SV *ver)
 {
-    char *version;
+    const char *version, *s;
     bool qv = 0;
+#ifdef SvVOK
+    const MAGIC *mg;
+#endif
 
     if ( SvNOK(ver) ) /* may get too much accuracy */ 
     {
 	char tbuf[64];
-	const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
+#ifdef USE_SNPRINTF
+	const STRLEN len = snprintf(tbuf, sizeof(tbuf), "%.9"NVgf, SvNVX(ver));
+#else
+	const STRLEN len = my_sprintf(tbuf, "%.9"NVgf, SvNVX(ver));
+#endif /* #ifdef USE_SNPRINTF */
 	version = savepvn(tbuf, len);
     }
 #ifdef SvVOK
-    else if ( SvVOK(ver) ) { /* already a v-string */
-	const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
+    else if ( (mg = SvVOK(ver)) ) { /* already a v-string */
 	version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
 	qv = 1;
     }
@@ -4197,7 +4311,12 @@ Perl_upg_version(pTHX_ SV *ver)
     {
 	version = savepv(SvPV_nolen(ver));
     }
-    (void)scan_version(version, ver, 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);
     Safefree(version);
     return ver;
 }
@@ -4235,7 +4354,7 @@ Perl_vverify(pTHX_ SV *vs)
     /* see if the appropriate elements exist */
     if ( SvTYPE(vs) == SVt_PVHV
 	 && hv_exists((HV*)vs, "version", 7)
-	 && (sv = SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)))
+	 && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
 	 && SvTYPE(sv) == SVt_PVAV )
 	return TRUE;
     else
@@ -4274,21 +4393,21 @@ Perl_vnumify(pTHX_ SV *vs)
     if ( hv_exists((HV*)vs, "alpha", 5 ) )
 	alpha = TRUE;
     if ( hv_exists((HV*)vs, "width", 5 ) )
-	width = SvIV(*hv_fetch((HV*)vs, "width", 5, FALSE));
+	width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
     else
 	width = 3;
 
 
     /* attempt to retrieve the version array */
-    if ( !(av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)) ) ) {
-	sv_catpvn(sv,"0",1);
+    if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
+	sv_catpvs(sv,"0");
 	return sv;
     }
 
     len = av_len(av);
     if ( len == -1 )
     {
-	sv_catpvn(sv,"0",1);
+	sv_catpvs(sv,"0");
 	return sv;
     }
 
@@ -4298,7 +4417,7 @@ Perl_vnumify(pTHX_ SV *vs)
     {
 	digit = SvIV(*av_fetch(av, i, 0));
 	if ( width < 3 ) {
-	    const int denom = (int)pow(10,(3-width));
+	    const int denom = (width == 2 ? 10 : 100);
 	    const div_t term = div((int)PERL_ABS(digit),denom);
 	    Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
 	}
@@ -4311,12 +4430,12 @@ Perl_vnumify(pTHX_ SV *vs)
     {
 	digit = SvIV(*av_fetch(av, len, 0));
 	if ( alpha && width == 3 ) /* alpha version */
-	    sv_catpvn(sv,"_",1);
+	    sv_catpvs(sv,"_");
 	Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
     }
     else /* len == 0 */
     {
-	sv_catpvn(sv,"000",3);
+	sv_catpvs(sv, "000");
     }
     return sv;
 }
@@ -4350,12 +4469,12 @@ Perl_vnormal(pTHX_ SV *vs)
 
     if ( hv_exists((HV*)vs, "alpha", 5 ) )
 	alpha = TRUE;
-    av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE));
+    av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
 
     len = av_len(av);
     if ( len == -1 )
     {
-	sv_catpvn(sv,"",0);
+	sv_catpvs(sv,"");
 	return sv;
     }
     digit = SvIV(*av_fetch(av, 0, 0));
@@ -4377,7 +4496,7 @@ Perl_vnormal(pTHX_ SV *vs)
 
     if ( len <= 2 ) { /* short version, must be at least three */
 	for ( len = 2 - len; len != 0; len-- )
-	    sv_catpvn(sv,".0",2);
+	    sv_catpvs(sv,".0");
     }
     return sv;
 }
@@ -4438,12 +4557,12 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
 	Perl_croak(aTHX_ "Invalid version object");
 
     /* get the left hand term */
-    lav = (AV *)SvRV(*hv_fetch((HV*)lhv, "version", 7, FALSE));
+    lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
     if ( hv_exists((HV*)lhv, "alpha", 5 ) )
 	lalpha = TRUE;
 
     /* and the right hand term */
-    rav = (AV *)SvRV(*hv_fetch((HV*)rhv, "version", 7, FALSE));
+    rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
     if ( hv_exists((HV*)rhv, "alpha", 5 ) )
 	ralpha = TRUE;
 
@@ -4579,8 +4698,8 @@ S_socketpair_udp (int fd[2]) {
 	fd_set rset;
 
 	FD_ZERO(&rset);
-	FD_SET(sockets[0], &rset);
-	FD_SET(sockets[1], &rset);
+	FD_SET((unsigned int)sockets[0], &rset);
+	FD_SET((unsigned int)sockets[1], &rset);
 
 	got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
 	if (got != 2 || !FD_ISSET(sockets[0], &rset)
@@ -4777,6 +4896,7 @@ potentially warn under some level of strict-ness.
 void
 Perl_sv_nosharing(pTHX_ SV *sv)
 {
+    PERL_UNUSED_CONTEXT;
     PERL_UNUSED_ARG(sv);
 }
 
@@ -4814,6 +4934,8 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
 		      opt |= PERL_UNICODE_LOCALE_FLAG;	break;
 		 case PERL_UNICODE_ARGV:
 		      opt |= PERL_UNICODE_ARGV_FLAG;	break;
+		 case PERL_UNICODE_UTF8CACHEASSERT:
+		      opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
 		 default:
 		      if (*p != '\n' && *p != '\r')
 			  Perl_croak(aTHX_
@@ -4837,6 +4959,7 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
 U32
 Perl_seed(pTHX)
 {
+    dVAR;
     /*
      * This is really just a quick hack which grabs various garbage
      * values.  It really should be a real hash algorithm which
@@ -4918,6 +5041,7 @@ Perl_seed(pTHX)
 UV
 Perl_get_hash_seed(pTHX)
 {
+    dVAR;
      const char *s = PerlEnv_getenv("PERL_HASH_SEED");
      UV myseed = 0;
 
@@ -4958,6 +5082,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;
 
     if (stashpv == name)
 	return TRUE;
@@ -5058,7 +5183,7 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t
 				  " %s = %"IVdf": %"UVxf"\n",
 				  filename, linenumber, funcname, n, typesize,
 				  typename, n * typesize, PTR2UV(newalloc));
-    PerlLIO_write(2,  buf, len));
+    PerlLIO_write(2,  buf, len);
 #endif
     return newalloc;
 }
@@ -5170,6 +5295,47 @@ Perl_my_clearenv(pTHX)
 #endif /* PERL_MICRO */
 }
 
+#ifdef PERL_IMPLICIT_CONTEXT
+
+/* implements the MY_CXT_INIT macro. The first time a module is loaded,
+the global PL_my_cxt_index is incremented, and that value is assigned to
+that module's static my_cxt_index (who's address is passed as an arg).
+Then, for each interpreter this function is called for, it makes sure a
+void* slot is available to hang the static data off, by allocating or
+extending the interpreter's PL_my_cxt_list array */
+
+void *
+Perl_my_cxt_init(pTHX_ int *index, size_t size)
+{
+    dVAR;
+    void *p;
+    if (*index == -1) {
+	/* this module hasn't been allocated an index yet */
+	MUTEX_LOCK(&PL_my_ctx_mutex);
+	*index = PL_my_cxt_index++;
+	MUTEX_UNLOCK(&PL_my_ctx_mutex);
+    }
+    
+    /* make sure the array is big enough */
+    if (PL_my_cxt_size <= *index) {
+	if (PL_my_cxt_size) {
+	    while (PL_my_cxt_size <= *index)
+		PL_my_cxt_size *= 2;
+	    Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
+	}
+	else {
+	    PL_my_cxt_size = 16;
+	    Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
+	}
+    }
+    /* newSV() allocates one more than needed */
+    p = (void*)SvPVX(newSV(size-1));
+    PL_my_cxt_list[*index] = p;
+    Zero(p, size, char);
+    return p;
+}
+#endif
+
 /*
  * Local variables:
  * c-indentation-style: bsd