X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=cf1dee0a0a3dd6d6815faf20089676fc361b0c6d;hb=c4fbe2471f42249bd57e1c071c99349d2331aea5;hp=b6155564738eedef11404c2e1478214819f6e53e;hpb=a2efc82216efc10377cf26fd4aff1aa5e66c6687;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/util.c b/util.c
index b615556..cf1dee0 100644
--- a/util.c
+++ b/util.c
@@ -504,7 +504,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 	sv_catpvn(sv, "\n", 1);		/* Taken into account in fbm_instr() */
     s = (U8*)SvPV_force(sv, len);
     (void)SvUPGRADE(sv, SVt_PVBM);
-    if (len == 0)		/* TAIL might be on on a zero-length string. */
+    if (len == 0)		/* TAIL might be on a zero-length string. */
 	return;
     if (len > 2) {
 	U8 mlen;
@@ -1054,7 +1054,7 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
 		      line_mode ? "line" : "chunk",
 		      (IV)IoLINES(GvIOp(PL_last_in_gv)));
 	}
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
 	if (thr->tid)
 	    Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
 #endif
@@ -1227,6 +1227,9 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args)
 	PL_restartop = die_where(message, msglen);
 	JMPENV_JUMP(3);
     }
+    else if (!message)
+	message = SvPVx(ERRSV, msglen);
+
     {
 #ifdef USE_SFIO
 	/* SFIO can really mess with your errno */
@@ -1234,7 +1237,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args)
 #endif
 	PerlIO *serr = Perl_error_log;
 
-	PerlIO_write(serr, message, msglen);
+	PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
 	(void)PerlIO_flush(serr);
 #ifdef USE_SFIO
 	errno = e;
