Perl_eval_pv() leaks 4 bytes every time it is called because it

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

diff --git a/util.c b/util.c
index 4b0e1c5..a5cd954 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1515,6 +1515,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args)
            SV *msg;
 
            ENTER;
+           save_re_context();
            if (message) {
                msg = newSVpvn(message, msglen);
                SvREADONLY_on(msg);
@@ -1579,14 +1580,20 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args)
     SV *msv;
     STRLEN 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);
+    if (pat) {
+       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;
+       msglen = 0;
     }
-    else
-       message = SvPV(msv,msglen);
 
     DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
                          PTR2UV(thr), message));
@@ -1604,9 +1611,15 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args)
            SV *msg;
 
            ENTER;
-           msg = newSVpvn(message, msglen);
-           SvREADONLY_on(msg);
-           SAVEFREESV(msg);
+           save_re_context();
+           if (message) {
+               msg = newSVpvn(message, msglen);
+               SvREADONLY_on(msg);
+               SAVEFREESV(msg);
+           }
+           else {
+               msg = ERRSV;
+           }
 
            PUSHSTACKi(PERLSI_DIEHOOK);
            PUSHMARK(SP);
@@ -1653,9 +1666,16 @@ Perl_croak_nocontext(const char *pat, ...)
 /*
 =for apidoc croak
 
-This is the XSUB-writer's interface to Perl's C<die> function.  Use this
-function the same way you use the C C<printf> function.  See
-C<warn>.
+This is the XSUB-writer's interface to Perl's C<die> function.
+Normally use this function the same way you use the C C<printf>
+function.  See C<warn>.
+
+If you want to throw an exception object, assign the object to
+C<$@> and then pass C<Nullch> to croak():
+
+   errsv = get_sv("@", TRUE);
+   sv_setsv(errsv, exception_object);
+   croak(Nullch);
 
 =cut
 */
@@ -1697,6 +1717,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
            SV *msg;
 
            ENTER;
+           save_re_context();
            msg = newSVpvn(message, msglen);
            SvREADONLY_on(msg);
            SAVEFREESV(msg);
@@ -1810,15 +1831,17 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
                 SV *msg;
  
                 ENTER;
+               save_re_context();
                 msg = newSVpvn(message, msglen);
                 SvREADONLY_on(msg);
                 SAVEFREESV(msg);
  
+               PUSHSTACKi(PERLSI_DIEHOOK);
                 PUSHMARK(sp);
                 XPUSHs(msg);
                 PUTBACK;
                 call_sv((SV*)cv, G_DISCARD);
- 
+               POPSTACK;
                 LEAVE;
             }
         }
@@ -1843,21 +1866,23 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
             SAVESPTR(PL_warnhook);
             PL_warnhook = Nullsv;
             cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
-                LEAVE;
+           LEAVE;
             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
                 dSP;
                 SV *msg;
  
                 ENTER;
+               save_re_context();
                 msg = newSVpvn(message, msglen);
                 SvREADONLY_on(msg);
                 SAVEFREESV(msg);
  
+               PUSHSTACKi(PERLSI_WARNHOOK);
                 PUSHMARK(sp);
                 XPUSHs(msg);
                 PUTBACK;
                 call_sv((SV*)cv, G_DISCARD);
- 
+               POPSTACK;
                 LEAVE;
                 return;
             }
@@ -2294,7 +2319,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
     PERL_FLUSHALL_FOR_CHILD;
 #ifdef OS2
     if (doexec) {
-       return my_syspopen(cmd,mode);
+       return my_syspopen(aTHX_ cmd,mode);
     }
 #endif 
     This = (*mode == 'w');
