X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=a92c4dba2b1003141427f5a134a5f5254bf1e2f6;hb=b3656ec34f74d879ca158a5689e6d4537869c415;hp=36c9186b94b6919cd29e98190291204ae23c24a9;hpb=5779bbb1f597d1ebb4c7e5a72ad2a31cf4b91093;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/util.c b/util.c
index 36c9186..a92c4db 100644
--- a/util.c
+++ b/util.c
@@ -81,12 +81,13 @@ long lastxycount[MAXXCOUNT][MAXYCOUNT];
 Malloc_t
 Perl_safesysmalloc(MEM_SIZE size)
 {
+    dTHX;
     Malloc_t ptr;
 #ifdef HAS_64K_LIMIT
 	if (size > 0xffff) {
 	    PerlIO_printf(PerlIO_stderr(),
 			  "Allocation too large: %lx\n", size) FLUSH;
-	    WITH_THX(my_exit(1));
+	    my_exit(1);
 	}
 #endif /* HAS_64K_LIMIT */
 #ifdef DEBUGGING
@@ -94,18 +95,14 @@ Perl_safesysmalloc(MEM_SIZE size)
 	Perl_croak_nocontext("panic: malloc");
 #endif
     ptr = PerlMem_malloc(size?size:1);	/* malloc(0) is NASTY on our system */
-#if !(defined(I286) || defined(atarist))
-    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size));
-#else
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size));
-#endif
     if (ptr != Nullch)
 	return ptr;
     else if (PL_nomemok)
 	return Nullch;
     else {
 	PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH;
-	WITH_THX(my_exit(1));
+	my_exit(1);
         return Nullch;
     }
     /*NOTREACHED*/
@@ -116,6 +113,7 @@ Perl_safesysmalloc(MEM_SIZE size)
 Malloc_t
 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 {
+    dTHX;
     Malloc_t ptr;
 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE)
     Malloc_t PerlMem_realloc();
@@ -125,7 +123,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     if (size > 0xffff) {
 	PerlIO_printf(PerlIO_stderr(),
 		      "Reallocation too large: %lx\n", size) FLUSH;
-	WITH_THX(my_exit(1));
+	my_exit(1);
     }
 #endif /* HAS_64K_LIMIT */
     if (!size) {
@@ -141,17 +139,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 #endif
     ptr = PerlMem_realloc(where,size);
 
-#if !(defined(I286) || defined(atarist))
-    DEBUG_m( {
-	PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,PL_an++);
-	PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size);
-    } )
-#else
-    DEBUG_m( {
-	PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,PL_an++);
-	PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size);
-    } )
-#endif
+    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,PL_an++));
+    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size));
 
     if (ptr != Nullch)
 	return ptr;
@@ -159,7 +148,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 	return Nullch;
     else {
 	PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH;
-	WITH_THX(my_exit(1));
+	my_exit(1);
 	return Nullch;
     }
     /*NOTREACHED*/
@@ -170,11 +159,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 Free_t
 Perl_safesysfree(Malloc_t where)
 {
-#if !(defined(I286) || defined(atarist))
-    DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",(char *) where,PL_an++));
-#else
+    dTHX;
     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(char *) where,PL_an++));
-#endif
     if (where) {
 	/*SUPPRESS 701*/
 	PerlMem_free(where);
@@ -186,13 +172,14 @@ Perl_safesysfree(Malloc_t where)
 Malloc_t
 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 {
+    dTHX;
     Malloc_t ptr;
 
 #ifdef HAS_64K_LIMIT
     if (size * count > 0xffff) {
 	PerlIO_printf(PerlIO_stderr(),
 		      "Allocation too large: %lx\n", size * count) FLUSH;
-	WITH_THX(my_exit(1));
+	my_exit(1);
     }
 #endif /* HAS_64K_LIMIT */
 #ifdef DEBUGGING
@@ -201,11 +188,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 #endif
     size *= count;
     ptr = PerlMem_malloc(size?size:1);	/* malloc(0) is NASTY on our system */
-#if !(defined(I286) || defined(atarist))
-    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld  x %ld bytes\n",ptr,PL_an++,(long)count,(long)size));
-#else
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,PL_an++,(long)count,(long)size));
-#endif
     if (ptr != Nullch) {
 	memset((void*)ptr, 0, size);
 	return ptr;
@@ -214,7 +197,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 	return Nullch;
     else {
 	PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH;
-	WITH_THX(my_exit(1));
+	my_exit(1);
 	return Nullch;
     }
     /*NOTREACHED*/
@@ -1396,8 +1379,33 @@ Perl_vform(pTHX_ const char *pat, va_list *args)
     return SvPVX(sv);
 }
 
