X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=98b9b44d15315bf5667d236013be0d9169a89dbc;hb=de11ba31bba9f0eef0f76239d1d93a010926d6cf;hp=f2387b4ce0a57f885f23d8d10aaa17ccbd075e36;hpb=c39e6ab0a7545b7ae425e21f045aa689291b268e;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_hot.c b/pp_hot.c
index f2387b4..98b9b44 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -320,6 +320,42 @@ PP(pp_or)
     }
 }
 
+PP(pp_dor)
+{
+    /* Most of this is lifted straight from pp_defined */
+    dSP;
+    register SV* sv;
+
+    sv = TOPs;
+    if (!sv || !SvANY(sv)) {
+	--SP;
+	RETURNOP(cLOGOP->op_other);
+    }
+    
+    switch (SvTYPE(sv)) {
+    case SVt_PVAV:
+	if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
+	    RETURN;
+	break;
+    case SVt_PVHV:
+	if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
+	    RETURN;
+	break;
+    case SVt_PVCV:
+	if (CvROOT(sv) || CvXSUB(sv))
+	    RETURN;
+	break;
+    default:
+	if (SvGMAGICAL(sv))
+	    mg_get(sv);
+	if (SvOK(sv))
+	    RETURN;
+    }
+    
+    --SP;
+    RETURNOP(cLOGOP->op_other);
+}
+
 PP(pp_add)
 {
     dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
@@ -571,7 +607,7 @@ PP(pp_print)
             goto had_magic;
 	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 	    report_evil_fh(gv, io, PL_op->op_type);
-	SETERRNO(EBADF,RMS$_IFI);
+	SETERRNO(EBADF,RMS_IFI);
 	goto just_say_no;
     }
     else if (!(fp = IoOFP(io))) {
@@ -581,7 +617,7 @@ PP(pp_print)
 	    else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 		report_evil_fh(gv, io, PL_op->op_type);
 	}
