sysread should not ignore magic on its buffer

[perl5.git] / sv.c

diff --git a/sv.c b/sv.c
index 7ddb222..31bda3b 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3808,39 +3808,26 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
            CV* const cv = MUTABLE_CV(*location);
            if (cv) {
                if (!GvCVGEN((const GV *)dstr) &&
-                   (CvROOT(cv) || CvXSUB(cv)))
+                   (CvROOT(cv) || CvXSUB(cv)) &&
+                   /* redundant check that avoids creating the extra SV
+                      most of the time: */
+                   (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
                    {
-                       /* Redefining a sub - warning is mandatory if
-                          it was a const and its value changed. */
-                       if (CvCONST(cv) && CvCONST((const CV *)sref)
-                           && cv_const_sv(cv)
-                           == cv_const_sv((const CV *)sref)) {
-                           NOOP;
-                           /* They are 2 constant subroutines generated from
-                              the same constant. This probably means that
-                              they are really the "same" proxy subroutine
-                              instantiated in 2 places. Most likely this is
-                              when a constant is exported twice.  Don't warn.
-                           */
-                       }
-                       else if (ckWARN(WARN_REDEFINE)
-                                || (CvCONST(cv)
-                                    && (!CvCONST((const CV *)sref)
-                                        || sv_cmp(cv_const_sv(cv),
-                                                  cv_const_sv((const CV *)
-                                                              sref))))) {
-                           Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
-                                       (const char *)
-                                       (CvCONST(cv)
-                                        ? "Constant subroutine %"HEKf
-                                          "::%"HEKf" redefined"
-                                        : "Subroutine %"HEKf"::%"HEKf
-                                          " redefined"),
+                       SV * const new_const_sv =
+                           CvCONST((const CV *)sref)
+                                ? cv_const_sv((const CV *)sref)
+                                : NULL;
+                       report_redefined_cv(
+                          sv_2mortal(Perl_newSVpvf(aTHX_
+                               "%"HEKf"::%"HEKf,
                                HEKfARG(
                                 HvNAME_HEK(GvSTASH((const GV *)dstr))
                                ),
-                               HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))));
-                       }
+                               HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
+                          )),
+                          cv,
+                          CvCONST((const CV *)sref) ? &new_const_sv : NULL
+                       );
                    }
                if (!intro)
                    cv_ckproto_len_flags(cv, (const GV *)dstr,
@@ -5724,7 +5711,8 @@ the Perl substr() function.  Handles get magic.
 
 =for apidoc sv_insert_flags
 
-Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
+Same as C<sv_insert>, but the extra C<flags> are passed to the
+C<SvPV_force_flags> that applies to C<bigstr>.
 
 =cut
 */
@@ -6295,11 +6283,19 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
                /* A constant subroutine can have no side effects, so
                   don't bother calling it.  */
                && !CvCONST(destructor)
-               /* Don't bother calling an empty destructor */
+               /* Don't bother calling an empty destructor or one that
+                  returns immediately. */
                && (CvISXSUB(destructor)
                || (CvSTART(destructor)
                    && (CvSTART(destructor)->op_next->op_type
-                                       != OP_LEAVESUB))))
+                                       != OP_LEAVESUB)
+                   && (CvSTART(destructor)->op_next->op_type
+                                       != OP_PUSHMARK
+                       || CvSTART(destructor)->op_next->op_next->op_type
+                                       != OP_RETURN
+                      )
+                  ))
+              )
            {
                SV* const tmpref = newRV(sv);
                SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
@@ -8906,8 +8902,6 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
        if (SvROK(sv)) {
            if (SvAMAGIC(sv))
                sv = amagic_deref_call(sv, to_cv_amg);
-           /* At this point I'd like to do SPAGAIN, but really I need to
-              force it upon my callers. Hmmm. This is a mess... */
 
            sv = SvRV(sv);
            if (SvTYPE(sv) == SVt_PVCV) {
@@ -8999,7 +8993,7 @@ Perl_sv_true(pTHX_ register SV *const sv)
 
 Get a sensible string out of the SV somehow.
 A private implementation of the C<SvPV_force> macro for compilers which
-can't cope with complex macro expressions. Always use the macro instead.
+can't cope with complex macro expressions.  Always use the macro instead.
 
 =for apidoc sv_pvn_force_flags
 
@@ -9020,6 +9014,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
 
     PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
 
+    if (flags & SV_GMAGIC) SvGETMAGIC(sv);
     if (SvTHINKFIRST(sv) && !SvROK(sv))
         sv_force_normal_flags(sv, 0);
 
@@ -9044,7 +9039,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
            /* diag_listed_as: Can't coerce %s to %s in %s */
            Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
                OP_DESC(PL_op));
-       s = sv_2pv_flags(sv, &len, flags);
+       s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC);
        if (lp)
            *lp = len;
 
@@ -10349,7 +10344,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
                 * back into v-string notation and then let the
                 * vectorize happen normally
                 */
-               if (sv_derived_from(vecsv, "version")) {
+               if (sv_derived_from(vecsv, "version") && SvROK(vecsv)) {
                    char *version = savesvpv(vecsv);
                    if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
                        Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
@@ -13908,9 +13903,11 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
                    break;
                sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
            }
-           else /* @{expr}, %{expr} */
+           else if (obase == PL_op) /* @{expr}, %{expr} */
                return find_uninit_var(cUNOPx(obase)->op_first,
                                                    uninit_sv, match);
+           else /* @{expr}, %{expr} as a sub-expression */
+               return NULL;
        }
 
        /* attempt to find a match within the aggregate */
@@ -14270,12 +14267,6 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
                if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
                  || (type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
                  || (type == OP_PUSHMARK)
-                 || (
-                     /* @$a and %$a, but not @a or %a */
-                       (type == OP_RV2AV || type == OP_RV2HV)
-                    && cUNOPx(kid)->op_first
-                    && cUNOPx(kid)->op_first->op_type != OP_GV
-                    )
                )
                continue;
            }