perldelta for Storable saving a code reference as UTF-8

[perl5.git] / pp_sys.c

diff --git a/pp_sys.c b/pp_sys.c
index 1f1f59c..d27bde6 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -505,7 +505,7 @@ PP(pp_open)
 
     GV * const gv = MUTABLE_GV(*++MARK);
 
-    if (!isGV(gv))
+    if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
        DIE(aTHX_ PL_no_usym, "filehandle");
 
     if ((io = GvIOp(gv))) {
@@ -825,7 +825,12 @@ PP(pp_tie)
            methname = "TIEARRAY";
            break;
        case SVt_PVGV:
+       case SVt_PVLV:
            if (isGV_with_GP(varsv)) {
+               if (SvFAKE(varsv) && !(GvFLAGS(varsv) & GVf_TIEWARNED)) {
+                   deprecate("tie on a handle without *");
+                   GvFLAGS(varsv) |= GVf_TIEWARNED;
+               }
                methname = "TIEHANDLE";
                how = PERL_MAGIC_tiedscalar;
                /* For tied filehandles, we apply tiedscalar magic to the IO
@@ -902,8 +907,14 @@ PP(pp_untie)
     const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
                ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
 
-    if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
+    if (isGV_with_GP(sv)) {
+      if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
+       deprecate("untie on a handle without *");
+       GvFLAGS(sv) |= GVf_TIEWARNED;
+      }
+      if (!(sv = MUTABLE_SV(GvIOp(sv))))
        RETPUSHYES;
+    }
 
     if ((mg = SvTIED_mg(sv, how))) {
        SV * const obj = SvRV(SvTIED_obj(sv, mg));
@@ -940,8 +951,14 @@ PP(pp_tied)
     const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
                ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
 
-    if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
+    if (isGV_with_GP(sv)) {
+      if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
+       deprecate("tied on a handle without *");
+       GvFLAGS(sv) |= GVf_TIEWARNED;
+      }
+      if (!(sv = MUTABLE_SV(GvIOp(sv))))
        RETPUSHUNDEF;
+    }
 
     if ((mg = SvTIED_mg(sv, how))) {
        SV *osv = SvTIED_obj(sv, mg);
@@ -1043,7 +1060,7 @@ PP(pp_sselect)
            if (SvIsCOW(sv))
                sv_force_normal_flags(sv, 0);
            if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
-               DIE(aTHX_ "%s", PL_no_modify);
+               Perl_croak_no_modify(aTHX);
        }
        if (!SvPOK(sv)) {
            Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
@@ -1275,6 +1292,9 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
 
     PERL_ARGS_ASSERT_DOFORM;
 
+    if (cv && CvCLONE(cv))
+       cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
+
     ENTER;
     SAVETMPS;
 
@@ -1330,9 +1350,6 @@ PP(pp_enterwrite)
        not_a_format_reference:
        DIE(aTHX_ "Not a format reference");
     }
-    if (CvCLONE(cv))
-       cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
-
     IoFLAGS(io) &= ~IOf_DIDTOP;
     return doform(cv,gv,PL_op->op_next);
 }
@@ -1347,6 +1364,7 @@ PP(pp_leavewrite)
     SV **newsp;
     I32 gimme;
     register PERL_CONTEXT *cx;
+    OP *retop;
 
     if (!io || !(ofp = IoOFP(io)))
         goto forget_top;
@@ -1421,14 +1439,13 @@ PP(pp_leavewrite)
            else
                DIE(aTHX_ "Undefined top format called");
        }
-       if (cv && CvCLONE(cv))
-           cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
        return doform(cv, gv, PL_op);
     }
 
   forget_top:
     POPBLOCK(cx,PL_curpm);
     POPFORMAT(cx);
+    retop = cx->blk_sub.retop;
     LEAVE;
 
     fp = IoOFP(io);
@@ -1461,7 +1478,7 @@ PP(pp_leavewrite)
     PUTBACK;
     PERL_UNUSED_VAR(newsp);
     PERL_UNUSED_VAR(gimme);
-    return cx->blk_sub.retop;
+    return retop;
 }
 
 PP(pp_prtf)
@@ -1654,6 +1671,9 @@ PP(pp_sysread)
                                  (struct sockaddr *)namebuf, &bufsize);
        if (count < 0)
            RETPUSHUNDEF;
+       /* MSG_TRUNC can give oversized count; quietly lose it */
+       if (count > length)
+           count = length;
 #ifdef EPOC
         /* Bogus return without padding */
        bufsize = sizeof (struct sockaddr_in);
@@ -3133,7 +3153,7 @@ PP(pp_ftrread)
 #endif
     }
 
-    result = my_stat();
+    result = my_stat_flags(0);
     SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
@@ -3161,7 +3181,7 @@ PP(pp_ftis)
 
     STACKED_FTEST_CHECK;
 
-    result = my_stat();
+    result = my_stat_flags(0);
     SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
@@ -3216,24 +3236,33 @@ PP(pp_ftrowned)
     }
     tryAMAGICftest_MG(opchar);
 
