X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/226b920186705fc2c28a5bfa7f1b68ab3b56ddb4..efc859fb2266cae5156ec3e6efab319e797708a8:/pp_sys.c

diff --git a/pp_sys.c b/pp_sys.c
index 660d1d7..fb93732 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -363,7 +363,7 @@ PP(pp_glob)
      * is called once and only once */
     if (SvGMAGICAL(TOPm1s)) TOPm1s = sv_2mortal(newSVsv(TOPm1s));
 
-    tryAMAGICunTARGET(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL));
+    tryAMAGICunTARGETlist(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL));
 
     if (PL_op->op_flags & OPf_SPECIAL) {
 	/* call Perl-level glob function instead. Stack args are:
@@ -438,20 +438,29 @@ PP(pp_warn)
     }
     else {
 	exsv = TOPs;
+	if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
     }
 
     if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
 	/* well-formed exception supplied */
     }
-    else if (SvROK(ERRSV)) {
-	exsv = ERRSV;
-    }
-    else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
-	exsv = sv_mortalcopy(ERRSV);
-	sv_catpvs(exsv, "\t...caught");
-    }
     else {
+      SvGETMAGIC(ERRSV);
+      if (SvROK(ERRSV)) {
+	if (SvGMAGICAL(ERRSV)) {
+	    exsv = sv_newmortal();
+	    sv_setsv_nomg(exsv, ERRSV);
+	}
+	else exsv = ERRSV;
+      }
+      else if (SvPOKp(ERRSV) ? SvCUR(ERRSV) : SvNIOKp(ERRSV)) {
+	exsv = sv_newmortal();
+	sv_setsv_nomg(exsv, ERRSV);
+	sv_catpvs(exsv, "\t...caught");
+      }
+      else {
 	exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
+      }
     }
     if (SvROK(exsv) && !PL_warnhook)
 	 Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
@@ -1227,7 +1236,8 @@ void
 Perl_setdefout(pTHX_ GV *gv)
 {
     dVAR;
-    SvREFCNT_inc_simple_void(gv);
+    PERL_ARGS_ASSERT_SETDEFOUT;
+    SvREFCNT_inc_simple_void_NN(gv);
     SvREFCNT_dec(PL_defoutgv);
     PL_defoutgv = gv;
 }
@@ -1360,21 +1370,16 @@ PP(pp_enterwrite)
     else
 	fgv = gv;
 
-    if (!fgv)
-	goto not_a_format_reference;
+    assert(fgv);
 
     cv = GvFORM(fgv);
     if (!cv) {
 	tmpsv = sv_newmortal();
 	gv_efullname4(tmpsv, fgv, NULL, FALSE);
-	if (SvPOK(tmpsv) && *SvPV_nolen_const(tmpsv))
-	    DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
-
-	not_a_format_reference:
-	DIE(aTHX_ "Not a format reference");
+	DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
     }
     IoFLAGS(io) &= ~IOf_DIDTOP;
-    return doform(cv,gv,PL_op->op_next);
+    RETURNOP(doform(cv,gv,PL_op->op_next));
 }
 
 PP(pp_leavewrite)
@@ -1389,6 +1394,12 @@ PP(pp_leavewrite)
     register PERL_CONTEXT *cx;
     OP *retop;
 
+    /* I'm not sure why, but executing the format leaves an extra value on the
+     * stack. There's probably a better place to be handling this (probably
+     * by avoiding pushing it in the first place!) but I don't quite know
+     * where to look. -doy */
+    (void)POPs;
+
     if (!io || !(ofp = IoOFP(io)))
         goto forget_top;
 
@@ -1456,12 +1467,9 @@ PP(pp_leavewrite)
 	if (!cv) {
 	    SV * const sv = sv_newmortal();
 	    gv_efullname4(sv, fgv, NULL, FALSE);
-	    if (SvPOK(sv) && *SvPV_nolen_const(sv))
-		DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
-	    else
-		DIE(aTHX_ "Undefined top format called");
+	    DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
 	}
