X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=52fcf96016ee0136a12fe2cc1a7aaed60626b2ef;hb=181ea953f5037d8eebef8af5f5ba67f9ff02a565;hp=5a8cf00a86e2a217522421d5ab193cfb711f612a;hpb=d0ecd44c5964f10ab34d28eea63e112aa8c61503;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_ctl.c b/pp_ctl.c
index 5a8cf00..52fcf96 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -41,6 +41,10 @@ static void save_lines _((AV *array, SV *sv));
 static I32 sortcv _((SV *a, SV *b));
 static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
 static OP *doeval _((int gimme, OP** startop));
+static I32 sv_ncmp _((SV *a, SV *b));
+static I32 sv_i_ncmp _((SV *a, SV *b));
+static I32 amagic_ncmp _((SV *a, SV *b));
+static I32 amagic_i_ncmp _((SV *a, SV *b));
 static I32 amagic_cmp _((SV *str1, SV *str2));
 static I32 amagic_cmp_locale _((SV *str1, SV *str2));
 #endif
@@ -164,8 +168,10 @@ PP(pp_substcont)
 
 	/* Are we done */
 	if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
-				     s == m, Nullsv, NULL,
-				     cx->sb_safebase ? 0 : REXEC_COPY_STR))
+				     s == m, cx->sb_targ, NULL,
+				     ((cx->sb_rflags & REXEC_COPY_STR)
+				      ? REXEC_IGNOREPOS 
+				      : (REXEC_COPY_STR|REXEC_IGNOREPOS))))
 	{
 	    SV *targ = cx->sb_targ;
 	    sv_catpvn(dstr, s, cx->sb_strend - s);
@@ -617,7 +623,13 @@ PP(pp_formline)
 	    break;
 
 	case FF_MORE:
-	    if (itemsize) {
+	    s = chophere;
+	    send = item + len;
+	    if (chopspace) {
+		while (*s && isSPACE(*s) && s < send)
+		    s++;
+	    }
+	    if (s < send) {
 		arg = fieldsize - itemsize;
 		if (arg) {
 		    fieldsize -= arg;
@@ -662,12 +674,8 @@ PP(pp_grepstart)
     ENTER;					/* enter outer scope */
 
     SAVETMPS;
-#ifdef USE_THREADS
-    /* SAVE_DEFSV does *not* suffice here */
-    save_sptr(&THREADSV(0));
-#else
-    SAVESPTR(GvSV(PL_defgv));
-#endif /* USE_THREADS */
+    /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
+    SAVESPTR(DEFSV);
     ENTER;					/* enter inner scope */
     SAVESPTR(PL_curpm);
 
@@ -749,6 +757,20 @@ PP(pp_mapwhile)
     }
 }
 
+STATIC I32
+sv_ncmp (SV *a, SV *b)
+{
+    double nv1 = SvNV(a);
+    double nv2 = SvNV(b);
+    return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
+}
+STATIC I32
+sv_i_ncmp (SV *a, SV *b)
+{
+    IV iv1 = SvIV(a);
+    IV iv2 = SvIV(b);
+    return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
+}
 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
 	  *svp = Nullsv;				\
           if (PL_amagic_generation) { \
@@ -761,6 +783,50 @@ PP(pp_mapwhile)
 	} STMT_END
 
 STATIC I32
+amagic_ncmp(register SV *a, register SV *b)
+{
+    SV *tmpsv;
+    tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
+    if (tmpsv) {
+    	double d;
+    	
+        if (SvIOK(tmpsv)) {
+            I32 i = SvIVX(tmpsv);
+            if (i > 0)
+               return 1;
+            return i? -1 : 0;
+        }
+        d = SvNV(tmpsv);
+        if (d > 0)
+           return 1;
+        return d? -1 : 0;
+     }
+     return sv_ncmp(a, b);
+}
+
+STATIC I32
+amagic_i_ncmp(register SV *a, register SV *b)
+{
+    SV *tmpsv;
+    tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
+    if (tmpsv) {
+    	double d;
+    	
+        if (SvIOK(tmpsv)) {
+            I32 i = SvIVX(tmpsv);
+            if (i > 0)
+               return 1;
+            return i? -1 : 0;
+        }
+        d = SvNV(tmpsv);
+        if (d > 0)
+           return 1;
+        return d? -1 : 0;
+    }
+    return sv_i_ncmp(a, b);
+}
+
+STATIC I32
 amagic_cmp(register SV *str1, register SV *str2)
 {
     SV *tmpsv;
@@ -852,7 +918,7 @@ PP(pp_sort)
 	    }
 	    PL_sortcop = CvSTART(cv);
 	    SAVESPTR(CvROOT(cv)->op_ppaddr);
-	    CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
+	    CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
 
 	    SAVESPTR(PL_curpad);
 	    PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
@@ -869,10 +935,11 @@ PP(pp_sort)
 	if (*up = *++MARK) {			/* Weed out nulls. */
 	    SvTEMP_off(*up);
 	    if (!PL_sortcop && !SvPOK(*up)) {
+		STRLEN n_a;
 	        if (SvAMAGIC(*up))
 	            overloading = 1;
 	        else
-		    (void)sv_2pv(*up, &PL_na);
+		    (void)sv_2pv(*up, &n_a);
 	    }
 	    up++;
 	}
@@ -911,6 +978,7 @@ PP(pp_sort)
 	    qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
 
 	    POPBLOCK(cx,PL_curpm);
+	    PL_stack_sp = newsp;
 	    POPSTACK;
 	    CATCH_SET(oldcatch);
 	}
@@ -919,13 +987,30 @@ PP(pp_sort)
 	if (max > 1) {
 	    MEXTEND(SP, 20);	/* Can't afford stack realloc on signal. */
 	    qsortsv(ORIGMARK+1, max,
-		    (PL_op->op_private & OPpLOCALE)
-		    ? ( overloading
-		        ? FUNC_NAME_TO_PTR(amagic_cmp_locale)
-		        : FUNC_NAME_TO_PTR(sv_cmp_locale))
-		    : ( overloading 
-		        ? FUNC_NAME_TO_PTR(amagic_cmp)
-		        : FUNC_NAME_TO_PTR(sv_cmp) ));
+ 		    (PL_op->op_private & OPpSORT_NUMERIC)
+			? ( (PL_op->op_private & OPpSORT_INTEGER)
+			    ? ( overloading
+				? FUNC_NAME_TO_PTR(amagic_i_ncmp)
+				: FUNC_NAME_TO_PTR(sv_i_ncmp))
+			    : ( overloading
+				? FUNC_NAME_TO_PTR(amagic_ncmp)
+				: FUNC_NAME_TO_PTR(sv_ncmp)))
+			: ( (PL_op->op_private & OPpLOCALE)
+			    ? ( overloading
+				? FUNC_NAME_TO_PTR(amagic_cmp_locale)
+				: FUNC_NAME_TO_PTR(sv_cmp_locale))
+			    : ( overloading
+				? FUNC_NAME_TO_PTR(amagic_cmp)
+		    : FUNC_NAME_TO_PTR(sv_cmp) )));
+	    if (PL_op->op_private & OPpSORT_REVERSE) {
+		SV **p = ORIGMARK+1;
+		SV **q = ORIGMARK+max;
+		while (p < q) {
+		    SV *tmp = *p;
+		    *p++ = *q;
+		    *q-- = tmp;
+		}
+	    }
 	}
     }
     LEAVE;