+#if defined(PERL_IMPLICIT_CONTEXT)
+SV *
+Perl_mess_nocontext(const char *pat, ...)
+{
+    dTHX;
+    SV *retval;
+    va_list args;
+    va_start(args, pat);
+    retval = vmess(pat, &args);
+    va_end(args);
+    return retval;
+}
+#endif /* PERL_IMPLICIT_CONTEXT */
+
 SV *
-Perl_mess(pTHX_ const char *pat, va_list *args)
+Perl_mess(pTHX_ const char *pat, ...)
+{
+    SV *retval;
+    va_list args;
+    va_start(args, pat);
+    retval = vmess(pat, &args);
+    va_end(args);
+    return retval;
+}
+
+SV *
+Perl_vmess(pTHX_ const char *pat, va_list *args)
 {
     SV *sv = mess_alloc();
     static char dgd[] = " during global destruction.\n";
@@ -1455,8 +1463,14 @@ Perl_vdie(pTHX_ const char* pat, va_list *args)
 			  thr, PL_curstack, PL_mainstack));
 
     if (pat) {
-	msv = mess(pat, args);
-	message = SvPV(msv,msglen);
+	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);
     }
     else {
 	message = Nullch;
@@ -1546,9 +1560,18 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args)
     SV *msv;
     STRLEN msglen;
 
-    msv = mess(pat, args);
-    message = SvPV(msv,msglen);
-    DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
+    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);
+
+    DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s",
+			  (unsigned long) thr, message));
+
     if (PL_diehook) {
 	/* sv_2cv might call Perl_croak() */
 	SV *olddiehook = PL_diehook;
@@ -1626,7 +1649,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
     SV *msv;
     STRLEN msglen;
 
-    msv = mess(pat, args);
+    msv = vmess(pat, args);
     message = SvPV(msv, msglen);
 
     if (PL_warnhook) {
@@ -1722,7 +1745,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
     SV *msv;
     STRLEN msglen;
 
-    msv = mess(pat, args);
+    msv = vmess(pat, args);
     message = SvPV(msv, msglen);
 
     if (ckDEAD(err)) {
@@ -1839,28 +1862,13 @@ Perl_my_setenv(pTHX_ char *nam, char *val)
 	safesysfree(environ[i]);
     environ[i] = (char*)safesysmalloc((strlen(nam)+strlen(val)+2) * sizeof(char));
 
-#ifndef MSDOS
     (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
-#else
-    /* MS-DOS requires environment variable names to be in uppercase */
-    /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but
-     * some utilities and applications may break because they only look
-     * for upper case strings. (Fixed strupr() bug here.)]
-     */
-    strcpy(environ[i],nam); strupr(environ[i]);
-    (void)sprintf(environ[i] + strlen(nam),"=%s",val);
-#endif /* MSDOS */
 
 #else   /* PERL_USE_SAFE_PUTENV */
     char *new_env;
 
     new_env = (char*)safesysmalloc((strlen(nam) + strlen(val) + 2) * sizeof(char));
-#ifndef MSDOS
     (void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */
-#else
-    strcpy(new_env,nam); strupr(new_env);
-    (void)sprintf(new_env + strlen(nam),"=%s",val);
-#endif
     (void)putenv(new_env);
 #endif  /* PERL_USE_SAFE_PUTENV */
 }
@@ -2652,6 +2660,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     /* Needs work for PerlIO ! */
     FILE *f = PerlIO_findFILE(ptr);
     I32 result = pclose(f);
+#if defined(DJGPP)
+    result = (result << 8) & 0xff00;
+#endif
     PerlIO_releaseFILE(ptr,f);
     return result;
 }
@@ -2846,7 +2857,7 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
     if (!overflowed)
 	rnv = (NV) ruv;
     if (   ( overflowed && rnv > 4294967295.0)
-#if UV_SIZEOF > 4
+#if UVSIZE > 4
 	|| (!overflowed && ruv > 0xffffffff  )
 #endif
 	) { 
@@ -2911,7 +2922,7 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
     if (!overflowed)
 	rnv = (NV) ruv;
     if (   ( overflowed && rnv > 4294967295.0)
-#if UV_SIZEOF > 4
+#if UVSIZE > 4
 	|| (!overflowed && ruv > 0xffffffff  )
 #endif
 	) {
@@ -2979,7 +2990,7 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
     if (!overflowed)
 	rnv = (NV) ruv;
     if (   ( overflowed && rnv > 4294967295.0)
-#if UV_SIZEOF > 4
+#if UVSIZE > 4
 	|| (!overflowed && ruv > 0xffffffff  )
 #endif
 	) { 
@@ -3399,6 +3410,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
     PL_restartop = 0;
 
     PL_statname = NEWSV(66,0);
+    PL_errors = newSVpvn("", 0);
     PL_maxscream = -1;
     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);