@@ -1327,7 +1330,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
     {
 	PerlIO *serr = Perl_error_log;
 
-	PerlIO_write(serr, message, msglen);
+	PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
 #ifdef LEAKTEST
 	DEBUG_L(*message == '!'
 		? (xstat(message[1]=='!'
@@ -1406,9 +1409,9 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
     message = SvPV(msv, msglen);
 
     if (ckDEAD(err)) {
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
         DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
         if (PL_diehook) {
             /* sv_2cv might call Perl_croak() */
             SV *olddiehook = PL_diehook;
@@ -1442,7 +1445,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
         }
 	{
 	    PerlIO *serr = Perl_error_log;
-	    PerlIO_write(serr, message, msglen);
+	    PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
 	    (void)PerlIO_flush(serr);
 	}
         my_failure_exit();
@@ -1479,7 +1482,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
         }
 	{
 	    PerlIO *serr = Perl_error_log;
-	    PerlIO_write(serr, message, msglen);
+	    PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
 #ifdef LEAKTEST
 	    DEBUG_L(*message == '!'
 		? (xstat(message[1]=='!'
@@ -1493,6 +1496,16 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
     }
 }
 
+/* since we've already done strlen() for both nam and val
+ * we can use that info to make things faster than
+ * sprintf(s, "%s=%s", nam, val)
+ */
+#define my_setenv_format(s, nam, nlen, val, vlen) \
+   Copy(nam, s, nlen, char); \
+   *(s+nlen) = '='; \
+   Copy(val, s+(nlen+1), vlen, char); \
+   *(s+(nlen+1+vlen)) = '\0'
+
 #ifdef USE_ENVIRON_ARRAY
        /* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */
 #if !defined(WIN32) && !defined(NETWARE)
@@ -1502,6 +1515,7 @@ Perl_my_setenv(pTHX_ char *nam, char *val)
 #ifndef PERL_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;
 
     if (environ == PL_origenviron) {	/* need we copy environment? */
 	I32 j;
@@ -1512,8 +1526,9 @@ 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 */
-	    tmpenv[j] = (char*)safesysmalloc((strlen(environ[j])+1)*sizeof(char));
-	    strcpy(tmpenv[j], environ[j]);
+            int len = strlen(environ[j]);
+            tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
+            Copy(environ[j], tmpenv[j], len+1, char);
 	}
 	tmpenv[max] = Nullch;
 	environ = tmpenv;		/* tell exec where it is now */
@@ -1532,18 +1547,26 @@ Perl_my_setenv(pTHX_ char *nam, char *val)
     }
     else
 	safesysfree(environ[i]);
-    environ[i] = (char*)safesysmalloc((strlen(nam)+strlen(val)+2) * sizeof(char));
+    nlen = strlen(nam);
+    vlen = strlen(val);
 
-    (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
+    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__)
     setenv(nam, val, 1);
 #   else
     char *new_env;
-
-    new_env = (char*)safesysmalloc((strlen(nam) + strlen(val) + 2) * sizeof(char));
-    (void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */
+    int nlen = strlen(nam), vlen;
+    if (!val) {
+        val = "";
+    }
+    vlen = strlen(val);
+    new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+    /* all that work just for this */
+    my_setenv_format(new_env, nam, nlen, val, vlen);
     (void)putenv(new_env);
 #   endif /* __CYGWIN__ */
 #endif  /* PERL_USE_SAFE_PUTENV */
@@ -1555,13 +1578,14 @@ void
 Perl_my_setenv(pTHX_ char *nam,char *val)
 {
     register char *envstr;
-    STRLEN len = strlen(nam) + 3;
+    int nlen = strlen(nam), vlen;
+
     if (!val) {
 	val = "";
     }
-    len += strlen(val);
-    New(904, envstr, len, char);
-    (void)sprintf(envstr,"%s=%s",nam,val);
+    vlen = strlen(val);
+    New(904, envstr, nlen+vlen+2, char);
+    my_setenv_format(envstr, nam, nlen, val, vlen);
     (void)PerlEnv_putenv(envstr);
     Safefree(envstr);
 }
@@ -1933,6 +1957,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
 	did_pipes = 0;
 	if (n) {			/* Error */
 	    int pid2, status;
+	    PerlLIO_close(p[This]);
 	    if (n != sizeof(int))
 		Perl_croak(aTHX_ "panic: kid popen errno read");
 	    do {
@@ -2033,8 +2058,11 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 	}
 #endif	/* defined OS2 */
 	/*SUPPRESS 560*/
-	if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
+	if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
+        SvREADONLY_off(GvSV(tmpgv));
 	    sv_setiv(GvSV(tmpgv), PerlProc_getpid());
+        SvREADONLY_on(GvSV(tmpgv));
+    }
 	PL_forkprocess = 0;
 	hv_clear(PL_pidstatus);	/* we have no children */
 	return Nullfp;
@@ -2072,6 +2100,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 	did_pipes = 0;
 	if (n) {			/* Error */
 	    int pid2, status;
+	    PerlLIO_close(p[This]);
 	    if (n != sizeof(int))
 		Perl_croak(aTHX_ "panic: kid popen errno read");
 	    do {
@@ -2120,7 +2149,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 void
 Perl_atfork_lock(void)
 {
-#if defined(USE_THREADS) || defined(USE_ITHREADS)
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
     /* locks must be held in locking order (if any) */
 #  ifdef MYMALLOC
     MUTEX_LOCK(&PL_malloc_mutex);
@@ -2133,7 +2162,7 @@ Perl_atfork_lock(void)
 void
 Perl_atfork_unlock(void)
 {
-#if defined(USE_THREADS) || defined(USE_ITHREADS)
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
     /* locks must be released in same order as in atfork_lock() */
 #  ifdef MYMALLOC
     MUTEX_UNLOCK(&PL_malloc_mutex);
@@ -2147,7 +2176,7 @@ Perl_my_fork(void)
 {
 #if defined(HAS_FORK)
     Pid_t pid;
-#if (defined(USE_THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
+#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
     atfork_lock();
     pid = fork();
     atfork_unlock();
@@ -2285,7 +2314,8 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
     return PerlProc_signal(signo, handler);
 }
 
-static int sig_trapped;
+static int sig_trapped;	/* XXX signals are process-wide anyway, so we
+			   ignore the implications of this for threading */
 
 static
 Signal_t
@@ -2561,7 +2591,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f
     char *xfailed = Nullch;
     char tmpbuf[MAXPATHLEN];
     register char *s;
-    I32 len;
+    I32 len = 0;
     int retval;
 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
 #  define SEARCH_EXTS ".bat", ".cmd", NULL
@@ -2790,7 +2820,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f
 void *
 Perl_get_context(void)
 {
-#if defined(USE_THREADS) || defined(USE_ITHREADS)
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
 #  ifdef OLD_PTHREADS_API
     pthread_addr_t t;
     if (pthread_getspecific(PL_thr_key, &t))
@@ -2811,7 +2841,7 @@ Perl_get_context(void)
 void
 Perl_set_context(void *t)
 {
-#if defined(USE_THREADS) || defined(USE_ITHREADS)
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
 #  ifdef I_MACH_CTHREADS
     cthread_set_data(cthread_self(), t);
 #  else
@@ -2823,7 +2853,7 @@ Perl_set_context(void *t)
 
 #endif /* !PERL_GET_CONTEXT_DEFINED */
 
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
 
 #ifdef FAKE_THREADS
 /* Very simplistic scheduler for now */
@@ -3052,8 +3082,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
 
     PL_tainted = t->Ttainted;
     PL_curpm = t->Tcurpm;         /* XXX No PMOP ref count */
-    PL_nrs = newSVsv(t->Tnrs);
-    PL_rs = t->Tnrs ? SvREFCNT_inc(PL_nrs) : Nullsv;
+    PL_rs = newSVsv(t->Trs);
     PL_last_in_gv = Nullgv;
     PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv;
     PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
@@ -3096,7 +3125,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
 #endif /* HAVE_THREAD_INTERN */
     return thr;
 }
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
 
 #ifdef PERL_GLOBAL_STRUCT
 struct perl_vars *
@@ -3217,7 +3246,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id)
     case want_vtbl_uvar:
 	result = &PL_vtbl_uvar;
 	break;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
     case want_vtbl_mutex:
 	result = &PL_vtbl_mutex;
 	break;
@@ -3719,6 +3748,10 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 {
 #ifndef PERL_MICRO
 
+#ifndef INCOMPLETE_TAINTS
+    SvTAINTED_on(sv);
+#endif
+
 #ifdef HAS_GETCWD
     {
 	char buf[MAXPATHLEN];
@@ -3856,3 +3889,76 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 #endif
 }
 
+/*
+=for apidoc new_vstring
+
+Returns a pointer to the next character after the parsed
+vstring, as well as updating the passed in sv.
+ * 
+Function must be called like 
+ 	
+        sv = NEWSV(92,5);
+	s = new_vstring(s,sv);
+
+The sv must already be large enough to store the vstring
+passed in.
+
+=cut
+*/
+
+char *
+Perl_new_vstring(pTHX_ char *s, SV *sv)
+{
+    char *pos = s;
+    if (*pos == 'v') pos++;  /* get past 'v' */
+    while (isDIGIT(*pos) || *pos == '_')
+    pos++;
+    if (!isALPHA(*pos)) {
+	UV rev;
+	U8 tmpbuf[UTF8_MAXLEN+1];
+	U8 *tmpend;
+
+	if (*s == 'v') s++;  /* get past 'v' */
+
+	sv_setpvn(sv, "", 0);
+
+	for (;;) {
+	    rev = 0;
+	    {
+	    /* this is atoi() that tolerates underscores */
+	    char *end = pos;
+	    UV mult = 1;
+	    if ( *(s-1) == '_') {
+	    	mult = 10;
+	    }
+	    while (--end >= s) {
+		UV orev;
+		orev = rev;
+		rev += (*end - '0') * mult;
+		mult *= 10;
+		if (orev > rev && ckWARN_d(WARN_OVERFLOW))
+		Perl_warner(aTHX_ WARN_OVERFLOW,
+			"Integer overflow in decimal number");
+	    }
+	    }
+	    /* Append native character for the rev point */
+	    tmpend = uvchr_to_utf8(tmpbuf, rev);
+	    sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
+	    if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
+	    SvUTF8_on(sv);
+	    if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
+	    s = ++pos;
+	    else {
+	    s = pos;
+	    break;
+	    }
+	    while (isDIGIT(*pos) )
+	    pos++;
+	}
+	SvPOK_on(sv);
+	SvREADONLY_on(sv);
+    }
+    return s;
+}
+
+