@@ -2870,9 +2895,13 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
 
     for (; len-- && *s; s++) {
        if (!(*s == '0' || *s == '1')) {
-           if (*s == '_')
-               continue; /* Note: does not check for __ and the like. */
-           if (seenb == FALSE && *s == 'b' && ruv == 0) {
+           if (*s == '_' && len && *retlen
+               && (s[1] == '0' || s[1] == '1'))
+           {
+               --len;
+               ++s;
+           }
+           else if (seenb == FALSE && *s == 'b' && ruv == 0) {
                /* Disallow 0bbb0b0bbb... */
                seenb = TRUE;
                continue;
@@ -2895,7 +2924,8 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
                if (ckWARN_d(WARN_OVERFLOW))
                    Perl_warner(aTHX_ WARN_OVERFLOW,
                                "Integer overflow in binary number");
-           } else
+           }
+           else
                ruv = xuv | (*s - '0');
        }
        if (overflowed) {
@@ -2935,8 +2965,12 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
 
     for (; len-- && *s; s++) {
        if (!(*s >= '0' && *s <= '7')) {
-           if (*s == '_')
-               continue; /* Note: does not check for __ and the like. */
+           if (*s == '_' && len && *retlen
+               && (s[1] >= '0' && s[1] <= '7'))
+           {
+               --len;
+               ++s;
+           }
            else {
                /* Allow \octal to work the DWIM way (that is, stop scanning
                 * as soon as non-octal characters are seen, complain only iff
@@ -2960,7 +2994,8 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
                if (ckWARN_d(WARN_OVERFLOW))
                    Perl_warner(aTHX_ WARN_OVERFLOW,
                                "Integer overflow in octal number");
-           } else
+           }
+           else
                ruv = xuv | (*s - '0');
        }
        if (overflowed) {
@@ -3003,9 +3038,13 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
     for (; len-- && *s; s++) {
        hexdigit = strchr((char *) PL_hexdigit, *s);
        if (!hexdigit) {
-           if (*s == '_')
-               continue; /* Note: does not check for __ and the like. */
-           if (seenx == FALSE && *s == 'x' && ruv == 0) {
+           if (*s == '_' && len && *retlen && s[1]
+               && (hexdigit = strchr((char *) PL_hexdigit, s[1])))
+           {
+               --len;
+               ++s;
+           }
+           else if (seenx == FALSE && *s == 'x' && ruv == 0) {
                /* Disallow 0xxx0x0xxx... */
                seenx = TRUE;
                continue;
@@ -3028,7 +3067,8 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
                if (ckWARN_d(WARN_OVERFLOW))
                    Perl_warner(aTHX_ WARN_OVERFLOW,
                                "Integer overflow in hexadecimal number");
-           } else
+           }
+           else
                ruv = xuv | ((hexdigit - PL_hexdigit) & 15);
        }
        if (overflowed) {
@@ -3570,7 +3610,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
 }
 #endif /* USE_THREADS */
 
-#ifdef HUGE_VAL
+#if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
 /*
  * This hack is to force load of "huge" support from libm.a
  * So it is in perl for (say) POSIX to use. 
@@ -3579,7 +3619,10 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
 NV 
 Perl_huge(void)
 {
- return HUGE_VAL;
+#   if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
+    return HUGE_VALL;
+#   endif
+    return HUGE_VAL;
 }
 #endif
 
@@ -3623,7 +3666,7 @@ Perl_get_ppaddr(pTHX)
 
 #ifndef HAS_GETENV_LEN
 char *
-Perl_getenv_len(pTHX_ char *env_elem, unsigned long *len)
+Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
 {
     char *env_trans = PerlEnv_getenv(env_elem);
     if (env_trans)
@@ -3817,6 +3860,6 @@ Perl_report_closed_fh(pTHX_ GV *gv, IO *io, const char *func, const char *obj)
 
     if (io && IoDIRP(io))
        Perl_warner(aTHX_ WARN_CLOSED,
-                   "(Are you trying to call %s() on dirhandle %s?)\n",
+                   "\t(Are you trying to call %s() on dirhandle %s?)\n",
                    func, name);
 }