allow embedded null characters in diagnostics

p4raw-id: //depot/perl@3274

diff --git a/pp_ctl.c b/pp_ctl.c
index 7ac600b..0beaea9 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1319,7 +1319,7 @@ dounwind(I32 cxix)
 }
 
 OP *
-die_where(char *message)
+die_where(char *message, STRLEN msglen)
 {
     dSP;
     STRLEN n_a;
@@ -1332,9 +1332,8 @@ die_where(char *message)
        if (message) {
            if (PL_in_eval & 4) {
                SV **svp;
-               STRLEN klen = strlen(message);
                
-               svp = hv_fetch(ERRHV, message, klen, TRUE);
+               svp = hv_fetch(ERRHV, message, msglen, TRUE);
                if (svp) {
                    if (!SvIOK(*svp)) {
                        static char prefix[] = "\t(in cleanup) ";
@@ -1343,11 +1342,11 @@ die_where(char *message)
                        (void)SvIOK_only(*svp);
                        if (!SvPOK(err))
                            sv_setpv(err,"");
-                       SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
+                       SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
                        sv_catpvn(err, prefix, sizeof(prefix)-1);
-                       sv_catpvn(err, message, klen);
+                       sv_catpvn(err, message, msglen);
                        if (ckWARN(WARN_UNSAFE)) {
-                           STRLEN start = SvCUR(err)-klen-sizeof(prefix)+1;
+                           STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
                            warner(WARN_UNSAFE, SvPVX(err)+start);
                        }
                    }
@@ -1355,10 +1354,10 @@ die_where(char *message)
                }
            }
            else
-               sv_setpv(ERRSV, message);
+               sv_setpvn(ERRSV, message, msglen);
        }
        else
-           message = SvPVx(ERRSV, n_a);
+           message = SvPVx(ERRSV, msglen);
 
        while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
            dounwind(-1);
@@ -1373,7 +1372,8 @@ die_where(char *message)
 
            POPBLOCK(cx,PL_curpm);
            if (CxTYPE(cx) != CXt_EVAL) {
-               PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
+               PerlIO_write(PerlIO_stderr(), "panic: die ", 11);
+               PerlIO_write(PerlIO_stderr(), message, msglen);
                my_exit(1);
            }
            POPEVAL(cx);
@@ -1392,13 +1392,13 @@ die_where(char *message)
        }
     }
     if (!message)
