X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a7cb70fb771fb5beedde33170ea9e6b2b2c36bf9..66610fdd5da795f6de595e815ccc4d1c9f3f4505:/util.c

diff --git a/util.c b/util.c
index 824b3a0..03201dd 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, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, 2005, 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.
@@ -13,6 +13,12 @@
  * not content."  --Gandalf
  */
 
+/* This file contains assorted utility routines.
+ * Which is a polite way of saying any stuff that people couldn't think of
+ * a better place for. Amongst other things, it includes the warning and
+ * dieing stuff, plus wrappers for malloc code.
+ */
+
 #include "EXTERN.h"
 #define PERL_IN_UTIL_C
 #include "perl.h"
@@ -135,6 +141,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 Free_t
 Perl_safesysfree(Malloc_t where)
 {
+    dVAR;
 #ifdef PERL_IMPLICIT_SYS
     dTHX;
 #endif
@@ -218,7 +225,7 @@ 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 char *toend, register char *from, register char *fromend, register int delim, I32 *retlen)
+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;
     for (tolen = 0; from < fromend; from++, tolen++) {
@@ -240,7 +247,7 @@ Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from
     if (to < toend)
 	*to = '\0';
     *retlen = tolen;
-    return from;
+    return (char *)from;
 }
 
 /* return ptr to little string in big string, NULL if not found */