+    STACKED_FTEST_CHECK;
+
     /* I believe that all these three are likely to be defined on most every
        system these days.  */
 #ifndef S_ISUID
-    if(PL_op->op_type == OP_FTSUID)
+    if(PL_op->op_type == OP_FTSUID) {
+       if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
+           (void) POPs;
        RETPUSHNO;
+    }
 #endif
 #ifndef S_ISGID
-    if(PL_op->op_type == OP_FTSGID)
+    if(PL_op->op_type == OP_FTSGID) {
+       if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
+           (void) POPs;
        RETPUSHNO;
+    }
 #endif
 #ifndef S_ISVTX
-    if(PL_op->op_type == OP_FTSVTX)
+    if(PL_op->op_type == OP_FTSVTX) {
+       if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
+           (void) POPs;
        RETPUSHNO;
+    }
 #endif
 
-    STACKED_FTEST_CHECK;
-
-    result = my_stat();
+    result = my_stat_flags(0);
     SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
@@ -3303,7 +3332,7 @@ PP(pp_ftlink)
     I32 result;
 
     tryAMAGICftest_MG('l');
-    result = my_lstat();
+    result = my_lstat_flags(0);
     SPAGAIN;
 
     if (result < 0)
@@ -3320,6 +3349,8 @@ PP(pp_fttty)
     int fd;
     GV *gv;
     SV *tmpsv = NULL;
+    char *name = NULL;
+    STRLEN namelen;
 
     tryAMAGICftest_MG('t');
 
@@ -3327,19 +3358,21 @@ PP(pp_fttty)
 
     if (PL_op->op_flags & OPf_REF)
        gv = cGVOP_gv;
-    else if (isGV(TOPs))
+    else if (isGV_with_GP(TOPs))
        gv = MUTABLE_GV(POPs);
     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
        gv = MUTABLE_GV(SvRV(POPs));
-    else
-       gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
+    else {
+       tmpsv = POPs;
+       name = SvPV_nomg(tmpsv, namelen);
+       gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
+    }
 
     if (GvIO(gv) && IoIFP(GvIOp(gv)))
        fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
     else if (tmpsv && SvOK(tmpsv)) {
-       const char *tmps = SvPV_nolen_const(tmpsv);
-       if (isDIGIT(*tmps))
-           fd = atoi(tmps);
+       if (isDIGIT(*name))
+           fd = atoi(name);
        else 
            RETPUSHUNDEF;
     }
@@ -3378,7 +3411,7 @@ PP(pp_fttext)
 
     if (PL_op->op_flags & OPf_REF)
        gv = cGVOP_gv;
-    else if (isGV(TOPs))
+    else if (isGV_with_GP(TOPs))
        gv = MUTABLE_GV(POPs);
     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
        gv = MUTABLE_GV(SvRV(POPs));
@@ -3440,7 +3473,7 @@ PP(pp_fttext)
       really_filename:
        PL_statgv = NULL;
        PL_laststype = OP_STAT;
-       sv_setpv(PL_statname, SvPV_nolen_const(sv));
+       sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
        if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
            if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
                                               '\n'))
@@ -4440,13 +4473,19 @@ PP(pp_setpgrp)
 #endif
 }
 
+#ifdef __GLIBC__
+#  define PRIORITY_WHICH_T(which) (__priority_which_t)which
+#else
+#  define PRIORITY_WHICH_T(which) which
+#endif
+
 PP(pp_getpriority)
 {
 #ifdef HAS_GETPRIORITY
     dVAR; dSP; dTARGET;
     const int who = POPi;
     const int which = TOPi;
-    SETi( getpriority(which, who) );
+    SETi( getpriority(PRIORITY_WHICH_T(which), who) );
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "getpriority()");
@@ -4461,13 +4500,15 @@ PP(pp_setpriority)
     const int who = POPi;
     const int which = TOPi;
     TAINT_PROPER("setpriority");
-    SETi( setpriority(which, who, niceval) >= 0 );
+    SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "setpriority()");
 #endif
 }
 
+#undef PRIORITY_WHICH_T
+
 /* Time calls. */
 
 PP(pp_time)
@@ -5497,7 +5538,8 @@ PP(pp_getlogin)
     EXTEND(SP, 1);
     if (!(tmps = PerlProc_getlogin()))
        RETPUSHUNDEF;
-    PUSHp(tmps, strlen(tmps));
+    sv_setpv_mg(TARG, tmps);
+    PUSHs(TARG);
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "getlogin");