@@ -980,33 +1065,41 @@ PP(pp_flop)
 
     if (GIMME == G_ARRAY) {
 	dPOPPOPssrl;
-	register I32 i;
+	register I32 i, j;
 	register SV *sv;
 	I32 max;
 
+	if (SvGMAGICAL(left))
+	    mg_get(left);
+	if (SvGMAGICAL(right))
+	    mg_get(right);
+
 	if (SvNIOKp(left) || !SvPOKp(left) ||
 	  (looks_like_number(left) && *SvPVX(left) != '0') )
 	{
-	    if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX)
+	    if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
 		croak("Range iterator outside integer range");
 	    i = SvIV(left);
 	    max = SvIV(right);
 	    if (max >= i) {
-		EXTEND_MORTAL(max - i + 1);
-		EXTEND(SP, max - i + 1);
+		j = max - i + 1;
+		EXTEND_MORTAL(j);
+		EXTEND(SP, j);
 	    }
-	    while (i <= max) {
+	    else
+		j = 0;
+	    while (j--) {
 		sv = sv_2mortal(newSViv(i++));
 		PUSHs(sv);
 	    }
 	}
 	else {
 	    SV *final = sv_mortalcopy(right);
-	    STRLEN len;
+	    STRLEN len, n_a;
 	    char *tmps = SvPV(final, len);
 
 	    sv = sv_mortalcopy(left);
-	    SvPV_force(sv,PL_na);
+	    SvPV_force(sv,n_a);
 	    while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
 		XPUSHs(sv);
 	        if (strEQ(SvPVX(sv),tmps))
@@ -1047,22 +1140,22 @@ dopoptolabel(char *label)
 	case CXt_SUBST:
 	    if (ckWARN(WARN_UNSAFE))
 		warner(WARN_UNSAFE, "Exiting substitution via %s", 
-			op_name[PL_op->op_type]);
+			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_SUB:
 	    if (ckWARN(WARN_UNSAFE))
 		warner(WARN_UNSAFE, "Exiting subroutine via %s", 
-			op_name[PL_op->op_type]);
+			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_EVAL:
 	    if (ckWARN(WARN_UNSAFE))
 		warner(WARN_UNSAFE, "Exiting eval via %s", 
-			op_name[PL_op->op_type]);
+			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_NULL:
 	    if (ckWARN(WARN_UNSAFE))
 		warner(WARN_UNSAFE, "Exiting pseudo-block via %s", 
-			op_name[PL_op->op_type]);
+			PL_op_name[PL_op->op_type]);
 	    return -1;
 	case CXt_LOOP:
 	    if (!cx->blk_loop.label ||
@@ -1167,22 +1260,22 @@ dopoptoloop(I32 startingblock)
 	case CXt_SUBST:
 	    if (ckWARN(WARN_UNSAFE))
 		warner(WARN_UNSAFE, "Exiting substitution via %s", 
-			op_name[PL_op->op_type]);
+			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_SUB:
 	    if (ckWARN(WARN_UNSAFE))
 		warner(WARN_UNSAFE, "Exiting subroutine via %s", 
-			op_name[PL_op->op_type]);
+			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_EVAL:
 	    if (ckWARN(WARN_UNSAFE))
 		warner(WARN_UNSAFE, "Exiting eval via %s", 
-			op_name[PL_op->op_type]);
+			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_NULL:
 	    if (ckWARN(WARN_UNSAFE))
 		warner(WARN_UNSAFE, "Exiting pseudo-block via %s", 
-			op_name[PL_op->op_type]);
+			PL_op_name[PL_op->op_type]);
 	    return -1;
 	case CXt_LOOP:
 	    DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
@@ -1203,7 +1296,7 @@ dounwind(I32 cxix)
     while (cxstack_ix > cxix) {
 	cx = &cxstack[cxstack_ix];
 	DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
-			      (long) cxstack_ix, block_type[CxTYPE(cx)]));
+			      (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
 	/* Note: we don't need to restore the base context info till the end. */
 	switch (CxTYPE(cx)) {
 	case CXt_SUBST:
@@ -1229,6 +1322,7 @@ OP *
 die_where(char *message)
 {
     dSP;
+    STRLEN n_a;
     if (PL_in_eval) {
 	I32 cxix;
 	register PERL_CONTEXT *cx;
@@ -1252,6 +1346,10 @@ die_where(char *message)
 			SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
 			sv_catpvn(err, prefix, sizeof(prefix)-1);
 			sv_catpvn(err, message, klen);
+			if (ckWARN(WARN_UNSAFE)) {
+			    STRLEN start = SvCUR(err)-klen-sizeof(prefix)+1;
+			    warner(WARN_UNSAFE, SvPVX(err)+start);
+			}
 		    }
 		    sv_inc(*svp);
 		}
@@ -1260,7 +1358,7 @@ die_where(char *message)
 		sv_setpv(ERRSV, message);
 	}
 	else
-	    message = SvPVx(ERRSV, PL_na);
+	    message = SvPVx(ERRSV, n_a);
 
 	while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
 	    dounwind(-1);
@@ -1287,14 +1385,14 @@ die_where(char *message)
 	    LEAVE;
 
 	    if (optype == OP_REQUIRE) {
-		char* msg = SvPVx(ERRSV, PL_na);
+		char* msg = SvPVx(ERRSV, n_a);
 		DIE("%s", *msg ? msg : "Compilation failed in require");
 	    }
 	    return pop_return();
 	}
     }
     if (!message)