-       message = SvPVx(ERRSV, n_a);
+       message = SvPVx(ERRSV, msglen);
     {
 #ifdef USE_SFIO
        /* SFIO can really mess with your errno */
        int e = errno;
 #endif
-       PerlIO_puts(PerlIO_stderr(), message);
+       PerlIO_write(PerlIO_stderr(), message, msglen);
        (void)PerlIO_flush(PerlIO_stderr());
 #ifdef USE_SFIO
        errno = e;

diff --git a/pp_sys.c b/pp_sys.c
index 3998497..45eee0b 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -400,27 +400,31 @@ PP(pp_rcatline)
 PP(pp_warn)
 {
     djSP; dMARK;
+    SV *tmpsv;
     char *tmps;
-    STRLEN n_a;
+    STRLEN len;
     if (SP - MARK != 1) {
        dTARGET;
        do_join(TARG, &PL_sv_no, MARK, SP);
-       tmps = SvPV(TARG, n_a);
+       tmpsv = TARG;
        SP = MARK + 1;
     }
     else {
-       tmps = SvPV(TOPs, n_a);
+       tmpsv = TOPs;
     }
-    if (!tmps || !*tmps) {
+    tmps = SvPV(tmpsv, len);
+    if (!tmps || !len) {
        SV *error = ERRSV;
        (void)SvUPGRADE(error, SVt_PV);
        if (SvPOK(error) && SvCUR(error))
            sv_catpv(error, "\t...caught");
-       tmps = SvPV(error, n_a);
+       tmpsv = error;
+       tmps = SvPV(tmpsv, len);
     }
-    if (!tmps || !*tmps)
-       tmps = "Warning: something's wrong";
-    warn("%s", tmps);
+    if (!tmps || !len)
+       tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
+
+    warn("%_", tmpsv);
     RETSETYES;
 }
 
@@ -428,26 +432,28 @@ PP(pp_die)
 {
     djSP; dMARK;
     char *tmps;
-    SV *tmpsv = Nullsv;
-    char *pat = "%s";
-    STRLEN n_a;
+    SV *tmpsv;
+    STRLEN len;
+    bool multiarg = 0;
     if (SP - MARK != 1) {
        dTARGET;
        do_join(TARG, &PL_sv_no, MARK, SP);
-       tmps = SvPV(TARG, n_a);
+       tmpsv = TARG;
+       tmps = SvPV(tmpsv, len);
+       multiarg = 1;
        SP = MARK + 1;
     }
     else {
        tmpsv = TOPs;
-       tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, n_a);
+       tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
     }
-    if (!tmps || !*tmps) {
+    if (!tmps || !len) {
        SV *error = ERRSV;
        (void)SvUPGRADE(error, SVt_PV);
-       if(tmpsv ? SvROK(tmpsv) : SvROK(error)) {
-           if(tmpsv)
+       if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
+           if (!multiarg)
                SvSetSV(error,tmpsv);
-           else if(sv_isobject(error)) {
+           else if (sv_isobject(error)) {
                HV *stash = SvSTASH(SvRV(error));
                GV *gv = gv_fetchmethod(stash, "PROPAGATE");
                if (gv) {
@@ -464,17 +470,19 @@ PP(pp_die)
                    sv_setsv(error,*PL_stack_sp--);
                }
            }
-           pat = Nullch;
+           DIE(Nullch);
        }
        else {
            if (SvPOK(error) && SvCUR(error))
                sv_catpv(error, "\t...propagated");
-           tmps = SvPV(error, n_a);
+           tmpsv = error;
+           tmps = SvPV(tmpsv, len);
        }
     }
-    if (!tmps || !*tmps)
-       tmps = "Died";
-    DIE(pat, tmps);
+    if (!tmps || !len)
+       tmpsv = sv_2mortal(newSVpvn("Died", 4));
+
+    DIE("%_", tmpsv);
 }
 
 /* I/O. */

diff --git a/proto.h b/proto.h
index cc98104..d430c45 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -91,7 +91,7 @@ VIRTUAL char* delimcpy _((char* to, char* toend, char* from, char* fromend,
                    int delim, I32* retlen));
 VIRTUAL void   deprecate _((char* s));
 VIRTUAL OP*    die _((const char* pat,...));
-VIRTUAL OP*    die_where _((char* message));
+VIRTUAL OP*    die_where _((char* message, STRLEN msglen));
 VIRTUAL void   dounwind _((I32 cxix));
 VIRTUAL bool   do_aexec _((SV* really, SV** mark, SV** sp));
 VIRTUAL int    do_binmode _((PerlIO *fp, int iotype, int flag));
@@ -302,7 +302,7 @@ VIRTUAL void        markstack_grow _((void));
 #ifdef USE_LOCALE_COLLATE
 VIRTUAL char*  mem_collxfrm _((const char* s, STRLEN len, STRLEN* xlen));
 #endif
-VIRTUAL char*  mess _((const char* pat, va_list* args));
+VIRTUAL SV*    mess _((const char* pat, va_list* args));
 VIRTUAL int    mg_clear _((SV* sv));
 VIRTUAL int    mg_copy _((SV* sv, SV* nsv, const char* key, I32 klen));
 VIRTUAL MAGIC* mg_find _((SV* sv, int type));

diff --git a/regcomp.c b/regcomp.c
index d8a62da..2755d61 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -3192,6 +3192,7 @@ re_croak2(const char* pat1,const char* pat2,...)
     STRLEN l1 = strlen(pat1);
     STRLEN l2 = strlen(pat2);
     char buf[512];
+    SV *msv;
     char *message;
 
     if (l1 > 510)
@@ -3203,9 +3204,9 @@ re_croak2(const char* pat1,const char* pat2,...)
     buf[l1 + l2] = '\n';
     buf[l1 + l2 + 1] = '\0';
     va_start(args, pat2);
-    message = mess(buf, &args);
+    msv = mess(buf, &args);
     va_end(args);
-    l1 = strlen(message);
+    message = SvPV(msv,l1);
     if (l1 > 512)
        l1 = 512;
     Copy(message, buf, l1 , char);

diff --git a/t/op/die.t b/t/op/die.t
index d473ed6..cf4f8b0 100755 (executable)
--- a/t/op/die.t
+++ b/t/op/die.t
@@ -4,7 +4,7 @@ print "1..10\n";
 
 $SIG{__DIE__} = sub { print ref($_[0]) ? ("ok ",$_[0]->[0]++,"\n") : @_ } ;
 
-$err = "ok 1\n";
+$err = "#[\000]\nok 1\n";
 eval {
     die $err;
 };

diff --git a/util.c b/util.c
index b6a9fe0..1318c31 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1213,7 +1213,7 @@ form(const char* pat, ...)
     return SvPVX(sv);
 }
 
-char *
+SV *
 mess(const char *pat, va_list *args)
 {
     SV *sv = mess_alloc();
@@ -1239,7 +1239,7 @@ mess(const char *pat, va_list *args)
            sv_catpv(sv, ".\n");
        }
     }
-    return SvPVX(sv);
+    return sv;
 }
 
 OP *
@@ -1252,13 +1252,21 @@ die(const char* pat, ...)
     HV *stash;
     GV *gv;
     CV *cv;
+    SV *msv;
+    STRLEN msglen;
 
     DEBUG_S(PerlIO_printf(PerlIO_stderr(),
                          "%p: die: curstack = %p, mainstack = %p\n",
                          thr, PL_curstack, PL_mainstack));
 
     va_start(args, pat);