-	SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
+	SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
 	goto just_say_no;
     }
     else {
@@ -762,7 +798,7 @@ PP(pp_rv2hv)
 	tryAMAGICunDEREF(to_hv);
 
 	hv = (HV*)SvRV(sv);
-	if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
+	if (SvTYPE(hv) != SVt_PVHV)
 	    DIE(aTHX_ "Not a HASH reference");
 	if (PL_op->op_flags & OPf_REF) {
 	    SETs((SV*)hv);
@@ -776,7 +812,7 @@ PP(pp_rv2hv)
 	}
     }
     else {
-	if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
+	if (SvTYPE(sv) == SVt_PVHV) {
 	    hv = (HV*)sv;
 	    if (PL_op->op_flags & OPf_REF) {
 		SETs((SV*)hv);
@@ -858,8 +894,6 @@ PP(pp_rv2hv)
     }
     else {
 	dTARGET;
-	if (SvTYPE(hv) == SVt_PVAV)
-	    hv = avhv_keys((AV*)hv);
 	if (HvFILL(hv))
             Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
 			   (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
@@ -871,57 +905,14 @@ PP(pp_rv2hv)
     }
 }
 
-STATIC int
-S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
-		 SV **lastrelem)
-{
-    OP *leftop;
-    I32 i;
-
-    leftop = ((BINOP*)PL_op)->op_last;
-    assert(leftop);
-    assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
-    leftop = ((LISTOP*)leftop)->op_first;
-    assert(leftop);
-    /* Skip PUSHMARK and each element already assigned to. */
-    for (i = lelem - firstlelem; i > 0; i--) {
-	leftop = leftop->op_sibling;
-	assert(leftop);
-    }
-    if (leftop->op_type != OP_RV2HV)
-	return 0;
-
-    /* pseudohash */
-    if (av_len(ary) > 0)
-	av_fill(ary, 0);		/* clear all but the fields hash */
-    if (lastrelem >= relem) {
-	while (relem < lastrelem) {	/* gobble up all the rest */
-	    SV *tmpstr;
-	    assert(relem[0]);
-	    assert(relem[1]);
-	    /* Avoid a memory leak when avhv_store_ent dies. */
-	    tmpstr = sv_newmortal();
-	    sv_setsv(tmpstr,relem[1]);	/* value */
-	    relem[1] = tmpstr;
-	    if (avhv_store_ent(ary,relem[0],tmpstr,0))
-		(void)SvREFCNT_inc(tmpstr);
-	    if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
-		mg_set(tmpstr);
-	    relem += 2;
-	    TAINT_NOT;
-	}
-    }
-    if (relem == lastrelem)
-	return 1;
-    return 2;
-}
-
 STATIC void
 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
 {
     if (*relem) {
 	SV *tmpstr;
-	if (ckWARN(WARN_MISC)) {
+        HE *didstore;
+
+        if (ckWARN(WARN_MISC)) {
 	    if (relem == firstrelem &&
 		SvROK(*relem) &&
 		(SvTYPE(SvRV(*relem)) == SVt_PVAV ||
@@ -934,26 +925,16 @@ S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
 		Perl_warner(aTHX_ packWARN(WARN_MISC),
 			    "Odd number of elements in hash assignment");
 	}
-	if (SvTYPE(hash) == SVt_PVAV) {
-	    /* pseudohash */
-	    tmpstr = sv_newmortal();
-	    if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
-		(void)SvREFCNT_inc(tmpstr);
-	    if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
-		mg_set(tmpstr);
-	}
-	else {
-	    HE *didstore;
-	    tmpstr = NEWSV(29,0);
-	    didstore = hv_store_ent(hash,*relem,tmpstr,0);
-	    if (SvMAGICAL(hash)) {
-		if (SvSMAGICAL(tmpstr))
-		    mg_set(tmpstr);
-		if (!didstore)
-		    sv_2mortal(tmpstr);
-	    }
-	}
-	TAINT_NOT;
+
+        tmpstr = NEWSV(29,0);
+        didstore = hv_store_ent(hash,*relem,tmpstr,0);
+        if (SvMAGICAL(hash)) {
+            if (SvSMAGICAL(tmpstr))
+                mg_set(tmpstr);
+            if (!didstore)
+                sv_2mortal(tmpstr);
+        }
+        TAINT_NOT;
     }
 }
 
@@ -1005,19 +986,6 @@ PP(pp_aassign)
 	case SVt_PVAV:
 	    ary = (AV*)sv;
 	    magic = SvMAGICAL(ary) != 0;
-	    if (PL_op->op_private & OPpASSIGN_HASH) {
-		switch (do_maybe_phash(ary, lelem, firstlelem, relem,
-				       lastrelem))
-		{
-		case 0:
-		    goto normal_array;
-		case 1:
-		    do_oddball((HV*)ary, relem, firstrelem);
-		}
-		relem = lastrelem + 1;
-		break;
-	    }
-	normal_array:
 	    av_clear(ary);
 	    av_extend(ary, lastrelem - relem);
 	    i = 0;
@@ -1454,8 +1422,11 @@ Perl_do_readline(pTHX)
 	call_method("READLINE", gimme);
 	LEAVE;
 	SPAGAIN;
-	if (gimme == G_SCALAR)
-	    SvSetMagicSV_nosteal(TARG, TOPs);
+	if (gimme == G_SCALAR) {
+	    SV* result = POPs;
+	    SvSetSV_nosteal(TARG, result);
+	    PUSHTARG;
+	}
 	RETURN;
     }
     fp = Nullfp;
@@ -1513,10 +1484,14 @@ Perl_do_readline(pTHX)
 	tmplen = SvLEN(sv);	/* remember if already alloced */
 	if (!tmplen)
 	    Sv_Grow(sv, 80);	/* try short-buffering it */
-	if (type == OP_RCATLINE)
+	offset = 0;
+	if (type == OP_RCATLINE && SvOK(sv)) {
+	    if (!SvPOK(sv)) {
+		STRLEN n_a;
+		(void)SvPV_force(sv, n_a);
+	    }
 	    offset = SvCUR(sv);
-	else
-	    offset = 0;
+	}
     }
     else {
 	sv = sv_2mortal(NEWSV(57, 80));
@@ -1639,25 +1614,36 @@ PP(pp_helem)
     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
     SV *sv;
+#ifdef PERL_COPY_ON_WRITE
+    U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
+#else
     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
+#endif
     I32 preeminent = 0;
 
     if (SvTYPE(hv) == SVt_PVHV) {
-	if (PL_op->op_private & OPpLVAL_INTRO)
+	if (PL_op->op_private & OPpLVAL_INTRO) {
+	    MAGIC *mg;
+	    HV *stash;
+	    /* does the element we're localizing already exist? */
 	    preeminent =  
-		( SvRMAGICAL(hv)
-		  && !mg_find((SV*)hv, PERL_MAGIC_tied)
-		  && !mg_find((SV*)hv, PERL_MAGIC_env)
-		) ? 1 : hv_exists_ent(hv, keysv, 0);
+		/* can we determine whether it exists? */
+		(    !SvRMAGICAL(hv)
+		  || mg_find((SV*)hv, PERL_MAGIC_env)
+		  || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
+			/* Try to preserve the existenceness of a tied hash
+			 * element by using EXISTS and DELETE if possible.
+			 * Fallback to FETCH and STORE otherwise */
+			&& (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
+			&& gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
+			&& gv_fetchmethod_autoload(stash, "DELETE", TRUE)
+		    )
+		) ? hv_exists_ent(hv, keysv, 0) : 1;
 
+	}
 	he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
 	svp = he ? &HeVAL(he) : 0;
     }
-    else if (SvTYPE(hv) == SVt_PVAV) {
-	if (PL_op->op_private & OPpLVAL_INTRO)
-	    DIE(aTHX_ "Can't localize pseudo-hash element");
-	svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
-    }
     else {
 	RETPUSHUNDEF;
     }
@@ -1687,17 +1673,8 @@ PP(pp_helem)
 		    STRLEN keylen;
 		    char *key = SvPV(keysv, keylen);
 		    SAVEDELETE(hv, savepvn(key,keylen), keylen);
-		} else {
-		    SV *sv;
+		} else
 		    save_helem(hv, keysv, svp);
-		    sv = *svp;
-		    /* If we're localizing a tied hash element, this new
-		     * sv won't actually be stored in the hash - so it
-		     * won't get reaped when the localize ends. Ensure it
-		     * gets reaped by mortifying it instead. DAPM */
-		    if (SvTIED_mg(sv, PERL_MAGIC_tiedelem))
-			sv_2mortal(sv);
-		}
             }
 	}
 	else if (PL_op->op_private & OPpDEREF)
