X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/655f5b268af8bf50c44ba4ae4803a33c9b792b8b..7706bc5635d89ccfcf9bd9d3797a9c6f657934fd:/pp.c

diff --git a/pp.c b/pp.c
index 5305521..42bea4d 100644
--- a/pp.c
+++ b/pp.c
@@ -31,22 +31,6 @@
 #include "reentr.h"
 #include "regcharclass.h"
 
-/* XXX I can't imagine anyone who doesn't have this actually _needs_
-   it, since pid_t is an integral type.
-   --AD  2/20/1998
-*/
-#ifdef NEED_GETPID_PROTO
-extern Pid_t getpid (void);
-#endif
-
-/*
- * Some BSDs and Cygwin default to POSIX math instead of IEEE.
- * This switches them over to IEEE.
- */
-#if defined(LIBM_LIB_VERSION)
-    _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
-#endif
-
 static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
 static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
 
@@ -62,101 +46,7 @@ PP(pp_stub)
 
 /* Pushy stuff. */
 
-/* This is also called directly by pp_lvavref.  */
-PP(pp_padav)
-{
-    dSP; dTARGET;
-    U8 gimme;
-    assert(SvTYPE(TARG) == SVt_PVAV);
-    if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
-	if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
-	    SAVECLEARSV(PAD_SVl(PL_op->op_targ));
-    EXTEND(SP, 1);
 
-    if (PL_op->op_flags & OPf_REF) {
-	PUSHs(TARG);
-	RETURN;
-    }
-    else if (PL_op->op_private & OPpMAYBE_LVSUB) {
-        const I32 flags = is_lvalue_sub();
-        if (flags && !(flags & OPpENTERSUB_INARGS)) {
-	    if (GIMME_V == G_SCALAR)
-                /* diag_listed_as: Can't return %s to lvalue scalar context */
-                Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
-            PUSHs(TARG);
-            RETURN;
-       }
-    }
-
-    gimme = GIMME_V;
-    if (gimme == G_ARRAY) {
-        /* XXX see also S_pushav in pp_hot.c */
-	const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
-	EXTEND(SP, maxarg);
-	if (SvMAGICAL(TARG)) {
-	    SSize_t i;
-	    for (i=0; i < maxarg; i++) {
-		SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
-		SP[i+1] = (svp) ? *svp : &PL_sv_undef;
-	    }
-	}
-	else {
-	    SSize_t i;
-	    for (i=0; i < maxarg; i++) {
-		SV * const sv = AvARRAY((const AV *)TARG)[i];
-		SP[i+1] = sv ? sv : &PL_sv_undef;
-	    }
-	}
-	SP += maxarg;
-    }
-    else if (gimme == G_SCALAR) {
-	SV* const sv = sv_newmortal();
-	const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
-	sv_setiv(sv, maxarg);
-	PUSHs(sv);
-    }
-    RETURN;
-}
-
-PP(pp_padhv)
-{
-    dSP; dTARGET;
-    U8 gimme;
-
-    assert(SvTYPE(TARG) == SVt_PVHV);
-    XPUSHs(TARG);
-    if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
-	if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
-	    SAVECLEARSV(PAD_SVl(PL_op->op_targ));
-
-    if (PL_op->op_flags & OPf_REF)
-	RETURN;
-    else if (PL_op->op_private & OPpMAYBE_LVSUB) {
-        const I32 flags = is_lvalue_sub();
-        if (flags && !(flags & OPpENTERSUB_INARGS)) {
-            if (GIMME_V == G_SCALAR)
-                /* diag_listed_as: Can't return %s to lvalue scalar context */
-                Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
-            RETURN;
-        }
-    }
-
-    gimme = GIMME_V;
-    if (gimme == G_ARRAY) {
-	RETURNOP(Perl_do_kv(aTHX));
-    }
-    else if ((PL_op->op_private & OPpTRUEBOOL
-	  || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
-	     && block_gimme() == G_VOID  ))
-	  && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied))
-    )
-	SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : &PL_sv_no);
-    else if (gimme == G_SCALAR) {
-	SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
-	SETs(sv);
-    }
-    RETURN;
-}
 
 PP(pp_padcv)
 {
@@ -440,11 +330,15 @@ PP(pp_pos)
     else {
 	    const MAGIC * const mg = mg_find_mglob(sv);
 	    if (mg && mg->mg_len != -1) {
-		dTARGET;
 		STRLEN i = mg->mg_len;
-		if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
-		    i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
-		SETu(i);
+                if (PL_op->op_private & OPpTRUEBOOL)
+                    SETs(i ? &PL_sv_yes : &PL_sv_zero);
+                else {
+                    dTARGET;
+                    if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
+                        i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
+                    SETu(i);
+                }
 		return NORMAL;
 	    }
 	    SETs(&PL_sv_undef);
@@ -592,19 +486,50 @@ PP(pp_ref)
     SV * const sv = TOPs;
 
     SvGETMAGIC(sv);
-    if (!SvROK(sv))
+    if (!SvROK(sv)) {
 	SETs(&PL_sv_no);
-    else {
+        return NORMAL;
+    }
+
+    /* op is in boolean context? */
+    if (   (PL_op->op_private & OPpTRUEBOOL)
+        || (   (PL_op->op_private & OPpMAYBE_TRUEBOOL)
+            && block_gimme() == G_VOID))
+    {
+        /* refs are always true - unless it's to an object blessed into a
+         * class with a false name, i.e. "0". So we have to check for
+         * that remote possibility. The following is is basically an
+         * unrolled SvTRUE(sv_reftype(rv)) */
+        SV * const rv = SvRV(sv);
+        if (SvOBJECT(rv)) {
+            HV *stash = SvSTASH(rv);
+            HEK *hek = HvNAME_HEK(stash);
+            if (hek) {
+                I32 len = HEK_LEN(hek);
+                /* bail out and do it the hard way? */
+                if (UNLIKELY(
+                       len == HEf_SVKEY
+                    || (len == 1 && HEK_KEY(hek)[0] == '0')
+                ))
+                    goto do_sv_ref;
+            }
+        }
+        SETs(&PL_sv_yes);
+        return NORMAL;
+    }
+
+  do_sv_ref:
+    {
 	dTARGET;
 	SETs(TARG);
-	/* use the return value that is in a register, its the same as TARG */
-	TARG = sv_ref(TARG,SvRV(sv),TRUE);
+	sv_ref(TARG, SvRV(sv), TRUE);
 	SvSETMAGIC(TARG);
+	return NORMAL;
     }
 
-    return NORMAL;
 }
 
+
 PP(pp_bless)
 {
     dSP;
@@ -1515,15 +1440,9 @@ PP(pp_divide)
        can be too large to preserve, so don't need to compile the code to
        test the size of UVs.  */
 
-#ifdef SLOPPYDIVIDE
+#if defined(SLOPPYDIVIDE) || (defined(PERL_PRESERVE_IVUV) && !defined(NV_PRESERVES_UV))
 #  define PERL_TRY_UV_DIVIDE
     /* ensure that 20./5. == 4. */
-#else
-#  ifdef PERL_PRESERVE_IVUV
-#    ifndef NV_PRESERVES_UV
-#      define PERL_TRY_UV_DIVIDE
-#    endif
-#  endif
 #endif
 
 #ifdef PERL_TRY_UV_DIVIDE
@@ -2590,8 +2509,11 @@ PP(pp_negate)
 PP(pp_not)
 {
     dSP;
+    SV *sv;
+
     tryAMAGICun_MG(not_amg, AMGf_set);
-    *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
+    sv = *PL_stack_sp;
+    *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
     return NORMAL;
 }
 
@@ -2604,64 +2526,17 @@ S_scomplement(pTHX_ SV *targ, SV *sv)
 
 	sv_copypv_nomg(TARG, sv);
 	tmps = (U8*)SvPV_nomg(TARG, len);
-	anum = len;
+
 	if (SvUTF8(TARG)) {
-	  /* Calculate exact length, let's not estimate. */
-	  STRLEN targlen = 0;
-	  STRLEN l;
-	  UV nchar = 0;
-	  UV nwide = 0;
-	  U8 * const send = tmps + len;
-	  U8 * const origtmps = tmps;
-	  const UV utf8flags = UTF8_ALLOW_ANYUV;
-
-	  while (tmps < send) {
-	    const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
-	    tmps += l;
-	    targlen += UVCHR_SKIP(~c);
-	    nchar++;
-	    if (c > 0xff)
-		nwide++;
-	  }
+            if (len && ! utf8_to_bytes(tmps, &len)) {
+                Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[PL_op->op_type]);
+            }
+            SvCUR(TARG) = len;
+            SvUTF8_off(TARG);
+        }
+
+	anum = len;
 
-	  /* Now rewind strings and write them. */
-	  tmps = origtmps;
-
-	  if (nwide) {
-	      U8 *result;
-	      U8 *p;
-
-              Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
-                        deprecated_above_ff_msg, PL_op_desc[PL_op->op_type]);
-	      Newx(result, targlen + 1, U8);
-	      p = result;
-	      while (tmps < send) {
-		  const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
-		  tmps += l;
-		  p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
-	      }
-	      *p = '\0';
-	      sv_usepvn_flags(TARG, (char*)result, targlen,
-			      SV_HAS_TRAILING_NUL);
-	      SvUTF8_on(TARG);
-	  }
-	  else {
-	      U8 *result;
-	      U8 *p;
-
-	      Newx(result, nchar + 1, U8);
-	      p = result;
-	      while (tmps < send) {
-		  const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
-		  tmps += l;
-		  *p++ = ~c;
-	      }
-	      *p = '\0';
-	      sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
-	      SvUTF8_off(TARG);
-	  }
-	  return;
-	}
 #ifdef LIBERAL
 	{
 	    long *tmpl;
@@ -3217,52 +3092,74 @@ PP(pp_oct)
 
 /* String stuff. */
 
+
 PP(pp_length)
 {
     dSP; dTARGET;
     SV * const sv = TOPs;
 
     U32 in_bytes = IN_BYTES;
-    /* simplest case shortcut */
-    /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
+    /* Simplest case shortcut:
+     * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
+     * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
+     * set)
+     */
     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
-    STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
+
+    STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
     SETs(TARG);
 
-    if(LIKELY(svflags == SVf_POK))
+    if (LIKELY(svflags == SVf_POK))
         goto simple_pv;
-    if(svflags & SVs_GMG)
+
+    if (svflags & SVs_GMG)
         mg_get(sv);
+
     if (SvOK(sv)) {
-	if (!IN_BYTES) /* reread to avoid using an C auto/register */
-	    sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
-	else
-	{
-	    STRLEN len;
+        STRLEN len;
+	if (!IN_BYTES) { /* reread to avoid using an C auto/register */
+            if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
+                goto simple_pv;
+            if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
+                /* no need to convert from bytes to chars */
+                len = SvCUR(sv);
+                goto return_bool;
+            }
+	    len = sv_len_utf8_nomg(sv);
+        }
+	else {
             /* unrolled SvPV_nomg_const(sv,len) */
-            if(SvPOK_nog(sv)){
-                simple_pv:
+            if (SvPOK_nog(sv)) {
+              simple_pv:
                 len = SvCUR(sv);
-            } else  {
+                if (PL_op->op_private & OPpTRUEBOOL) {
+                  return_bool:
+                    SETs(len ? &PL_sv_yes : &PL_sv_zero);
+                    return NORMAL;
+                }
+            }
+            else {
                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
             }
-	    sv_setiv(TARG, (IV)(len));
 	}
-    } else {
+        TARGi((IV)(len), 1);
+    }
+    else {
 	if (!SvPADTMP(TARG)) {
+            /* OPpTARGET_MY: targ is var in '$lex = length()' */
             sv_set_undef(TARG);
-	} else { /* TARG is on stack at this point and is overwriten by SETs.
-                   This branch is the odd one out, so put TARG by default on
-                   stack earlier to let local SP go out of liveness sooner */
+            SvSETMAGIC(TARG);
+	}
+        else
+            /* TARG is on stack at this point and is overwriten by SETs.
+             * This branch is the odd one out, so put TARG by default on
+             * stack earlier to let local SP go out of liveness sooner */
             SETs(&PL_sv_undef);
-            goto no_set_magic;
-        }
     }
-    SvSETMAGIC(TARG);
-    no_set_magic:
     return NORMAL; /* no putback, SP didn't move in this opcode */
 }
 
+
 /* Returns false if substring is completely outside original string.
    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
    always be true for an explicit 0.
@@ -3565,7 +3462,7 @@ PP(pp_index)
 		   convert the small string to ISO-8859-1, then there is no
 		   way that it could be found anywhere by index.  */
 		retval = -1;
-		goto fail;
+		goto push_result;
 	    }
 
 	    /* At this point, pv is a malloc()ed string. So donate it to temp
@@ -3628,8 +3525,18 @@ PP(pp_index)
 	    retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
     }
     SvREFCNT_dec(temp);
- fail:
-    PUSHi(retval);
+
+  push_result:
+    /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
+    if (PL_op->op_private & OPpTRUEBOOL) {
+        PUSHs( ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
+                    ? &PL_sv_yes : &PL_sv_no);
+        if (PL_op->op_private & OPpTARGET_MY)
+            /* $lex = (index() == -1) */
+            sv_setsv(TARG, TOPs);
+    }
+    else 
+        PUSHi(retval);
     RETURN;
 }
 