-    message = pat ? mess(pat, &args) : Nullch;
+    if (pat) {
+       msv = mess(pat, &args);
+       message = SvPV(msv,msglen);
+    }
+    else {
+       message = Nullch;
+    }
     va_end(args);
 
     DEBUG_S(PerlIO_printf(PerlIO_stderr(),
@@ -1278,7 +1286,7 @@ die(const char* pat, ...)
 
            ENTER;
            if (message) {
-               msg = newSVpv(message, 0);
+               msg = newSVpvn(message, msglen);
                SvREADONLY_on(msg);
                SAVEFREESV(msg);
            }
@@ -1296,7 +1304,7 @@ die(const char* pat, ...)
        }
     }
 
-    PL_restartop = die_where(message);
+    PL_restartop = die_where(message, msglen);
     DEBUG_S(PerlIO_printf(PerlIO_stderr(),
          "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
          thr, PL_restartop, was_in_eval, PL_top_env));
@@ -1314,9 +1322,12 @@ croak(const char* pat, ...)
     HV *stash;
     GV *gv;
     CV *cv;
+    SV *msv;
+    STRLEN msglen;
 
     va_start(args, pat);
-    message = mess(pat, &args);
+    msv = mess(pat, &args);
+    message = SvPV(msv,msglen);
     va_end(args);
     DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
     if (PL_diehook) {
@@ -1332,7 +1343,7 @@ croak(const char* pat, ...)
            SV *msg;
 
            ENTER;
-           msg = newSVpv(message, 0);
+           msg = newSVpvn(message, msglen);
            SvREADONLY_on(msg);
            SAVEFREESV(msg);
 
@@ -1346,7 +1357,7 @@ croak(const char* pat, ...)
        }
     }
     if (PL_in_eval) {
-       PL_restartop = die_where(message);
+       PL_restartop = die_where(message, msglen);
        JMPENV_JUMP(3);
     }
     {
@@ -1354,7 +1365,7 @@ croak(const char* pat, ...)
        /* SFIO can really mess with your errno */
        int e = errno;
 #endif
-       PerlIO_puts(PerlIO_stderr(), message);
+       PerlIO_write(PerlIO_stderr(), message, msglen);
        (void)PerlIO_flush(PerlIO_stderr());
 #ifdef USE_SFIO
        errno = e;
@@ -1371,9 +1382,12 @@ warn(const char* pat,...)
     HV *stash;
     GV *gv;
     CV *cv;
+    SV *msv;
+    STRLEN msglen;
 
     va_start(args, pat);
-    message = mess(pat, &args);
+    msv = mess(pat, &args);
+    message = SvPV(msv, msglen);
     va_end(args);
 
     if (PL_warnhook) {
@@ -1390,7 +1404,7 @@ warn(const char* pat,...)
            SV *msg;
 
            ENTER;
-           msg = newSVpv(message, 0);
+           msg = newSVpvn(message, msglen);
            SvREADONLY_on(msg);
            SAVEFREESV(msg);
 
@@ -1404,7 +1418,7 @@ warn(const char* pat,...)
            return;
        }
     }
-    PerlIO_puts(PerlIO_stderr(),message);
+    PerlIO_write(PerlIO_stderr(), message, msglen);
 #ifdef LEAKTEST
     DEBUG_L(*message == '!' 
            ? (xstat(message[1]=='!'
@@ -1425,9 +1439,12 @@ warner(U32  err, const char* pat,...)
     HV *stash;
     GV *gv;
     CV *cv;
+    SV *msv;
+    STRLEN msglen;
 
     va_start(args, pat);
-    message = mess(pat, &args);
+    msv = mess(pat, &args);
+    message = SvPV(msv, msglen);
     va_end(args);
 
     if (ckDEAD(err)) {
@@ -1447,7 +1464,7 @@ warner(U32  err, const char* pat,...)
                 SV *msg;
  
                 ENTER;
-                msg = newSVpv(message, 0);
+                msg = newSVpvn(message, msglen);
                 SvREADONLY_on(msg);
                 SAVEFREESV(msg);
  
@@ -1460,10 +1477,10 @@ warner(U32  err, const char* pat,...)
             }
         }
         if (PL_in_eval) {
-            PL_restartop = die_where(message);
+            PL_restartop = die_where(message, msglen);
             JMPENV_JUMP(3);
         }
-        PerlIO_puts(PerlIO_stderr(),message);
+        PerlIO_write(PerlIO_stderr(), message, msglen);
         (void)PerlIO_flush(PerlIO_stderr());
         my_failure_exit();
 
@@ -1483,7 +1500,7 @@ warner(U32  err, const char* pat,...)
                 SV *msg;
  
                 ENTER;
-                msg = newSVpv(message, 0);
+                msg = newSVpvn(message, msglen);
                 SvREADONLY_on(msg);
                 SAVEFREESV(msg);
  
@@ -1496,7 +1513,7 @@ warner(U32  err, const char* pat,...)
                 return;
             }
         }
-        PerlIO_puts(PerlIO_stderr(),message);
+        PerlIO_write(PerlIO_stderr(), message, msglen);
 #ifdef LEAKTEST
         DEBUG_L(xstat());
 #endif