-	message = SvPVx(ERRSV, PL_na);
+	message = SvPVx(ERRSV, n_a);
     PerlIO_printf(PerlIO_stderr(), "%s",message);
     PerlIO_flush(PerlIO_stderr());
     my_failure_exit();
@@ -1472,11 +1570,12 @@ PP(pp_reset)
 {
     djSP;
     char *tmps;
+    STRLEN n_a;
 
     if (MAXARG < 1)
 	tmps = "";
     else
-	tmps = POPp;
+	tmps = POPpx;
     sv_reset(tmps, PL_curcop->cop_stash);
     PUSHs(&PL_sv_yes);
     RETURN;
@@ -1549,8 +1648,12 @@ PP(pp_enteriter)
     SAVETMPS;
 
 #ifdef USE_THREADS
-    if (PL_op->op_flags & OPf_SPECIAL)
-	svp = save_threadsv(PL_op->op_targ);	/* per-thread variable */
+    if (PL_op->op_flags & OPf_SPECIAL) {
+	dTHR;
+	svp = &THREADSV(PL_op->op_targ);	/* per-thread variable */
+	SAVEGENERICSV(*svp);
+	*svp = NEWSV(0,0);
+    }
     else
 #endif /* USE_THREADS */
     if (PL_op->op_targ) {
@@ -1558,9 +1661,9 @@ PP(pp_enteriter)
 	SAVESPTR(*svp);
     }
     else {
-	GV *gv = (GV*)POPs;
-	(void)save_scalar(gv);
-	svp = &GvSV(gv);			/* symbol table variable */
+	svp = &GvSV((GV*)POPs);			/* symbol table variable */
+	SAVEGENERICSV(*svp);
+	*svp = NEWSV(0,0);
     }
 
     ENTER;
@@ -1928,10 +2031,12 @@ PP(pp_goto)
     OP *enterops[GOTO_DEPTH];
     char *label;
     int do_dump = (PL_op->op_type == OP_DUMP);
+    static char must_have_label[] = "goto must have label";
 
     label = 0;
     if (PL_op->op_flags & OPf_STACKED) {
 	SV *sv = POPs;
+	STRLEN n_a;
 
 	/* This egregious kludge implements goto &subroutine */
 	if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
@@ -2180,12 +2285,15 @@ PP(pp_goto)
 		RETURNOP(CvSTART(cv));
 	    }
 	}