@@ -1917,8 +1894,8 @@ PP(pp_subst)
 	EXTEND(SP,1);
     }
 
-    if (SvFAKE(TARG) && SvREADONLY(TARG))
-	sv_force_normal(TARG);
+    if (SvIsCOW(TARG))
+	sv_force_normal_flags(TARG,0);
     if (SvREADONLY(TARG)
 	|| (SvTYPE(TARG) > SVt_PVLV
 	    && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
@@ -1980,8 +1957,21 @@ PP(pp_subst)
 
     /* known replacement string? */
     if (dstr) {
-        c = SvPV(dstr, clen);
-	doutf8 = DO_UTF8(dstr);
+	/* replacement needing upgrading? */
+	if (DO_UTF8(TARG) && !doutf8) {
+	     SV *nsv = sv_newmortal();
+	     SvSetSV(nsv, dstr);
+	     if (PL_encoding)
+		  sv_recode_to_utf8(nsv, PL_encoding);
+	     else
+		  sv_utf8_upgrade(nsv);
+	     c = SvPV(nsv, clen);
+	     doutf8 = TRUE;
+	}
+	else {
+	    c = SvPV(dstr, clen);
+	    doutf8 = DO_UTF8(dstr);
+	}
     }
     else {
         c = Nullch;
@@ -2086,6 +2076,8 @@ PP(pp_subst)
 	    SPAGAIN;
 	}
 	SvTAINT(TARG);
+	if (doutf8)
+	    SvUTF8_on(TARG);
 	LEAVE_SCOPE(oldsave);
 	RETURN;
     }
@@ -2952,17 +2944,8 @@ PP(pp_aelem)
 	    PUSHs(lv);
 	    RETURN;
 	}
-	if (PL_op->op_private & OPpLVAL_INTRO) {
-	    SV *sv;
+	if (PL_op->op_private & OPpLVAL_INTRO)
 	    save_aelem(av, elem, svp);
-	    sv = *svp;
-	    /* If we're localizing a tied array element, this new sv
-	     * won't actually be stored in the array - so it won't get
-	     * reaped when the localize ends. Ensure it gets reaped by
-	     * mortifying it instead. DAPM */
-	    if (SvTIED_mg(sv, PERL_MAGIC_tiedelem))
-		sv_2mortal(sv);
-	}
 	else if (PL_op->op_private & OPpDEREF)
 	    vivify_ref(*svp, PL_op->op_private & OPpDEREF);
     }