There *is* a month called October.

[p5sagit/p5-mst-13.2.git] / util.c

diff --git a/util.c b/util.c
index c84510e..a92c4db 100644 (file)
--- 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;
@@ -1491,7 +1505,11 @@ Perl_vdie(pTHX_ const char* pat, va_list *args)
            PUSHMARK(SP);
            XPUSHs(msg);
            PUTBACK;
-           call_sv((SV*)cv, G_DISCARD);
+           /* HACK - REVISIT - avoid CATCH_SET(TRUE) in call_sv()
+              or we come back here due to a JMPENV_JMP() and do 
+              a POPSTACK - but die_where() will have already done 
+              one as it unwound - NI-S 1999/08/14 */
+           call_sv((SV*)cv, G_DISCARD|G_NOCATCH);
            POPSTACK;
            LEAVE;
        }
@@ -1542,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;
@@ -1622,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) {
@@ -1718,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)) {
@@ -1835,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 */
 }
@@ -2218,7 +2230,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 {
     int p[2];
     register I32 This, that;
-    register I32 pid;
+    register Pid_t pid;
     SV *sv;
     I32 doexec = strNE(cmd,"-");
     I32 did_pipes = 0;
@@ -2289,7 +2301,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 #endif /* defined OS2 */
        /*SUPPRESS 560*/
        if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
-           sv_setiv(GvSV(tmpgv), (IV)getpid());
+           sv_setiv(GvSV(tmpgv), getpid());
        PL_forkprocess = 0;
        hv_clear(PL_pidstatus); /* we have no children */
        return Nullfp;
@@ -2511,8 +2523,8 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     Sigsave_t hstat, istat, qstat;
     int status;
     SV **svp;
-    int pid;
-    int pid2;
+    Pid_t pid;
+    Pid_t pid2;
     bool close_failed;
     int saved_errno;
 #ifdef VMS
@@ -2523,7 +2535,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 #endif
 
     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
-    pid = (int)SvIVX(*svp);
+    pid = SvIVX(*svp);
     SvREFCNT_dec(*svp);
     *svp = &PL_sv_undef;
 #ifdef OS2
@@ -2562,7 +2574,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 
 #if  !defined(DOSISH) || defined(OS2) || defined(WIN32)
 I32
-Perl_wait4pid(pTHX_ int pid, int *statusp, int flags)
+Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 {
     SV *sv;
     SV** svp;
@@ -2622,7 +2634,7 @@ Perl_wait4pid(pTHX_ int pid, int *statusp, int flags)
 
 void
 /*SUPPRESS 590*/
-Perl_pidgone(pTHX_ int pid, int status)
+Perl_pidgone(pTHX_ Pid_t pid, int status)
 {
     register SV *sv;
     char spid[TYPE_CHARS(int)];
@@ -2648,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;
 }
@@ -2842,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
        ) { 
@@ -2907,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
        ) {
@@ -2975,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
        ) { 
@@ -3395,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);