This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Encoding neutral unpack
[perl5.git] / util.c
diff --git a/util.c b/util.c
index 81d1ef7..fc99463 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1,7 +1,7 @@
 /*    util.c
  *
  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -758,10 +758,18 @@ char *
 Perl_savepv(pTHX_ const char *pv)
 {
     register char *newaddr;
+#ifdef PERL_MALLOC_WRAP
+    STRLEN pvlen;
+#endif
     if (!pv)
        return Nullch;
 
+#ifdef PERL_MALLOC_WRAP
+    pvlen = strlen(pv)+1;
+    New(902,newaddr,pvlen,char);
+#else
     New(902,newaddr,strlen(pv)+1,char);
+#endif
     return strcpy(newaddr,pv);
 }
 
@@ -819,6 +827,26 @@ Perl_savesharedpv(pTHX_ const char *pv)
     return strcpy(newaddr,pv);
 }
 
+/*
+=for apidoc savesvpv
+
+A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
+the passed in SV using C<SvPV()>
+
+=cut
+*/
+
+char *
+Perl_savesvpv(pTHX_ SV *sv)
+{
+    STRLEN len;
+    const char *pv = SvPV(sv, len);
+    register char *newaddr;
+
+    ++len;
+    New(903,newaddr,len,char);
+    return CopyD(pv,newaddr,len,char);
+}
 
 
 /* the SV for Perl_form() and mess() is not kept in an arena */
@@ -1037,6 +1065,40 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
     }
 }
 
+/* Common code used by vcroak, vdie and vwarner  */
+
+void S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8);
+
+char *
+S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
+                   I32* utf8)
+{
+    char *message;
+
+    if (pat) {
+       SV *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);
+       *utf8 = SvUTF8(msv);
+    }
+    else {
+       message = Nullch;
+    }
+
+    DEBUG_S(PerlIO_printf(Perl_debug_log,
+                         "%p: die/croak: message = %s\ndiehook = %p\n",
+                         thr, message, PL_diehook));
+    if (PL_diehook) {
+       S_vdie_common(aTHX_ message, *msglen, *utf8);
+    }
+    return message;
+}
+
 void
 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
 {
@@ -1083,7 +1145,6 @@ Perl_vdie(pTHX_ const char* pat, va_list *args)
 {
     char *message;
     int was_in_eval = PL_in_eval;
-    SV *msv;
     STRLEN msglen;
     I32 utf8 = 0;
 
@@ -1091,28 +1152,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args)
                          "%p: die: curstack = %p, mainstack = %p\n",
                          thr, PL_curstack, PL_mainstack));
 
-    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);
-       utf8 = SvUTF8(msv);
-    }
-    else {
-       message = Nullch;
-       msglen = 0;
-    }
-
-    DEBUG_S(PerlIO_printf(Perl_debug_log,
-                         "%p: die: message = %s\ndiehook = %p\n",
-                         thr, message, PL_diehook));
-    if (PL_diehook) {
-       S_vdie_common(aTHX_ message, msglen, utf8);
-    }
+    message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
 
     PL_restartop = die_where(message, msglen);
     SvFLAGS(ERRSV) |= utf8;
@@ -1153,65 +1193,11 @@ void
 Perl_vcroak(pTHX_ const char* pat, va_list *args)
 {
     char *message;
-    HV *stash;
-    GV *gv;
-    CV *cv;
-    SV *msv;
     STRLEN msglen;
     I32 utf8 = 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);
-       utf8 = SvUTF8(msv);
-    }
-    else {
-       message = Nullch;
-       msglen = 0;
-    }
-
-    DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
-                         PTR2UV(thr), message));
-
-    if (PL_diehook) {
-       /* sv_2cv might call Perl_croak() */
-       SV *olddiehook = PL_diehook;
-       ENTER;
-       SAVESPTR(PL_diehook);
-       PL_diehook = Nullsv;
-       cv = sv_2cv(olddiehook, &stash, &gv, 0);
-       LEAVE;
-       if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
-           dSP;
-           SV *msg;
-
-           ENTER;
-           save_re_context();
-           if (message) {
-               msg = newSVpvn(message, msglen);
-               SvFLAGS(msg) |= utf8;
-               SvREADONLY_on(msg);
-               SAVEFREESV(msg);
-           }
-           else {
-               msg = ERRSV;
-           }
+    message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
 
-           PUSHSTACKi(PERLSI_DIEHOOK);
-           PUSHMARK(SP);
-           XPUSHs(msg);
-           PUTBACK;
-           call_sv((SV*)cv, G_DISCARD);
-           POPSTACK;
-           LEAVE;
-       }
-    }
     if (PL_in_eval) {
        PL_restartop = die_where(message, msglen);
        SvFLAGS(ERRSV) |= utf8;
@@ -1414,6 +1400,7 @@ Perl_my_setenv(pTHX_ char *nam, char *val)
 #endif
   {
 #ifndef PERL_USE_SAFE_PUTENV
+    if (!PL_use_safe_putenv) {
     /* most putenv()s leak, so we manipulate environ directly */
     register I32 i=setenv_getix(nam);          /* where does it go? */
     int nlen, vlen;
@@ -1454,8 +1441,8 @@ Perl_my_setenv(pTHX_ char *nam, char *val)
     environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
     /* all that work just for this */
     my_setenv_format(environ[i], nam, nlen, val, vlen);
-
-#else   /* PERL_USE_SAFE_PUTENV */
+    } else {
+# endif
 #   if defined(__CYGWIN__) || defined( EPOC)
     setenv(nam, val, 1);
 #   else
@@ -1470,7 +1457,9 @@ Perl_my_setenv(pTHX_ char *nam, char *val)
     my_setenv_format(new_env, nam, nlen, val, vlen);
     (void)putenv(new_env);
 #   endif /* __CYGWIN__ */
-#endif  /* PERL_USE_SAFE_PUTENV */
+#ifndef PERL_USE_SAFE_PUTENV
+    }
+#endif
   }
 }
 
@@ -2084,7 +2073,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
     register I32 This, that;
     register Pid_t pid;
     SV *sv;
-    I32 doexec = strNE(cmd,"-");
+    I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
     I32 did_pipes = 0;
     int pp[2];
 
@@ -2578,7 +2567,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
     {
        SV *sv;
        SV** svp;
-       char spid[TYPE_CHARS(int)];
+       char spid[TYPE_CHARS(IV)];
 
        if (pid > 0) {
            sprintf(spid, "%"IVdf, (IV)pid);
@@ -2594,9 +2583,6 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 
            hv_iterinit(PL_pidstatus);
            if ((entry = hv_iternext(PL_pidstatus))) {
-               SV *sv;
-               char spid[TYPE_CHARS(int)];
-
                pid = atoi(hv_iterkey(entry,(I32*)statusp));
                sv = hv_iterval(PL_pidstatus,entry);
                *statusp = SvIVX(sv);
@@ -2645,7 +2631,7 @@ void
 Perl_pidgone(pTHX_ Pid_t pid, int status)
 {
     register SV *sv;
-    char spid[TYPE_CHARS(int)];
+    char spid[TYPE_CHARS(IV)];
 
     sprintf(spid, "%"IVdf, (IV)pid);
     sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
@@ -4018,8 +4004,7 @@ Perl_upg_version(pTHX_ SV *ver)
 #endif
     else /* must be a string or something like a string */
     {
-       STRLEN n_a;
-       version = savepv(SvPV(ver,n_a));
+       version = savesvpv(ver);
     }
     (void)scan_version(version, ver, qv);
     Safefree(version);