@@ -280,7 +287,7 @@ char *
 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
 {
     register const char *s, *x;
-    register I32 first = *little;
+    register const I32 first = *little;
     register const char *littleend = lend;
 
     if (!first && little >= littleend)
@@ -310,7 +317,7 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit
 {
     register const char *bigbeg;
     register const char *s, *x;
-    register I32 first = *little;
+    register const I32 first = *little;
     register const char *littleend = lend;
 
     if (!first && little >= littleend)
@@ -433,7 +440,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
     STRLEN l;
     register unsigned char *little = (unsigned char *)SvPV(littlestr,l);
     register STRLEN littlelen = l;
-    register I32 multiline = flags & FBMrf_MULTILINE;
+    register const I32 multiline = flags & FBMrf_MULTILINE;
 
     if ((STRLEN)(bigend - big) < littlelen) {
 	if ( SvTAIL(littlestr)
@@ -561,7 +568,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
     }
 
     {	/* Do actual FBM.  */
-	register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
+	register const unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
 	register unsigned char *oldlittle;
 
 	if (littlelen > (STRLEN)(bigend - big))
@@ -710,8 +717,8 @@ 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)
 {
-    register U8 *a = (U8 *)s1;
-    register U8 *b = (U8 *)s2;
+    register const U8 *a = (const U8 *)s1;
+    register const U8 *b = (const U8 *)s2;
     while (len--) {
 	if (*a != *b && *a != PL_fold[*b])
 	    return 1;
@@ -723,8 +730,9 @@ 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)
 {
-    register U8 *a = (U8 *)s1;
-    register U8 *b = (U8 *)s2;
+    dVAR;
+    register const U8 *a = (const U8 *)s1;
+    register const U8 *b = (const U8 *)s2;
     while (len--) {
 	if (*a != *b && *a != PL_fold_locale[*b])
 	    return 1;
@@ -751,12 +759,20 @@ be freed with the C<Safefree()> function.
 char *
 Perl_savepv(pTHX_ const char *pv)
 {
-    register char *newaddr = Nullch;
-    if (pv) {
-	New(902,newaddr,strlen(pv)+1,char);
-	(void)strcpy(newaddr,pv);
-    }
-    return newaddr;
+    register char *newaddr;
+#ifdef PERL_MALLOC_WRAP
+    STRLEN pvlen;
+#endif
+    if (!pv)
+	return Nullch;
+
+#ifdef PERL_MALLOC_WRAP
+    pvlen = strlen(pv)+1;
+    New(902,newaddr,pvlen,char);
+#else
+    New(902,newaddr,strlen(pv)+1,char);
+#endif
+    return strcpy(newaddr,pv);
 }
 
 /* same thing but with a known length */
@@ -780,13 +796,13 @@ Perl_savepvn(pTHX_ const char *pv, register I32 len)
     New(903,newaddr,len+1,char);
     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
     if (pv) {
-    	Copy(pv,newaddr,len,char);	/* might not be null terminated */
-    	newaddr[len] = '\0';		/* is now */
+	/* might not be null terminated */
+    	newaddr[len] = '\0';
+    	return (char *) CopyD(pv,newaddr,len,char);
     }
     else {
-	Zero(newaddr,len+1,char);
+	return (char *) ZeroD(newaddr,len+1,char);
     }
-    return newaddr;
 }
 
 /*
@@ -800,14 +816,39 @@ which is shared between threads.
 char *
 Perl_savesharedpv(pTHX_ const char *pv)
 {
-    register char *newaddr = Nullch;
-    if (pv) {
-	newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1);
-    	(void)strcpy(newaddr,pv);
+    register char *newaddr;
+    if (!pv)
+	return Nullch;
+
+    newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1);
+    if (!newaddr) {
+	PerlLIO_write(PerlIO_fileno(Perl_error_log),
+		      PL_no_mem, strlen(PL_no_mem));
+	my_exit(1);
     }
-    return newaddr;
+    return strcpy(newaddr,pv);
 }
 
+/*
+=for apidoc savesvpv
+
+A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
+the passed in SV using C<SvPV()>
+
+=cut
+*/
+
+char *
+Perl_savesvpv(pTHX_ SV *sv)
+{
+    STRLEN len;
+    const char *pv = SvPV(sv, len);
+    register char *newaddr;
+
+    ++len;
+    New(903,newaddr,len,char);
+    return (char *) CopyD(pv,newaddr,len,char);
+}
 
 
 /* the SV for Perl_form() and mess() is not kept in an arena */
@@ -947,8 +988,7 @@ SV *
 Perl_vmess(pTHX_ const char *pat, va_list *args)
 {
     SV *sv = mess_alloc();
-    static char dgd[] = " during global destruction.\n";
-    COP *cop;
+    static const char dgd[] = " during global destruction.\n";
 
     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
@@ -960,14 +1000,14 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
 	 * from the sibling of PL_curcop.
 	 */
 
-	cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
+	const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
 	if (!cop) cop = PL_curcop;
 
 	if (CopLINE(cop))
 	    Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
 	    OutCopFILE(cop), (IV)CopLINE(cop));
 	if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
-	    bool line_mode = (RsSIMPLE(PL_rs) &&
+	    const bool line_mode = (RsSIMPLE(PL_rs) &&
 			      SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
 	    Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
 			   PL_last_in_gv == PL_argvgv ?
@@ -983,6 +1023,7 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
 void
 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
 {
+    dVAR;
     IO *io;
     MAGIC *mg;
 
@@ -1026,74 +1067,95 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
     }
 }
 
-OP *
-Perl_vdie(pTHX_ const char* pat, va_list *args)
+/* Common code used by vcroak, vdie and vwarner  */
+
+void S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8);
+
+STATIC char *
+S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
+		    I32* utf8)
 {
+    dVAR;
     char *message;
-    int was_in_eval = PL_in_eval;
-    HV *stash;
-    GV *gv;
-    CV *cv;
-    SV *msv;
-    STRLEN msglen;
-    I32 utf8 = 0;
-
-    DEBUG_S(PerlIO_printf(Perl_debug_log,
-			  "%p: die: curstack = %p, mainstack = %p\n",
-			  thr, PL_curstack, PL_mainstack));
 
     if (pat) {
-	msv = vmess(pat, args);
+	SV *msv = vmess(pat, args);
 	if (PL_errors && SvCUR(PL_errors)) {
 	    sv_catsv(PL_errors, msv);
-	    message = SvPV(PL_errors, msglen);
+	    message = SvPV(PL_errors, *msglen);
 	    SvCUR_set(PL_errors, 0);
 	}
 	else
-	    message = SvPV(msv,msglen);
-	utf8 = SvUTF8(msv);
+	    message = SvPV(msv,*msglen);
+	*utf8 = SvUTF8(msv);
     }
     else {
 	message = Nullch;
-	msglen = 0;
     }
 
     DEBUG_S(PerlIO_printf(Perl_debug_log,
-			  "%p: die: message = %s\ndiehook = %p\n",
+			  "%p: die/croak: message = %s\ndiehook = %p\n",
 			  thr, message, PL_diehook));
     if (PL_diehook) {
-	/* sv_2cv might call Perl_croak() */
-	SV *olddiehook = PL_diehook;
-	ENTER;
-	SAVESPTR(PL_diehook);
-	PL_diehook = Nullsv;
-	cv = sv_2cv(olddiehook, &stash, &gv, 0);
-	LEAVE;
-	if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
-	    dSP;
-	    SV *msg;
+	S_vdie_common(aTHX_ message, *msglen, *utf8);
+    }
+    return message;
+}
 
-	    ENTER;
-	    save_re_context();
-	    if (message) {
-		msg = newSVpvn(message, msglen);
-		SvFLAGS(msg) |= utf8;
-		SvREADONLY_on(msg);
-		SAVEFREESV(msg);
-	    }
-	    else {
-		msg = ERRSV;
-	    }
+void
+S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
+{
+    HV *stash;
+    GV *gv;
+    CV *cv;
+    /* sv_2cv might call Perl_croak() */
+    SV *olddiehook = PL_diehook;
+
+    assert(PL_diehook);
+    ENTER;
+    SAVESPTR(PL_diehook);
+    PL_diehook = Nullsv;
+    cv = sv_2cv(olddiehook, &stash, &gv, 0);
+    LEAVE;
+    if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
+	dSP;
+	SV *msg;
 
-	    PUSHSTACKi(PERLSI_DIEHOOK);
-	    PUSHMARK(SP);
-	    XPUSHs(msg);
-	    PUTBACK;
-	    call_sv((SV*)cv, G_DISCARD);
-	    POPSTACK;
-	    LEAVE;
+	ENTER;
+	save_re_context();
+	if (message) {
+	    msg = newSVpvn(message, msglen);
+	    SvFLAGS(msg) |= utf8;
+	    SvREADONLY_on(msg);
+	    SAVEFREESV(msg);
 	}
+	else {
+	    msg = ERRSV;
+	}
+
+	PUSHSTACKi(PERLSI_DIEHOOK);
+	PUSHMARK(SP);
+	XPUSHs(msg);
+	PUTBACK;
+	call_sv((SV*)cv, G_DISCARD);
+	POPSTACK;
+	LEAVE;
     }
+}
+
+OP *
+Perl_vdie(pTHX_ const char* pat, va_list *args)
+{
+    const char *message;
+    const int was_in_eval = PL_in_eval;
+    STRLEN msglen;
+    I32 utf8 = 0;
+
+    DEBUG_S(PerlIO_printf(Perl_debug_log,
+			  "%p: die: curstack = %p, mainstack = %p\n",
+			  thr, PL_curstack, PL_mainstack));
+
+    message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
 
     PL_restartop = die_where(message, msglen);
     SvFLAGS(ERRSV) |= utf8;
@@ -1133,66 +1195,12 @@ Perl_die(pTHX_ const char* pat, ...)
 void
 Perl_vcroak(pTHX_ const char* pat, va_list *args)
 {
-    char *message;
-    HV *stash;
-    GV *gv;
-    CV *cv;
-    SV *msv;
+    const char *message;
     STRLEN msglen;
     I32 utf8 = 0;
 
-    if (pat) {
-	msv = vmess(pat, args);
-	if (PL_errors && SvCUR(PL_errors)) {
-	    sv_catsv(PL_errors, msv);
-	    message = SvPV(PL_errors, msglen);
-	    SvCUR_set(PL_errors, 0);
-	}
-	else
-	    message = SvPV(msv,msglen);
-	utf8 = SvUTF8(msv);
-    }
-    else {
-	message = Nullch;
-	msglen = 0;
-    }
+    message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
 
-    DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
-			  PTR2UV(thr), message));
-
-    if (PL_diehook) {
-	/* sv_2cv might call Perl_croak() */
-	SV *olddiehook = PL_diehook;
-	ENTER;
-	SAVESPTR(PL_diehook);
-	PL_diehook = Nullsv;
-	cv = sv_2cv(olddiehook, &stash, &gv, 0);
-	LEAVE;
-	if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
-	    dSP;
-	    SV *msg;
-
-	    ENTER;
-	    save_re_context();
-	    if (message) {
-		msg = newSVpvn(message, msglen);
-		SvFLAGS(msg) |= utf8;
-		SvREADONLY_on(msg);
-		SAVEFREESV(msg);
-	    }
-	    else {
-		msg = ERRSV;
-	    }
-
-	    PUSHSTACKi(PERLSI_DIEHOOK);
-	    PUSHMARK(SP);
-	    XPUSHs(msg);
-	    PUTBACK;
-	    call_sv((SV*)cv, G_DISCARD);
-	    POPSTACK;
-	    LEAVE;
-	}
-    }
     if (PL_in_eval) {
 	PL_restartop = die_where(message, msglen);
 	SvFLAGS(ERRSV) |= utf8;
@@ -1251,6 +1259,7 @@ Perl_croak(pTHX_ const char *pat, ...)
 void
 Perl_vwarn(pTHX_ const char* pat, va_list *args)
 {
+    dVAR;
     char *message;
     HV *stash;
     GV *gv;
@@ -1330,7 +1339,7 @@ Perl_warn(pTHX_ const char *pat, ...)
 void
 Perl_warner_nocontext(U32 err, const char *pat, ...)
 {
-    dTHX;
+    dTHX; 
     va_list args;
     va_start(args, pat);
     vwarner(err, pat, &args);
@@ -1350,46 +1359,16 @@ Perl_warner(pTHX_ U32  err, const char* pat,...)
 void
 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 {
-    char *message;
-    HV *stash;
-    GV *gv;
-    CV *cv;
-    SV *msv;
-    STRLEN msglen;
-    I32 utf8 = 0;
-
-    msv = vmess(pat, args);
-    message = SvPV(msv, msglen);
-    utf8 = SvUTF8(msv);
-
+    dVAR;
     if (ckDEAD(err)) {
+	SV *msv = vmess(pat, args);
+	STRLEN msglen;
+	const char *message = SvPV(msv, msglen);
+	I32 utf8 = SvUTF8(msv);
+
 	if (PL_diehook) {
-	    /* sv_2cv might call Perl_croak() */
-	    SV *olddiehook = PL_diehook;
-	    ENTER;
-	    SAVESPTR(PL_diehook);
-	    PL_diehook = Nullsv;
-	    cv = sv_2cv(olddiehook, &stash, &gv, 0);
-	    LEAVE;
-	    if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
-		dSP;
-		SV *msg;
-
-		ENTER;
-		save_re_context();
-		msg = newSVpvn(message, msglen);
-		SvFLAGS(msg) |= utf8;
-		SvREADONLY_on(msg);
-		SAVEFREESV(msg);
-
-		PUSHSTACKi(PERLSI_DIEHOOK);
-		PUSHMARK(sp);
-		XPUSHs(msg);
-		PUTBACK;
-		call_sv((SV*)cv, G_DISCARD);
-		POPSTACK;
-		LEAVE;
-	    }
+	    assert(message);
+	    S_vdie_common(aTHX_ message, msglen, utf8);
 	}
 	if (PL_in_eval) {
 	    PL_restartop = die_where(message, msglen);
@@ -1400,36 +1379,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 	my_failure_exit();
     }
     else {
-	if (PL_warnhook) {
-	    /* sv_2cv might call Perl_warn() */
-	    SV *oldwarnhook = PL_warnhook;
-	    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;
-		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;
-		return;
-	    }
-	}
-	write_to_stderr(message, msglen);
+	Perl_vwarn(aTHX_ pat, args);
     }
 }
 
@@ -1447,14 +1397,16 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
        /* VMS' my_setenv() is in vms.c */
 #if !defined(WIN32) && !defined(NETWARE)
 void
-Perl_my_setenv(pTHX_ char *nam, char *val)
+Perl_my_setenv(pTHX_ const char *nam, const char *val)
 {
+  dVAR;
 #ifdef USE_ITHREADS
   /* only parent thread can modify process environment */
   if (PL_curinterp == aTHX)
 #endif
   {
 #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? */
     int nlen, vlen;
@@ -1468,7 +1420,7 @@ Perl_my_setenv(pTHX_ char *nam, char *val)
 	for (max = i; environ[max]; max++) ;
 	tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
 	for (j=0; j<max; j++) {		/* copy environment */
-	    int len = strlen(environ[j]);
+	    const int len = strlen(environ[j]);
 	    tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
 	    Copy(environ[j], tmpenv[j], len+1, char);
 	}
@@ -1495,9 +1447,9 @@ Perl_my_setenv(pTHX_ char *nam, char *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);
-
-#else   /* PERL_USE_SAFE_PUTENV */
-#   if defined(__CYGWIN__) || defined( EPOC)
+    } else {
+# endif
+#   if defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN) 
     setenv(nam, val, 1);
 #   else
     char *new_env;
@@ -1511,17 +1463,21 @@ Perl_my_setenv(pTHX_ char *nam, char *val)
     my_setenv_format(new_env, nam, nlen, val, vlen);
     (void)putenv(new_env);
 #   endif /* __CYGWIN__ */
-#endif  /* PERL_USE_SAFE_PUTENV */
+#ifndef PERL_USE_SAFE_PUTENV
+    }
+#endif
   }
 }
 
 #else /* WIN32 || NETWARE */
 
 void
-Perl_my_setenv(pTHX_ char *nam,char *val)
+Perl_my_setenv(pTHX_ const char *nam, const char *val)
 {
+    dVAR;
     register char *envstr;
-    int nlen = strlen(nam), vlen;
+    const int nlen = strlen(nam);
+    int vlen;
 
     if (!val) {
 	val = "";
@@ -1537,7 +1493,7 @@ Perl_my_setenv(pTHX_ char *nam,char *val)
 
 #ifndef PERL_MICRO
 I32
-Perl_setenv_getix(pTHX_ char *nam)
+Perl_setenv_getix(pTHX_ const char *nam)
 {
     register I32 i, len = strlen(nam);
 
@@ -1620,12 +1576,12 @@ Perl_my_bzero(register char *loc, register I32 len)
 I32
 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
 {
-    register U8 *a = (U8 *)s1;
-    register U8 *b = (U8 *)s2;
+    register const U8 *a = (const U8 *)s1;
+    register const U8 *b = (const U8 *)s2;
     register I32 tmp;
 
     while (len--) {
-	if (tmp = *a++ - *b++)
+        if ((tmp = *a++ - *b++))
 	    return tmp;
     }
     return 0;
@@ -1746,7 +1702,7 @@ Perl_my_ntohl(pTHX_ long l)
  * -DWS
  */
 
-#define HTOV(name,type)						\
+#define HTOLE(name,type)					\
 	type							\
 	name (register type n)					\
 	{							\
@@ -1755,14 +1711,14 @@ Perl_my_ntohl(pTHX_ long l)
 		char c[sizeof(type)];				\
 	    } u;						\
 	    register I32 i;					\
-	    register I32 s;					\
-	    for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {	\
+	    register I32 s = 0;					\
+	    for (i = 0; i < sizeof(u.c); i++, s += 8) {		\
 		u.c[i] = (n >> s) & 0xFF;			\
 	    }							\
 	    return u.value;					\
 	}
 
-#define VTOH(name,type)						\
+#define LETOH(name,type)					\
 	type							\
 	name (register type n)					\
 	{							\
@@ -1771,28 +1727,219 @@ Perl_my_ntohl(pTHX_ long l)
 		char c[sizeof(type)];				\
 	    } u;						\
 	    register I32 i;					\
-	    register I32 s;					\
+	    register I32 s = 0;					\
 	    u.value = n;					\
 	    n = 0;						\
-	    for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {	\
-		n += (u.c[i] & 0xFF) << s;			\
+	    for (i = 0; i < sizeof(u.c); i++, s += 8) {		\
+		n |= ((type)(u.c[i] & 0xFF)) << s;		\
 	    }							\
 	    return n;						\
 	}
 
+/*
+ * Big-endian byte order functions.
+ */
+
+#define HTOBE(name,type)					\
+	type							\
+	name (register type n)					\
+	{							\
+	    union {						\
+		type value;					\
+		char c[sizeof(type)];				\
+	    } u;						\
+	    register I32 i;					\
+	    register I32 s = 8*(sizeof(u.c)-1);			\
+	    for (i = 0; i < sizeof(u.c); i++, s -= 8) {		\
+		u.c[i] = (n >> s) & 0xFF;			\
+	    }							\
+	    return u.value;					\
+	}
+
+#define BETOH(name,type)					\
+	type							\
+	name (register type n)					\
+	{							\
+	    union {						\
+		type value;					\
+		char c[sizeof(type)];				\
+	    } u;						\
+	    register I32 i;					\
+	    register I32 s = 8*(sizeof(u.c)-1);			\
+	    u.value = n;					\
+	    n = 0;						\
+	    for (i = 0; i < sizeof(u.c); i++, s -= 8) {		\
+		n |= ((type)(u.c[i] & 0xFF)) << s;		\
+	    }							\
+	    return n;						\
+	}
+
+/*
+ * If we just can't do it...
+ */
+
+#define NOT_AVAIL(name,type)                                    \
+        type                                                    \
+        name (register type n)                                  \
+        {                                                       \
+            Perl_croak_nocontext(#name "() not available");     \
+            return n; /* not reached */                         \
+        }
+
+
 #if defined(HAS_HTOVS) && !defined(htovs)
-HTOV(htovs,short)
+HTOLE(htovs,short)
 #endif
 #if defined(HAS_HTOVL) && !defined(htovl)
-HTOV(htovl,long)
+HTOLE(htovl,long)
 #endif
 #if defined(HAS_VTOHS) && !defined(vtohs)
-VTOH(vtohs,short)
+LETOH(vtohs,short)
 #endif
 #if defined(HAS_VTOHL) && !defined(vtohl)
-VTOH(vtohl,long)
+LETOH(vtohl,long)
+#endif
+
+#ifdef PERL_NEED_MY_HTOLE16
+# if U16SIZE == 2
+HTOLE(Perl_my_htole16,U16)
+# else
+NOT_AVAIL(Perl_my_htole16,U16)
+# endif
+#endif
+#ifdef PERL_NEED_MY_LETOH16
+# if U16SIZE == 2
+LETOH(Perl_my_letoh16,U16)
+# else
+NOT_AVAIL(Perl_my_letoh16,U16)
+# endif
+#endif
+#ifdef PERL_NEED_MY_HTOBE16
+# if U16SIZE == 2
+HTOBE(Perl_my_htobe16,U16)
+# else
+NOT_AVAIL(Perl_my_htobe16,U16)
+# endif
+#endif
+#ifdef PERL_NEED_MY_BETOH16
+# if U16SIZE == 2
+BETOH(Perl_my_betoh16,U16)
+# else
+NOT_AVAIL(Perl_my_betoh16,U16)
+# endif
+#endif
+
+#ifdef PERL_NEED_MY_HTOLE32
+# if U32SIZE == 4
+HTOLE(Perl_my_htole32,U32)
+# else
+NOT_AVAIL(Perl_my_htole32,U32)
+# endif
+#endif
+#ifdef PERL_NEED_MY_LETOH32
+# if U32SIZE == 4
+LETOH(Perl_my_letoh32,U32)
+# else
+NOT_AVAIL(Perl_my_letoh32,U32)
+# endif
+#endif
+#ifdef PERL_NEED_MY_HTOBE32
+# if U32SIZE == 4
+HTOBE(Perl_my_htobe32,U32)
+# else
+NOT_AVAIL(Perl_my_htobe32,U32)
+# endif
+#endif
+#ifdef PERL_NEED_MY_BETOH32
+# if U32SIZE == 4
+BETOH(Perl_my_betoh32,U32)
+# else
+NOT_AVAIL(Perl_my_betoh32,U32)
+# endif
+#endif
+
+#ifdef PERL_NEED_MY_HTOLE64
+# if U64SIZE == 8
+HTOLE(Perl_my_htole64,U64)
+# else
+NOT_AVAIL(Perl_my_htole64,U64)
+# endif
+#endif
+#ifdef PERL_NEED_MY_LETOH64
+# if U64SIZE == 8
+LETOH(Perl_my_letoh64,U64)
+# else
+NOT_AVAIL(Perl_my_letoh64,U64)
+# endif
+#endif
+#ifdef PERL_NEED_MY_HTOBE64
+# if U64SIZE == 8
+HTOBE(Perl_my_htobe64,U64)
+# else
+NOT_AVAIL(Perl_my_htobe64,U64)
+# endif
+#endif
+#ifdef PERL_NEED_MY_BETOH64
+# if U64SIZE == 8
+BETOH(Perl_my_betoh64,U64)
+# else
+NOT_AVAIL(Perl_my_betoh64,U64)
+# endif
 #endif
 
+#ifdef PERL_NEED_MY_HTOLES
+HTOLE(Perl_my_htoles,short)
+#endif
+#ifdef PERL_NEED_MY_LETOHS
+LETOH(Perl_my_letohs,short)
+#endif
+#ifdef PERL_NEED_MY_HTOBES
+HTOBE(Perl_my_htobes,short)
+#endif
+#ifdef PERL_NEED_MY_BETOHS
+BETOH(Perl_my_betohs,short)
+#endif
+
+#ifdef PERL_NEED_MY_HTOLEI
+HTOLE(Perl_my_htolei,int)
+#endif
+#ifdef PERL_NEED_MY_LETOHI
+LETOH(Perl_my_letohi,int)
+#endif
+#ifdef PERL_NEED_MY_HTOBEI
+HTOBE(Perl_my_htobei,int)
+#endif
+#ifdef PERL_NEED_MY_BETOHI
+BETOH(Perl_my_betohi,int)
+#endif
+
+#ifdef PERL_NEED_MY_HTOLEL
+HTOLE(Perl_my_htolel,long)
+#endif
+#ifdef PERL_NEED_MY_LETOHL
+LETOH(Perl_my_letohl,long)
+#endif
+#ifdef PERL_NEED_MY_HTOBEL
+HTOBE(Perl_my_htobel,long)
+#endif
+#ifdef PERL_NEED_MY_BETOHL
+BETOH(Perl_my_betohl,long)
+#endif
+
+void
+Perl_my_swabn(void *ptr, int n)
+{
+    register char *s = (char *)ptr;
+    register char *e = s + (n-1);
+    register char tc;
+
+    for (n /= 2; n > 0; s++, e--, n--) {
+      tc = *s;
+      *s = *e;
+      *e = tc;
+    }
+}
+
 PerlIO *
 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
 {
@@ -1887,7 +2034,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
     sv = *av_fetch(PL_fdpid,p[This],TRUE);
     UNLOCK_FDPID_MUTEX;
     (void)SvUPGRADE(sv,SVt_IV);
-    SvIVX(sv) = pid;
+    SvIV_set(sv, pid);
     PL_forkprocess = pid;
     /* If we managed to get status pipe check for exec fail */
     if (did_pipes && pid > 0) {
@@ -1934,7 +2081,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
     register I32 This, that;
     register Pid_t pid;
     SV *sv;
-    I32 doexec = strNE(cmd,"-");
+    I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
     I32 did_pipes = 0;
     int pp[2];
 
@@ -1992,8 +2139,6 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 #ifndef OS2
 	if (doexec) {
 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
-	    int fd;
-
 #ifndef NOFILE
 #define NOFILE 20
 #endif
@@ -2040,7 +2185,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
     sv = *av_fetch(PL_fdpid,p[This],TRUE);
     UNLOCK_FDPID_MUTEX;
     (void)SvUPGRADE(sv,SVt_IV);
-    SvIVX(sv) = pid;
+    SvIV_set(sv, pid);
     PL_forkprocess = pid;
     if (did_pipes && pid > 0) {
 	int errkid;
@@ -2107,6 +2252,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 void
 Perl_atfork_lock(void)
 {
+   dVAR;
 #if defined(USE_ITHREADS)
     /* locks must be held in locking order (if any) */
 #  ifdef MYMALLOC
@@ -2120,6 +2266,7 @@ Perl_atfork_lock(void)
 void
 Perl_atfork_unlock(void)
 {
+    dVAR;
 #if defined(USE_ITHREADS)
     /* locks must be released in same order as in atfork_lock() */
 #  ifdef MYMALLOC
@@ -2164,6 +2311,7 @@ Perl_dump_fds(pTHX_ char *s)
 	    PerlIO_printf(Perl_debug_log," %d",fd);
     }
     PerlIO_printf(Perl_debug_log,"\n");
+    return;
 }
 #endif	/* DUMP_FDS */
 
@@ -2212,6 +2360,7 @@ dup2(int oldfd, int newfd)
 Sighandler_t
 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
 {
+    dVAR;
     struct sigaction act, oact;
 
 #ifdef USE_ITHREADS
@@ -2251,6 +2400,7 @@ Perl_rsignal_state(pTHX_ int signo)
 int
 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
 {
+    dVAR;
     struct sigaction act;
 
 #ifdef USE_ITHREADS
@@ -2276,6 +2426,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
 int
 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
 {
+    dVAR;
 #ifdef USE_ITHREADS
     /* only "parent" interpreter can diddle signals */
     if (PL_curinterp != aTHX)
@@ -2299,19 +2450,18 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
     return PerlProc_signal(signo, handler);
 }
 
-static int sig_trapped;	/* XXX signals are process-wide anyway, so we
-			   ignore the implications of this for threading */
-
 static
 Signal_t
 sig_trap(int signo)
 {
-    sig_trapped++;
+    dVAR;
+    PL_sig_trapped++;
 }
 
 Sighandler_t
 Perl_rsignal_state(pTHX_ int signo)
 {
+    dVAR;
     Sighandler_t oldsig;
 
 #if defined(USE_ITHREADS) && !defined(WIN32)
@@ -2320,10 +2470,10 @@ Perl_rsignal_state(pTHX_ int signo)
 	return SIG_ERR;
 #endif
 
-    sig_trapped = 0;
+    PL_sig_trapped = 0;
     oldsig = PerlProc_signal(signo, sig_trap);
     PerlProc_signal(signo, oldsig);
-    if (sig_trapped)
+    if (PL_sig_trapped)
 	PerlProc_kill(PerlProc_getpid(), signo);
     return oldsig;
 }
@@ -2421,16 +2571,15 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 I32
 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 {
-    I32 result;
+    I32 result = 0;
     if (!pid)
 	return -1;
 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
     {
-	SV *sv;
-	SV** svp;
-	char spid[TYPE_CHARS(int)];
+	char spid[TYPE_CHARS(IV)];
 
 	if (pid > 0) {
+	    SV** svp;
 	    sprintf(spid, "%"IVdf, (IV)pid);
 	    svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
 	    if (svp && *svp != &PL_sv_undef) {
@@ -2444,11 +2593,9 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 
 	    hv_iterinit(PL_pidstatus);
 	    if ((entry = hv_iternext(PL_pidstatus))) {
-		SV *sv;
-		char spid[TYPE_CHARS(int)];
+		SV *sv = hv_iterval(PL_pidstatus,entry);
 
 		pid = atoi(hv_iterkey(entry,(I32*)statusp));
-		sv = hv_iterval(PL_pidstatus,entry);
 		*statusp = SvIVX(sv);
 		sprintf(spid, "%"IVdf, (IV)pid);
 		(void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
@@ -2470,7 +2617,9 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
     goto finish;
 #endif
 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
+#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
   hard_way:
+#endif
     {
 	if (flags)
 	    Perl_croak(aTHX_ "Can't do waitpid with flags");
@@ -2482,7 +2631,9 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 	}
     }
 #endif
+#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
   finish:
+#endif
     if (result < 0 && errno == EINTR) {
 	PERL_ASYNC_CHECK();
     }
@@ -2495,12 +2646,12 @@ void
 Perl_pidgone(pTHX_ Pid_t pid, int status)
 {
     register SV *sv;
-    char spid[TYPE_CHARS(int)];
+    char spid[TYPE_CHARS(IV)];
 
     sprintf(spid, "%"IVdf, (IV)pid);
     sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
     (void)SvUPGRADE(sv,SVt_IV);
-    SvIVX(sv) = status;
+    SvIV_set(sv, status);
     return;
 }
 
@@ -2559,7 +2710,7 @@ Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, regi
 
 #ifndef HAS_RENAME
 I32
-Perl_same_dirent(pTHX_ char *a, char *b)
+Perl_same_dirent(pTHX_ const char *a, const char *b)
 {
     char *fa = strrchr(a,'/');
     char *fb = strrchr(b,'/');
@@ -2595,9 +2746,9 @@ Perl_same_dirent(pTHX_ char *a, char *b)
 #endif /* !HAS_RENAME */
 
 char*
-Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
+Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **search_ext, I32 flags)
 {
-    char *xfound = Nullch;
+    const char *xfound = Nullch;
     char *xfailed = Nullch;
     char tmpbuf[MAXPATHLEN];
     register char *s;
@@ -2617,11 +2768,12 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f
 #endif
     /* additional extensions to try in each dir if scriptname not found */
 #ifdef SEARCH_EXTS
-    char *exts[] = { SEARCH_EXTS };
-    char **ext = search_ext ? search_ext : exts;
+    const char *exts[] = { SEARCH_EXTS };
+    const char **ext = search_ext ? search_ext : exts;
     int extidx = 0, i = 0;
-    char *curext = Nullch;
+    const char *curext = Nullch;
 #else
+    (void)search_ext;
 #  define MAX_EXT_LEN 0
 #endif
 
@@ -2679,7 +2831,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f
     if (strEQ(scriptname, "-"))
  	dosearch = 0;
     if (dosearch) {		/* Look in '.' first. */
-	char *cur = scriptname;
+	const char *cur = scriptname;
 #ifdef SEARCH_EXTS
 	if ((curext = strrchr(scriptname,'.')))	/* possible current ext */
 	    while (ext[i])
@@ -2830,6 +2982,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f
 void *
 Perl_get_context(void)
 {
+    dVAR;
 #if defined(USE_ITHREADS)
 #  ifdef OLD_PTHREADS_API
     pthread_addr_t t;
@@ -2851,6 +3004,7 @@ Perl_get_context(void)
 void
 Perl_set_context(void *t)
 {
+   dVAR;
 #if defined(USE_ITHREADS)
 #  ifdef I_MACH_CTHREADS
     cthread_set_data(cthread_self(), t);
@@ -2863,7 +3017,7 @@ Perl_set_context(void *t)
 
 #endif /* !PERL_GET_CONTEXT_DEFINED */
 
-#ifdef PERL_GLOBAL_STRUCT
+#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
 struct perl_vars *
 Perl_GetVars(pTHX)
 {
@@ -2874,30 +3028,31 @@ Perl_GetVars(pTHX)
 char **
 Perl_get_op_names(pTHX)
 {
- return PL_op_name;
+ return (char **)PL_op_name;
 }
 
 char **
 Perl_get_op_descs(pTHX)
 {
- return PL_op_desc;
+ return (char **)PL_op_desc;
 }
 
-char *
+const char *
 Perl_get_no_modify(pTHX)
 {
- return (char*)PL_no_modify;
+ return PL_no_modify;
 }
 
 U32 *
 Perl_get_opargs(pTHX)
 {
- return PL_opargs;
+ return (U32 *)PL_opargs;
 }
 
 PPADDR_t*
 Perl_get_ppaddr(pTHX)
 {
+ dVAR;
  return (PPADDR_t*)PL_ppaddr;
 }
 
@@ -2916,7 +3071,7 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
 MGVTBL*
 Perl_get_vtbl(pTHX_ int vtbl_id)
 {
-    MGVTBL* result = Null(MGVTBL*);
+    const MGVTBL* result = Null(MGVTBL*);
 
     switch(vtbl_id) {
     case want_vtbl_sv:
@@ -3012,7 +3167,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id)
 	result = &PL_vtbl_utf8;
 	break;
     }
-    return result;
+    return (MGVTBL*)result;
 }
 
 I32
@@ -3066,17 +3221,17 @@ Perl_my_fflush_all(pTHX)
 }
 
 void
-Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
+Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
 {
-    char *func =
+    const char *func =
 	op == OP_READLINE   ? "readline"  :	/* "<HANDLE>" not nice */
 	op == OP_LEAVEWRITE ? "write" :		/* "write exit" not nice */
 	PL_op_desc[op];
-    char *pars = OP_IS_FILETEST(op) ? "" : "()";
-    char *type = OP_IS_SOCKET(op)
+    const char *pars = OP_IS_FILETEST(op) ? "" : "()";
+    const char *type = OP_IS_SOCKET(op)
 	    || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
 		?  "socket" : "filehandle";
-    char *name = NULL;
+    const char *name = NULL;
 
     if (gv && isGV(gv)) {
 	name = GvENAME(gv);
@@ -3095,7 +3250,7 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
 	}
     }
     else {
-	char *vile;
+        const char *vile;
 	I32   warn_type;
 
 	if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
@@ -3140,7 +3295,7 @@ int
 Perl_ebcdic_control(pTHX_ int ch)
 {
     if (ch > 'a') {
-	char *ctlp;
+	const char *ctlp;
 
 	if (islower(ch))
 	    ch = toupper(ch);
@@ -3199,8 +3354,11 @@ Perl_init_tm(pTHX_ struct tm *ptm)	/* see mktime, strftime and asctime */
 {
 #ifdef HAS_TM_TM_ZONE
     Time_t now;
+    struct tm* my_tm;
     (void)time(&now);
-    Copy(localtime(&now), ptm, 1, struct tm);
+    my_tm = localtime(&now);
+    if (my_tm)
+        Copy(my_tm, ptm, 1, struct tm);
 #endif
 }
 
@@ -3402,7 +3560,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm)
 }
 
 char *
-Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
+Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
 {
 #ifdef HAS_STRFTIME
   char *buf;
@@ -3456,8 +3614,8 @@ Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon,
     return buf;
   else {
     /* Possibly buf overflowed - try again with a bigger buf */
-    int     fmtlen = strlen(fmt);
-    int	    bufsize = fmtlen + buflen;
+    const int fmtlen = strlen(fmt);
+    const int bufsize = fmtlen + buflen;
 
     New(0, buf, bufsize, char);
     while (buf) {
@@ -3470,13 +3628,13 @@ Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon,
 	buf = NULL;
 	break;
       }
-      bufsize *= 2;
-      Renew(buf, bufsize, char);
+      Renew(buf, bufsize*2, char);
     }
     return buf;
   }
 #else
   Perl_croak(aTHX_ "panic: no strftime");
+  return NULL;
 #endif
 }
 
@@ -3524,8 +3682,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 	 * size from the heap if they are given a NULL buffer pointer.
 	 * The problem is that this behaviour is not portable. */
 	if (getcwd(buf, sizeof(buf) - 1)) {
-	    STRLEN len = strlen(buf);
-	    sv_setpvn(sv, buf, len);
+	    sv_setpvn(sv, buf, strlen(buf));
 	    return TRUE;
 	}
 	else {
@@ -3538,8 +3695,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 
     Stat_t statbuf;
     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
-    int namelen, pathlen=0;
-    DIR *dir;
+    int pathlen=0;
     Direntry_t *dp;
 
     (void)SvUPGRADE(sv, SVt_PV);
@@ -3554,6 +3710,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
     cino = orig_cino;
 
     for (;;) {
+	DIR *dir;
 	odev = cdev;
 	oino = cino;
 
@@ -3576,9 +3733,9 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 
 	while ((dp = PerlDir_read(dir)) != NULL) {
 #ifdef DIRNAMLEN
-	    namelen = dp->d_namlen;
+	    const int namelen = dp->d_namlen;
 #else
-	    namelen = strlen(dp->d_name);
+	    const int namelen = strlen(dp->d_name);
 #endif
 	    /* skip . and .. */
 	    if (SV_CWD_ISDOT(dp)) {
@@ -3677,14 +3834,15 @@ it doesn't.
 */
 
 char *
-Perl_scan_version(pTHX_ char *s, SV *rv, bool qv)
+Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 {
     const char *start = s;
-    char *pos = s;
+    const char *pos = s;
     I32 saw_period = 0;
     bool saw_under = 0;
     SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
     (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
+    AvREAL_on((AV*)sv);
 
     /* pre-scan the imput string to check for decimals */
     while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
@@ -3720,7 +3878,7 @@ Perl_scan_version(pTHX_ char *s, SV *rv, bool qv)
 	    rev = 0;
 	    {
   		/* this is atoi() that delimits on underscores */
-  		char *end = pos;
+		const char *end = pos;
   		I32 mult = 1;
  		I32 orev;
   		if ( s < pos && s > start && *(s-1) == '_' ) {
@@ -3730,8 +3888,8 @@ Perl_scan_version(pTHX_ char *s, SV *rv, bool qv)
 		 * point of a version originally created with a bare
 		 * floating point number, i.e. not quoted in any way
 		 */
- 		if ( !qv && s > start+1 && saw_period == 1 && !saw_under ) {
- 		    mult = 100;
+ 		if ( !qv && s > start+1 && saw_period == 1 ) {
+		    mult *= 100;
  		    while ( s < end ) {
  			orev = rev;
  			rev += (*s - '0') * mult;
@@ -3763,7 +3921,7 @@ Perl_scan_version(pTHX_ char *s, SV *rv, bool qv)
 		break;
 	    }
 	    while ( isDIGIT(*pos) ) {
-		if ( !saw_under && saw_period == 1 && pos-s == 3 )
+		if ( saw_period == 1 && pos-s == 3 )
 		    break;
 		pos++;
 	    }
@@ -3771,10 +3929,18 @@ Perl_scan_version(pTHX_ char *s, SV *rv, bool qv)
     }
     if ( qv ) { /* quoted versions always become full version objects */
 	I32 len = av_len((AV *)sv);
-	for ( len = 2 - len; len != 0; len-- )
+	/* This for loop appears to trigger a compiler bug on OS X, as it
+	   loops infinitely. Yes, len is negative. No, it makes no sense.
+	   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));
+	*/
+	len = 2 - len;
+	while (len-- > 0)
 	    av_push((AV *)sv, newSViv(0));
     }
-    return s;
+    return (char *)s;
 }
 
 /*
@@ -3794,6 +3960,20 @@ SV *
 Perl_new_version(pTHX_ SV *ver)
 {
     SV *rv = newSV(0);
+    if ( sv_derived_from(ver,"version") ) /* can just copy directly */
+    {
+	I32 key;
+	AV *av = (AV *)SvRV(ver);
+	SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+	(void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
+	AvREAL_on((AV*)sv);
+	for ( key = 0; key <= av_len(av); key++ )
+	{
+	    I32 rev = SvIV(*av_fetch(av, key, FALSE));
+	    av_push((AV *)sv, newSViv(rev));
+	}
+	return rv;
+    }
 #ifdef SvVOK
     if ( SvVOK(ver) ) { /* already a v-string */
 	char *version;
@@ -3845,8 +4025,7 @@ Perl_upg_version(pTHX_ SV *ver)
 #endif
     else /* must be a string or something like a string */
     {
-	STRLEN n_a;
-	version = savepv(SvPV(ver,n_a));
+	version = savesvpv(ver);
     }
     (void)scan_version(version, ver, qv);
     Safefree(version);
@@ -3883,14 +4062,27 @@ Perl_vnumify(pTHX_ SV *vs)
     }
     digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
     Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
-    for ( i = 1 ; i <= len ; i++ )
+    for ( i = 1 ; i < len ; i++ )
     {
 	digit = SvIVX(*av_fetch((AV *)vs, i, 0));
 	Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
     }
-    if ( len == 0 )
+
+    if ( len > 0 )
+    {
+	digit = SvIVX(*av_fetch((AV *)vs, len, 0));
+	if ( (int)PERL_ABS(digit) != 0 || len == 1 )
+	{
+	    if ( digit < 0 ) /* alpha version */
+		Perl_sv_catpv(aTHX_ sv,"_");
+	    /* Don't display additional trailing zeros */
+	    Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
+	}
+    }
+    else /* len == 0 */
+    {
 	 Perl_sv_catpv(aTHX_ sv,"000");
-    sv_setnv(sv, SvNV(sv));
+    }
     return sv;
 }
 
@@ -3954,12 +4146,13 @@ the original version contained 1 or more dots, respectively
 SV *
 Perl_vstringify(pTHX_ SV *vs)
 {
-    I32 len;
+    I32 len, digit;
     if ( SvROK(vs) )
 	vs = SvRV(vs);
     len = av_len((AV *)vs);
+    digit = SvIVX(*av_fetch((AV *)vs, len, 0));
     
-    if ( len < 2 )
+    if ( len < 2 || ( len == 2 && digit < 0 ) )
 	return vnumify(vs);
     else
 	return vnormal(vs);
@@ -4160,7 +4353,7 @@ S_socketpair_udp (int fd[2]) {
     errno = ECONNABORTED;
   tidy_up_and_fail:
     {
-	int save_errno = errno;
+	const int save_errno = errno;
 	if (sockets[0] != -1)
 	    PerlLIO_close(sockets[0]);
 	if (sockets[1] != -1)
@@ -4253,7 +4446,15 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
     return 0;
 
   abort_tidy_up_and_fail:
-  errno = ECONNABORTED; /* I hope this is portable and appropriate.  */
+#ifdef ECONNABORTED
+  errno = ECONNABORTED;	/* This would be the standard thing to do. */
+#else
+#  ifdef ECONNREFUSED
+  errno = ECONNREFUSED;	/* E.g. Symbian does not have ECONNABORTED. */
+#  else
+  errno = ETIMEDOUT;	/* Desperation time. */
+#  endif
+#endif
   tidy_up_and_fail:
     {
 	int save_errno = errno;
@@ -4294,6 +4495,7 @@ some level of strict-ness.
 void
 Perl_sv_nosharing(pTHX_ SV *sv)
 {
+    (void)sv;
 }
 
 /*
@@ -4309,6 +4511,7 @@ some level of strict-ness.
 void
 Perl_sv_nolocking(pTHX_ SV *sv)
 {
+    (void)sv;
 }
 
 
@@ -4325,12 +4528,13 @@ some level of strict-ness.
 void
 Perl_sv_nounlocking(pTHX_ SV *sv)
 {
+    (void)sv;
 }
 
 U32
-Perl_parse_unicode_opts(pTHX_ char **popt)
+Perl_parse_unicode_opts(pTHX_ const char **popt)
 {
-  char *p = *popt;
+  const char *p = *popt;
   U32 opt = 0;
 
   if (*p) {
@@ -4434,7 +4638,7 @@ Perl_seed(pTHX)
 #endif
     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
     if (fd != -1) {
-    	if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
+    	if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
 	    u = 0;
 	PerlLIO_close(fd);
 	if (u)
@@ -4465,7 +4669,7 @@ Perl_seed(pTHX)
 UV
 Perl_get_hash_seed(pTHX)
 {
-     char *s = PerlEnv_getenv("PERL_HASH_SEED");
+     const char *s = PerlEnv_getenv("PERL_HASH_SEED");
      UV myseed = 0;
 
      if (s)
@@ -4498,3 +4702,87 @@ Perl_get_hash_seed(pTHX)
 
      return myseed;
 }
+
+#ifdef PERL_GLOBAL_STRUCT
+
+struct perl_vars *
+Perl_init_global_struct(pTHX)
+{
+    struct perl_vars *plvarsp = NULL;
+#ifdef PERL_GLOBAL_STRUCT
+#  define PERL_GLOBAL_STRUCT_INIT
+#  include "opcode.h" /* the ppaddr and check */
+    IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
+    IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
+#  ifdef PERL_GLOBAL_STRUCT_PRIVATE
+    /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
+    plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
+    if (!plvarsp)
+        exit(1);
+#  else
+    plvarsp = PL_VarsPtr;
+#  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
+#  undef PERLVAR
+#  undef PERLVARA
+#  undef PERLVARI
+#  undef PERLVARIC
+#  undef PERLVARISC
+#  define PERLVAR(var,type) /**/
+#  define PERLVARA(var,n,type) /**/
+#  define PERLVARI(var,type,init) plvarsp->var = init;
+#  define PERLVARIC(var,type,init) plvarsp->var = init;
+#  define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
+#  include "perlvars.h"
+#  undef PERLVAR
+#  undef PERLVARA
+#  undef PERLVARI
+#  undef PERLVARIC
+#  undef PERLVARISC
+#  ifdef PERL_GLOBAL_STRUCT
+    plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
+    if (!plvarsp->Gppaddr)
+        exit(1);
+    plvarsp->Gcheck  = PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
+    if (!plvarsp->Gcheck)
+        exit(1);
+    Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); 
+    Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t); 
+#  endif
+#  ifdef PERL_SET_VARS
+    PERL_SET_VARS(plvarsp);
+#  endif
+#  undef PERL_GLOBAL_STRUCT_INIT
+#endif
+    return plvarsp;
+}
+
+#endif /* PERL_GLOBAL_STRUCT */
+
+#ifdef PERL_GLOBAL_STRUCT
+
+void
+Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
+{
+#ifdef PERL_GLOBAL_STRUCT
+#  ifdef PERL_UNSET_VARS
+    PERL_UNSET_VARS(plvarsp);
+#  endif
+    free(plvarsp->Gppaddr);
+    free(plvarsp->Gcheck);
+#    ifdef PERL_GLOBAL_STRUCT_PRIVATE
+    free(plvarsp);
+#    endif
+#endif
+}
+
+#endif /* PERL_GLOBAL_STRUCT */
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * vim: ts=8 sts=4 sw=4 noet:
+*/