-	else
-	    label = SvPV(sv,PL_na);
+	else {
+	    label = SvPV(sv,n_a);
+	    if (!(do_dump || *label))
+		DIE(must_have_label);
+	}
     }
     else if (PL_op->op_flags & OPf_SPECIAL) {
 	if (! do_dump)
-	    DIE("goto must have label");
+	    DIE(must_have_label);
     }
     else
 	label = cPVOP->op_pv;
@@ -2330,7 +2438,8 @@ PP(pp_cswitch)
     if (PL_multiline)
 	PL_op = PL_op->op_next;			/* can't assume anything */
     else {
-	match = *(SvPVx(GvSV(cCOP->cop_gv), PL_na)) & 255;
+	STRLEN n_a;
+	match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
 	match -= cCOP->uop.scop.scop_offset;
 	if (match < 0)
 	    match = 0;
@@ -2459,7 +2568,7 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
     POPEVAL(cx);
 
     (*startop)->op_type = OP_NULL;
-    (*startop)->op_ppaddr = ppaddr[OP_NULL];
+    (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
     lex_end();
     *avp = (AV*)SvREFCNT_inc(PL_comppad);
     LEAVE;
@@ -2569,6 +2678,7 @@ doeval(int gimme, OP** startop)
 	I32 gimme;
 	PERL_CONTEXT *cx;
 	I32 optype = 0;			/* Might be reset by POPEVAL. */
+	STRLEN n_a;
 
 	PL_op = saveop;
 	if (PL_eval_root) {
@@ -2584,10 +2694,10 @@ doeval(int gimme, OP** startop)
 	lex_end();
 	LEAVE;
 	if (optype == OP_REQUIRE) {
-	    char* msg = SvPVx(ERRSV, PL_na);
+	    char* msg = SvPVx(ERRSV, n_a);
 	    DIE("%s", *msg ? msg : "Compilation failed in require");
 	} else if (startop) {
-	    char* msg = SvPVx(ERRSV, PL_na);
+	    char* msg = SvPVx(ERRSV, n_a);
 
 	    POPBLOCK(cx,PL_curpm);
 	    POPEVAL(cx);
@@ -2660,13 +2770,14 @@ PP(pp_require)
     SV** svp;
     I32 gimme = G_SCALAR;
     PerlIO *tryrsfp = 0;
+    STRLEN n_a;
 
     sv = POPs;
     if (SvNIOKp(sv) && !SvPOKp(sv)) {
 	SET_NUMERIC_STANDARD();
 	if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
 	    DIE("Perl %s required--this is only version %s, stopped",
-		SvPV(sv,PL_na),PL_patchlevel);
+		SvPV(sv,n_a),PL_patchlevel);
 	RETPUSHYES;
     }
     name = SvPV(sv, len);
@@ -2709,7 +2820,7 @@ PP(pp_require)
 	{
 	    namesv = NEWSV(806, 0);
 	    for (i = 0; i <= AvFILL(ar); i++) {
-		char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
+		char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
 #ifdef VMS
 		char *unixdir;
 		if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
@@ -2745,7 +2856,7 @@ PP(pp_require)
 		sv_catpv(msg, " (did you run h2ph?)");
 	    sv_catpv(msg, " (@INC contains:");
 	    for (i = 0; i <= AvFILL(ar); i++) {
-		char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
+		char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
 		sv_setpvf(dirmsgsv, " %s", dir);
 	        sv_catsv(msg, dirmsgsv);
 	    }