@@ -5124,7 +5031,7 @@ PP(pp_hslice)
                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
             }
             if (localizing) {
-		if (HvNAME_get(hv) && isGV(*svp))
+		if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
 		    save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
 		else if (preeminent)
 		    save_helem_flags(hv, keysv, svp,
@@ -5201,6 +5108,7 @@ PP(pp_list)
     if (GIMME_V != G_ARRAY) {
 	SV **mark = PL_stack_base + markidx;
 	dSP;
+        EXTEND(SP, 1);          /* in case no arguments, as in @empty */
 	if (++MARK <= SP)
 	    *MARK = *SP;		/* unwanted list, return last item */
 	else
@@ -5225,6 +5133,7 @@ PP(pp_lslice)
 
     if (GIMME_V != G_ARRAY) {
         if (lastlelem < firstlelem) {
+            EXTEND(SP, 1);
             *firstlelem = &PL_sv_undef;
         }
         else {
@@ -5326,6 +5235,9 @@ PP(pp_splice)
 				    sp - mark);
     }
 
+    if (SvREADONLY(ary))
+        Perl_croak_no_modify();
+
     SP++;
 
     if (++MARK < SP) {
@@ -5698,8 +5610,11 @@ PP(pp_reverse)
 	SvUTF8_off(TARG);				/* decontaminate */
 	if (SP - MARK > 1)
 	    do_join(TARG, &PL_sv_no, MARK, SP);
-	else {
-	    sv_setsv(TARG, SP > MARK ? *SP : DEFSV);
+	else if (SP > MARK)
+	    sv_setsv(TARG, *SP);
+        else {
+	    sv_setsv(TARG, DEFSV);
+            EXTEND(SP, 1);
 	}
 
 	up = SvPV_force(TARG, len);
@@ -5754,6 +5669,7 @@ PP(pp_split)
     STRLEN len;
     const char *s = SvPV_const(sv, len);
     const bool do_utf8 = DO_UTF8(sv);
+    const bool in_uni_8_bit = IN_UNI_8_BIT;
     const char *strend = s + len;
     PMOP *pm = cPMOPx(PL_op);
     REGEXP *rx;
@@ -5840,6 +5756,10 @@ PP(pp_split)
 	    while (s < strend && isSPACE_LC(*s))
 		s++;
 	}
+        else if (in_uni_8_bit) {
+            while (s < strend && isSPACE_L1(*s))
+                s++;
+        }
 	else {
 	    while (s < strend && isSPACE(*s))
 		s++;
@@ -5871,6 +5791,10 @@ PP(pp_split)
             {
 	        while (m < strend && !isSPACE_LC(*m))
 		    ++m;
+            }
+            else if (in_uni_8_bit) {
+                while (m < strend && !isSPACE_L1(*m))
+                    ++m;
             } else {
                 while (m < strend && !isSPACE(*m))
                     ++m;
@@ -5905,6 +5829,10 @@ PP(pp_split)
             {
 	        while (s < strend && isSPACE_LC(*s))
 		    ++s;
+            }
+            else if (in_uni_8_bit) {
+                while (s < strend && isSPACE_L1(*s))
+                    ++s;
             } else {
                 while (s < strend && isSPACE(*s))
                     ++s;
@@ -6409,6 +6337,19 @@ PP(pp_coreargs)
     RETURN;
 }
 
+/* Implement CORE::keys(),values(),each().
+ *
+ * We won't know until run-time whether the arg is an array or hash,
+ * so this op calls
+ *
+ *    pp_keys/pp_values/pp_each
+ * or
+ *    pp_akeys/pp_avalues/pp_aeach
+ *
+ * as appropriate (or whatever pp function actually implements the OP_FOO
+ * functionality for each FOO).
+ */
+
 PP(pp_avhvswitch)
 {
     dVAR; dSP;