projects / p5sagit/p5-mst-13.2.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
[p5sagit/p5-mst-13.2.git] / util.c
diff --git a/util.c b/util.c
index a36d899..552c092 100644 (file)
--- a/util.c
+++ b/util.c
@@ -139,10 +139,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 #endif
     ptr = PerlMem_realloc(where,size);
 
-    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);
-    } )
+    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;
@@ -1824,28 +1822,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 */
 }
@@ -2207,7 +2190,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;
@@ -2278,7 +2261,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;
@@ -2500,8 +2483,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
@@ -2512,7 +2495,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
@@ -2551,7 +2534,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;
@@ -2611,7 +2594,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)];
@@ -2637,6 +2620,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;
 }
@@ -2798,8 +2784,8 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
            }
            else {
                dTHR;
-               if (ckWARN(WARN_UNSAFE))
-                   Perl_warner(aTHX_ WARN_UNSAFE,
+               if (ckWARN(WARN_DIGIT))
+                   Perl_warner(aTHX_ WARN_DIGIT,
                                "Illegal binary digit '%c' ignored", *s);
                break;
            }
@@ -2811,8 +2797,8 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
                dTHR;
                overflowed = TRUE;
                rnv = (NV) ruv;
-               if (ckWARN_d(WARN_UNSAFE))
-                   Perl_warner(aTHX_ WARN_UNSAFE,
+               if (ckWARN_d(WARN_OVERFLOW))
+                   Perl_warner(aTHX_ WARN_OVERFLOW,
                                "Integer overflow in binary number");
            } else
                ruv = xuv | (*s - '0');
@@ -2831,13 +2817,13 @@ 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
        ) { 
        dTHR;
-       if (ckWARN(WARN_UNSAFE))
-           Perl_warner(aTHX_ WARN_UNSAFE,
+       if (ckWARN(WARN_PORTABLE))
+           Perl_warner(aTHX_ WARN_PORTABLE,
                        "Binary number > 0b11111111111111111111111111111111 non-portable");
     }
     *retlen = s - start;
@@ -2862,8 +2848,8 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
                 * someone seems to want to use the digits eight and nine). */
                if (*s == '8' || *s == '9') {
                    dTHR;
-                   if (ckWARN(WARN_OCTAL))
-                       Perl_warner(aTHX_ WARN_OCTAL,
+                   if (ckWARN(WARN_DIGIT))
+                       Perl_warner(aTHX_ WARN_DIGIT,
                                    "Illegal octal digit '%c' ignored", *s);
                }
                break;
@@ -2876,8 +2862,8 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
                dTHR;
                overflowed = TRUE;
                rnv = (NV) ruv;
-               if (ckWARN_d(WARN_UNSAFE))
-                   Perl_warner(aTHX_ WARN_UNSAFE,
+               if (ckWARN_d(WARN_OVERFLOW))
+                   Perl_warner(aTHX_ WARN_OVERFLOW,
                                "Integer overflow in octal number");
            } else
                ruv = xuv | (*s - '0');
@@ -2896,13 +2882,13 @@ 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
        ) {
        dTHR;
-       if (ckWARN(WARN_UNSAFE))
-           Perl_warner(aTHX_ WARN_UNSAFE,
+       if (ckWARN(WARN_PORTABLE))
+           Perl_warner(aTHX_ WARN_PORTABLE,
                        "Octal number > 037777777777 non-portable");
     }
     *retlen = s - start;
@@ -2931,8 +2917,8 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
            }
            else {
                dTHR;
-               if (ckWARN(WARN_UNSAFE))
-                   Perl_warner(aTHX_ WARN_UNSAFE,
+               if (ckWARN(WARN_DIGIT))
+                   Perl_warner(aTHX_ WARN_DIGIT,
                                "Illegal hexadecimal digit '%c' ignored", *s);
                break;
            }
@@ -2944,8 +2930,8 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
                dTHR;
                overflowed = TRUE;
                rnv = (NV) ruv;
-               if (ckWARN_d(WARN_UNSAFE))
-                   Perl_warner(aTHX_ WARN_UNSAFE,
+               if (ckWARN_d(WARN_OVERFLOW))
+                   Perl_warner(aTHX_ WARN_OVERFLOW,
                                "Integer overflow in hexadecimal number");
            } else
                ruv = xuv | ((hexdigit - PL_hexdigit) & 15);
@@ -2964,13 +2950,13 @@ 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
        ) { 
        dTHR;
-       if (ckWARN(WARN_UNSAFE))
-           Perl_warner(aTHX_ WARN_UNSAFE,
+       if (ckWARN(WARN_PORTABLE))
+           Perl_warner(aTHX_ WARN_PORTABLE,
                        "Hexadecimal number > 0xffffffff non-portable");
     }
     *retlen = s - start;
Unnamed repository; edit this file to name it for gitweb.