-	return doform(cv, gv, PL_op);
+	RETURNOP(doform(cv, gv, PL_op));
     }
 
   forget_top:
@@ -1495,10 +1503,9 @@ PP(pp_leavewrite)
     }
     /* bad_ofp: */
     PL_formtarget = PL_bodytarget;
-    PUTBACK;
     PERL_UNUSED_VAR(newsp);
     PERL_UNUSED_VAR(gimme);
-    return retop;
+    RETURNOP(retop);
 }
 
 PP(pp_prtf)
@@ -2924,10 +2931,10 @@ S_ft_stacking_return_false(pTHX_ SV *ret) {
 #define FT_RETURN_TRUE(X)		 \
     RETURNX((void)(			  \
 	PL_op->op_flags & OPf_REF	   \
-	    ? XPUSHs(			    \
+	    ? (bool)XPUSHs(		    \
 		PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (X) \
 	      )								  \
-	    : (void)(PL_op->op_private & OPpFT_STACKING || SETs(X))	  \
+	    : (PL_op->op_private & OPpFT_STACKING || SETs(X))		  \
     ))
 
 #define FT_RETURNNO	FT_RETURN_FALSE(&PL_sv_no)
@@ -2961,8 +2968,6 @@ S_try_amagic_ftest(pTHX_ char chr) {
 	if (!tmpsv)
 	    return NULL;
 
-	SPAGAIN;
-
 	if (SvTRUE(tmpsv)) FT_RETURN_TRUE(tmpsv);
 	FT_RETURN_FALSE(tmpsv);
     }
@@ -3082,7 +3087,6 @@ PP(pp_ftrread)
     }
 
     result = my_stat_flags(0);
-    SPAGAIN;
     if (result < 0)
 	FT_RETURNUNDEF;
     if (cando(stat_mode, effective, &PL_statcache))
@@ -3108,7 +3112,6 @@ PP(pp_ftis)
     tryAMAGICftest_MG(opchar);
 
     result = my_stat_flags(0);
-    SPAGAIN;
     if (result < 0)
 	FT_RETURNUNDEF;
     if (op_type == OP_FTIS)
@@ -3186,7 +3189,6 @@ PP(pp_ftrowned)
 #endif
 
     result = my_stat_flags(0);
-    SPAGAIN;
     if (result < 0)
 	FT_RETURNUNDEF;
     switch (PL_op->op_type) {
@@ -3256,7 +3258,6 @@ PP(pp_ftlink)
 
     tryAMAGICftest_MG('l');
     result = my_lstat_flags(0);
-    SPAGAIN;
 
     if (result < 0)
 	FT_RETURNUNDEF;
@@ -4027,10 +4028,31 @@ PP(pp_fork)
 #ifdef HAS_FORK
     dVAR; dSP; dTARGET;
     Pid_t childpid;
+#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+    sigset_t oldmask, newmask;
+#endif
 
     EXTEND(SP, 1);
     PERL_FLUSHALL_FOR_CHILD;
+#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+    sigfillset(&newmask);
+    sigprocmask(SIG_SETMASK, &newmask, &oldmask);
+#endif
     childpid = PerlProc_fork();
+    if (childpid == 0) {
+	int sig;
+	PL_sig_pending = 0;
+	if (PL_psig_pend)
+	    for (sig = 1; sig < SIG_SIZE; sig++)
+		PL_psig_pend[sig] = 0;
+    }
+#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+    {
+	dSAVE_ERRNO;
+	sigprocmask(SIG_SETMASK, &oldmask, NULL);
+	RESTORE_ERRNO;
+    }
+#endif
     if (childpid < 0)
 	RETSETUNDEF;
     if (!childpid) {
@@ -5648,8 +5670,8 @@ lockf_emulate_flock(int fd, int operation)
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
  * End:
  *
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
  */