Re: [perl #24554] Segfault in POSIX module

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

diff --git a/mg.c b/mg.c
index 712a339..92aa03f 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -48,6 +48,14 @@ Signal_t Perl_csighandler(int sig);
 static void restore_magic(pTHX_ void *p);
 static void unwind_handler_stack(pTHX_ void *p);
 
+#ifdef __Lynx__
+/* Missing protos on LynxOS */
+void setruid(uid_t id);
+void seteuid(uid_t id);
+void setrgid(uid_t id);
+void setegid(uid_t id);
+#endif
+
 /*
  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
  */
@@ -139,6 +147,10 @@ Perl_mg_get(pTHX_ SV *sv)
            if (SvTYPE(sv) == SVTYPEMASK) {
                Perl_croak(aTHX_ "Tied variable freed while still in use");
            }
+           /* guard against magic having been deleted - eg FETCH calling
+            * untie */
+           if (!SvMAGIC(sv))
+               break;
 
            /* Don't restore the flags for this entry if it was deleted. */
            if (mg->mg_flags & MGf_GSKIP)
@@ -543,7 +555,7 @@ int
 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 {
     register I32 paren;
-    register char *s;
+    register char *s = NULL;
     register I32 i;
     register REGEXP *rx;
 
@@ -611,8 +623,12 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
                  SetLastError(dwErr);
             }
 #else
-            sv_setnv(sv, (NV)errno);
-            sv_setpv(sv, errno ? Strerror(errno) : "");
+            {
+                int saveerrno = errno;
+                sv_setnv(sv, (NV)errno);
+                sv_setpv(sv, errno ? Strerror(errno) : "");
+                errno = saveerrno;
+            }
 #endif
 #endif
 #endif
@@ -801,7 +817,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
        }
        break;
     case '^':
-       s = IoTOP_NAME(GvIOp(PL_defoutgv));
+       if (GvIOp(PL_defoutgv))
+           s = IoTOP_NAME(GvIOp(PL_defoutgv));
        if (s)
            sv_setpv(sv,s);
        else {
@@ -810,20 +827,24 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
        }
        break;
     case '~':
-       s = IoFMT_NAME(GvIOp(PL_defoutgv));
+       if (GvIOp(PL_defoutgv))
+           s = IoFMT_NAME(GvIOp(PL_defoutgv));
        if (!s)
            s = GvENAME(PL_defoutgv);
        sv_setpv(sv,s);
        break;
 #ifndef lint
     case '=':
-       sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
+       if (GvIOp(PL_defoutgv))
+           sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
        break;
     case '-':
-       sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
+       if (GvIOp(PL_defoutgv))
+           sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
        break;
     case '%':
-       sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
+       if (GvIOp(PL_defoutgv))
+           sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
        break;
 #endif
     case ':':
@@ -834,7 +855,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
        WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
        break;
     case '|':
-       sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
+       if (GvIOp(PL_defoutgv))
+           sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
        break;
     case ',':
        break;
@@ -1459,9 +1481,9 @@ S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
 int
 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
 {
-    magic_methpack(sv,mg,"FETCH");
     if (mg->mg_ptr)
        mg->mg_flags |= MGf_GSKIP;
+    magic_methpack(sv,mg,"FETCH");
     return 0;
 }
 
@@ -2222,9 +2244,14 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 #ifdef HAS_SETRESUID
       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
 #else
-       if (PL_uid == PL_euid)          /* special case $< = $> */
+       if (PL_uid == PL_euid) {                /* special case $< = $> */
+#ifdef PERL_DARWIN
+           /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
+           if (PL_uid != 0 && PerlProc_getuid() == 0)
+               (void)PerlProc_setuid(0);
+#endif
            (void)PerlProc_setuid(PL_uid);
-       else {
+       } else {
            PL_uid = PerlProc_getuid();
            Perl_croak(aTHX_ "setruid() not implemented");
        }
@@ -2377,10 +2404,11 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 #endif
        /* PL_origalen is set in perl_parse(). */
        s = SvPV_force(sv,len);
-       if (len >= (STRLEN)PL_origalen) {
-           /* Longer than original, will be truncated. */
-           Copy(s, PL_origargv[0], PL_origalen, char);
-           PL_origargv[0][PL_origalen - 1] = 0;
+       if (len >= (STRLEN)PL_origalen-1) {
+           /* Longer than original, will be truncated. We assume that
+             * PL_origalen bytes are available. */
+           Copy(s, PL_origargv[0], PL_origalen-1, char);
+           PL_origargv[0][PL_origalen-1] = 0;
        }
        else {
            /* Shorter than original, will be padded. */
@@ -2540,7 +2568,7 @@ cleanup:
 
     PL_Sv = tSv;                       /* Restore global temporaries. */
     PL_Xpv = tXpv;
-    return 0;
+    return;
 }
 
 
@@ -2555,6 +2583,13 @@ restore_magic(pTHX_ void *p)
 
     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
     {
+#ifdef PERL_COPY_ON_WRITE
+       /* While magic was saved (and off) sv_setsv may well have seen
+          this SV as a prime candidate for COW.  */
+       if (SvIsCOW(sv))
+           sv_force_normal(sv);
+#endif
+
        if (mgs->mgs_flags)
            SvFLAGS(sv) |= mgs->mgs_flags;
        else