X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=8dd0784922927a148eb312ef10bb0cfedc53dd82;hb=2db5ca0a86d6b3a21023f595f7a9ea5a35b63ed3;hp=8b51d21b625906384422fe0567a1d44391b1ec97;hpb=a02a5408b2f199007c4dcb74559cc79066307ada;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/util.c b/util.c
index 8b51d21..8dd0784 100644
--- a/util.c
+++ b/util.c
@@ -366,14 +366,13 @@ void
 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 {
     const register U8 *s;
-    register U8 *table;
     register U32 i;
     STRLEN len;
     I32 rarest = 0;
     U32 frequency = 256;
 
     if (flags & FBMcf_TAIL) {
-	MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
+	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() */
 	if (mg && mg->mg_len >= 0)
 	    mg->mg_len++;
@@ -385,6 +384,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
     if (len > 2) {
 	const unsigned char *sb;
 	const U8 mlen = (len>255) ? 255 : (U8)len;
+	register U8 *table;
 
 	Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
 	table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
@@ -921,7 +921,7 @@ Perl_form(pTHX_ const char* pat, ...)
 char *
 Perl_vform(pTHX_ const char *pat, va_list *args)
 {
-    SV *sv = mess_alloc();
+    SV * const sv = mess_alloc();
     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
     return SvPVX(sv);
 }
@@ -1074,7 +1074,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
     GV *gv;
     CV *cv;
     /* sv_2cv might call Perl_croak() */
-    SV *olddiehook = PL_diehook;
+    SV * const olddiehook = PL_diehook;
 
     assert(PL_diehook);
     ENTER;
@@ -1116,7 +1116,7 @@ S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
     const char *message;
 
     if (pat) {
-	SV *msv = vmess(pat, args);
+	SV * const msv = vmess(pat, args);
 	if (PL_errors && SvCUR(PL_errors)) {
 	    sv_catsv(PL_errors, msv);
 	    message = SvPV_const(PL_errors, *msglen);
@@ -1151,7 +1151,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args)
 			  "%p: die: curstack = %p, mainstack = %p\n",
 			  thr, PL_curstack, PL_mainstack));
 
-    message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
+    message = vdie_croak_common(pat, args, &msglen, &utf8);
 
     PL_restartop = die_where(message, msglen);
     SvFLAGS(ERRSV) |= utf8;
@@ -1278,6 +1278,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
 	    SV *msg;
 
 	    ENTER;
+	    SAVESPTR(PL_warnhook);
+	    PL_warnhook = Nullsv;
 	    save_re_context();
 	    msg = newSVpvn(message, msglen);
 	    SvFLAGS(msg) |= utf8;
@@ -1561,7 +1563,7 @@ Perl_setenv_getix(pTHX_ const char *nam)
 
 #ifdef UNLINK_ALL_VERSIONS
 I32
-Perl_unlnk(pTHX_ char *f)	/* unlink all versions of a file */
+Perl_unlnk(pTHX_ const char *f)	/* unlink all versions of a file */
 {
     I32 i;
 
@@ -1575,7 +1577,7 @@ Perl_unlnk(pTHX_ char *f)	/* unlink all versions of a file */
 char *
 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
 {
-    char *retval = to;
+    char * const retval = to;
 
     if (from - to >= 0) {
 	while (len--)
@@ -1596,7 +1598,7 @@ Perl_my_bcopy(register const char *from,register char *to,register I32 len)
 void *
 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
 {
-    char *retval = loc;
+    char * const retval = loc;
 
     while (len--)
 	*loc++ = ch;
@@ -1609,7 +1611,7 @@ Perl_my_memset(register char *loc, register I32 ch, register I32 len)
 char *
 Perl_my_bzero(register char *loc, register I32 len)
 {
-    char *retval = loc;
+    char * const retval = loc;
 
     while (len--)
 	*loc++ = 0;
@@ -2121,7 +2123,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)
 PerlIO *
-Perl_my_popen(pTHX_ char *cmd, char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
     int p[2];
     register I32 This, that;
@@ -2411,10 +2413,10 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
 #ifdef USE_ITHREADS
     /* only "parent" interpreter can diddle signals */
     if (PL_curinterp != aTHX)
-	return SIG_ERR;
+	return (Sighandler_t) SIG_ERR;
 #endif
 
-    act.sa_handler = handler;
+    act.sa_handler = (void(*)(int))handler;
     sigemptyset(&act.sa_mask);
     act.sa_flags = 0;
 #ifdef SA_RESTART
@@ -2422,13 +2424,13 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
         act.sa_flags |= SA_RESTART;	/* SVR4, 4.3+BSD */
 #endif
 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
-    if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
+    if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
 	act.sa_flags |= SA_NOCLDWAIT;
 #endif
     if (sigaction(signo, &act, &oact) == -1)
-    	return SIG_ERR;
+    	return (Sighandler_t) SIG_ERR;
     else
-    	return oact.sa_handler;
+    	return (Sighandler_t) oact.sa_handler;
 }
 
 Sighandler_t
@@ -2437,9 +2439,9 @@ Perl_rsignal_state(pTHX_ int signo)
     struct sigaction oact;
 
     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
-	return SIG_ERR;
+	return (Sighandler_t) SIG_ERR;
     else
-	return oact.sa_handler;
+	return (Sighandler_t) oact.sa_handler;
 }
 
 int
@@ -2454,7 +2456,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
 	return -1;
 #endif
 
-    act.sa_handler = handler;
+    act.sa_handler = (void(*)(int))handler;
     sigemptyset(&act.sa_mask);
     act.sa_flags = 0;
 #ifdef SA_RESTART
@@ -2462,7 +2464,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
         act.sa_flags |= SA_RESTART;	/* SVR4, 4.3+BSD */
 #endif
 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
-    if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
+    if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
 	act.sa_flags |= SA_NOCLDWAIT;
 #endif
     return sigaction(signo, &act, save);
@@ -2489,7 +2491,7 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
 #if defined(USE_ITHREADS) && !defined(WIN32)
     /* only "parent" interpreter can diddle signals */
     if (PL_curinterp != aTHX)
-	return SIG_ERR;
+	return (Sighandler_t) SIG_ERR;
 #endif
 
     return PerlProc_signal(signo, handler);
@@ -2512,7 +2514,7 @@ Perl_rsignal_state(pTHX_ int signo)
 #if defined(USE_ITHREADS) && !defined(WIN32)
     /* only "parent" interpreter can diddle signals */
     if (PL_curinterp != aTHX)
-	return SIG_ERR;
+	return (Sighandler_t) SIG_ERR;
 #endif
 
     PL_sig_trapped = 0;
@@ -2532,7 +2534,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
 	return -1;
 #endif
     *save = PerlProc_signal(signo, handler);
-    return (*save == SIG_ERR) ? -1 : 0;
+    return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
 }
 
 int
@@ -2543,7 +2545,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
     if (PL_curinterp != aTHX)
 	return -1;
 #endif
-    return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
+    return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
 }
 
 #endif /* !HAS_SIGACTION */
@@ -2586,9 +2588,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
 #endif
 #ifndef PERL_MICRO
-    rsignal_save(SIGHUP, SIG_IGN, &hstat);
-    rsignal_save(SIGINT, SIG_IGN, &istat);
-    rsignal_save(SIGQUIT, SIG_IGN, &qstat);
+    rsignal_save(SIGHUP,  (Sighandler_t) SIG_IGN, &hstat);
+    rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
+    rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
 #endif
     do {
 	pid2 = wait4pid(pid, &status, 0);
@@ -3876,7 +3878,7 @@ it doesn't.
 const char *
 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 {
-    const char *start = s;
+    const char *start;
     const char *pos;
     const char *last;
     int saw_period = 0;
@@ -3889,12 +3891,15 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
 #endif
 
+    while (isSPACE(*s)) /* leading whitespace is OK */
+	s++;
+
     if (*s == 'v') {
 	s++;  /* get past 'v' */
 	qv = 1; /* force quoted version processing */
     }
 
-    last = pos = s;
+    start = last = pos = s;
 
     /* pre-scan the input string to check for decimals/underbars */
     while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
@@ -3916,17 +3921,15 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 	pos++;
     }
 
-    if ( saw_period > 1 ) {
+    if ( saw_period > 1 )
 	qv = 1; /* force quoted version processing */
-    }
 
     pos = s;
 
     if ( qv )
 	hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
-    if ( saw_under ) {
+    if ( saw_under )
 	hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
-    }
     if ( !qv && width < 3 )
 	hv_store((HV *)hv, "width", 5, newSViv(width), 0);
     
@@ -3947,7 +3950,7 @@ Perl_scan_version(pTHX_ const 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 ) {
+ 		if ( !qv && s > start && saw_period == 1 ) {
 		    mult *= 100;
  		    while ( s < end ) {
  			orev = rev;
@@ -4035,14 +4038,14 @@ want to upgrade the SV.
 SV *
 Perl_new_version(pTHX_ SV *ver)
 {
-    SV *rv = newSV(0);
+    SV * const rv = newSV(0);
     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
     {
 	I32 key;
 	AV * const av = newAV();
 	AV *sav;
 	/* This will get reblessed later if a derived class*/
-	SV*  const hv = newSVrv(rv, "version"); 
+	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 */
@@ -4077,10 +4080,9 @@ Perl_new_version(pTHX_ SV *ver)
     }
 #ifdef SvVOK
     if ( SvVOK(ver) ) { /* already a v-string */
-	char *version;
-	MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
+	const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
 	const STRLEN len = mg->mg_len;
-	version = savepvn( (const char*)mg->mg_ptr, len);
+	char * const version = savepvn( (const char*)mg->mg_ptr, len);
 	sv_setpvn(rv,version,len);
 	Safefree(version);
     }
@@ -4120,7 +4122,7 @@ Perl_upg_version(pTHX_ SV *ver)
     }
 #ifdef SvVOK
     else if ( SvVOK(ver) ) { /* already a v-string */
-	MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
+	const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
 	version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
 	qv = 1;
     }
@@ -4134,6 +4136,45 @@ Perl_upg_version(pTHX_ SV *ver)
     return ver;
 }
 
+/*
+=for apidoc vverify
+
+Validates that the SV contains a valid version object.
+
+    bool vverify(SV *vobj);
+
+Note that it only confirms the bare minimum structure (so as not to get
+confused by derived classes which may contain additional hash entries):
+
+=over 4
+
+=item * The SV contains a hash (or a reference to one)
+
+=item * The hash contains a "version" key
+
+=item * The "version" key has an AV as its value
+
+=back
+
+=cut
+*/
+
+bool
+Perl_vverify(pTHX_ SV *vs)
+{
+    SV *sv;
+    if ( SvROK(vs) )
+	vs = SvRV(vs);
+
+    /* see if the appropriate elements exist */
+    if ( SvTYPE(vs) == SVt_PVHV
+	 && hv_exists((HV*)vs, "version", 7)
+	 && (sv = *hv_fetch((HV*)vs, "version", 7, FALSE))
+	 && SvTYPE(sv) == SVt_PVAV )
+	return TRUE;
+    else
+	return FALSE;
+}
 
 /*
 =for apidoc vnumify
@@ -4160,6 +4201,9 @@ Perl_vnumify(pTHX_ SV *vs)
     if ( SvROK(vs) )
 	vs = SvRV(vs);
 
+    if ( !vverify(vs) )
+	Perl_croak(aTHX_ "Invalid version object");
+
     /* see if various flags exist */
     if ( hv_exists((HV*)vs, "alpha", 5 ) )
 	alpha = TRUE;
@@ -4183,17 +4227,17 @@ Perl_vnumify(pTHX_ SV *vs)
     }
 
     digit = SvIV(*av_fetch(av, 0, 0));
-    Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
+    Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
     for ( i = 1 ; i < len ; i++ )
     {
 	digit = SvIV(*av_fetch(av, i, 0));
 	if ( width < 3 ) {
 	    const int denom = (int)pow(10,(3-width));
 	    const div_t term = div((int)PERL_ABS(digit),denom);
-	    Perl_sv_catpvf(aTHX_ sv,"%0*d_%d", width, term.quot, term.rem);
+	    Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
 	}
 	else {
-	    Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit);
+	    Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
 	}
     }
 
@@ -4201,14 +4245,12 @@ Perl_vnumify(pTHX_ SV *vs)
     {
 	digit = SvIV(*av_fetch(av, len, 0));
 	if ( alpha && width == 3 ) /* alpha version */
-	    Perl_sv_catpv(aTHX_ sv,"_");
-	/* Don't display additional trailing zeros */
-	if ( digit > 0 )
-	    Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit);
+	    sv_catpvn(sv,"_",1);
+	Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
     }
-    else /* len == 1 */
+    else /* len == 0 */
     {
-	 sv_catpvn(sv,"000",3);
+	sv_catpvn(sv,"000",3);
     }
     return sv;
 }
@@ -4232,28 +4274,33 @@ Perl_vnormal(pTHX_ SV *vs)
 {
     I32 i, len, digit;
     bool alpha = FALSE;
-    SV *sv = newSV(0);
+    SV * const sv = newSV(0);
     AV *av;
     if ( SvROK(vs) )
 	vs = SvRV(vs);
 
+    if ( !vverify(vs) )
+	Perl_croak(aTHX_ "Invalid version object");
+
     if ( hv_exists((HV*)vs, "alpha", 5 ) )
 	alpha = TRUE;
     av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE);
 
     len = av_len(av);
-    if ( len == -1 ) {
+    if ( len == -1 )
+    {
 	sv_catpvn(sv,"",0);
 	return sv;
     }
     digit = SvIV(*av_fetch(av, 0, 0));
-    Perl_sv_setpvf(aTHX_ sv,"v%"IVdf,(IV)digit);
+    Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
     for ( i = 1 ; i <= len-1 ; i++ ) {
 	digit = SvIV(*av_fetch(av, i, 0));
 	Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
     }
 
-    if ( len > 0 ) {
+    if ( len > 0 )
+    {
 	/* handle last digit specially */
 	digit = SvIV(*av_fetch(av, len, 0));
 	if ( alpha )
@@ -4266,7 +4313,6 @@ Perl_vnormal(pTHX_ SV *vs)
 	for ( len = 2 - len; len != 0; len-- )
 	    sv_catpvn(sv,".0",2);
     }
-
     return sv;
 }
 
@@ -4288,13 +4334,16 @@ Perl_vstringify(pTHX_ SV *vs)
     if ( SvROK(vs) )
 	vs = SvRV(vs);
     
+    if ( !vverify(vs) )
+	Perl_croak(aTHX_ "Invalid version object");
+
     if ( hv_exists((HV *)vs, "qv", 2) )
 	qv = 1;
     
     if ( qv )
-	return vnormal(vs);
+	return Perl_vnormal(aTHX_ vs);
     else
-	return vnumify(vs);
+	return Perl_vnumify(aTHX_ vs);
 }
 
 /*
@@ -4320,6 +4369,12 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
     if ( SvROK(rhv) )
 	rhv = SvRV(rhv);
 
+    if ( !vverify(lhv) )
+	Perl_croak(aTHX_ "Invalid version object");
+
+    if ( !vverify(rhv) )
+	Perl_croak(aTHX_ "Invalid version object");
+
     /* get the left hand term */
     lav = (AV *)*hv_fetch((HV*)lhv, "version", 7, FALSE);
     if ( hv_exists((HV*)lhv, "alpha", 5 ) )
@@ -4958,6 +5013,55 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
 
 #endif /* PERL_GLOBAL_STRUCT */
 
+#ifdef PERL_MEM_LOG
+
+#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
+
+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
+    /* We can't use PerlIO for obvious reasons. */
+    char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
+    sprintf(buf,
+	    "alloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf"\n",
+	    filename, linenumber, funcname,
+	    n, typesize, typename, n * typesize, PTR2UV(newalloc));
+    PerlLIO_write(2,  buf, strlen(buf));
+#endif
+    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
+    /* We can't use PerlIO for obvious reasons. */
+    char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
+    sprintf(buf,
+	    "realloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
+	    filename, linenumber, funcname,
+	    n, typesize, typename, n * typesize, PTR2UV(oldalloc), PTR2UV(newalloc));
+    PerlLIO_write(2,  buf, strlen(buf));
+#endif
+    return newalloc;
+}
+
+Malloc_t
+Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
+{
+#ifdef PERL_MEM_LOG_STDERR
+    /* We can't use PerlIO for obvious reasons. */
+    char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
+    sprintf(buf, "free: %s:%d:%s: %"UVxf"\n",
+	    filename, linenumber, funcname, PTR2UV(oldalloc));
+    PerlLIO_write(2,  buf, strlen(buf));
+#endif
+    return oldalloc;
+}
+
+#endif /* PERL_MEM_LOG */
+
 /*
  * Local variables:
  * c-indentation-style: bsd