X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=2df5a770e40f054b6a0a87cf3160f7057a13cadb;hb=5f2d99664d8a6923d24892ffc0569f4e03e22edd;hp=7a3dbc7948cc4a5970d4415e055ae3c36526814d;hpb=de5e01c2603e3fa2c0e1b6603c7f4f31802c829d;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_sys.c b/pp_sys.c
index 7a3dbc7..2df5a77 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -453,7 +453,7 @@ PP(pp_warn)
     if (!tmps || !len)
 	tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
 
-    Perl_warn(aTHX_ "%"SVf, tmpsv);
+    Perl_warn(aTHX_ "%"SVf, (void*)tmpsv);
     RETSETYES;
 }
 
@@ -517,7 +517,7 @@ PP(pp_die)
     if (!tmps || !len)
 	tmpsv = sv_2mortal(newSVpvs("Died"));
 
-    DIE(aTHX_ "%"SVf, tmpsv);
+    DIE(aTHX_ "%"SVf, (void*)tmpsv);
 }
 
 /* I/O. */
@@ -836,7 +836,7 @@ PP(pp_tie)
 	stash = gv_stashsv(*MARK, FALSE);
 	if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
 	    DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
-		 methname, *MARK);
+		 methname, (void*)*MARK);
 	}
 	ENTER;
 	PUSHSTACKi(PERLSI_MAGIC);
@@ -1277,16 +1277,17 @@ PP(pp_enterwrite)
     else
 	fgv = gv;
 
+    if (!fgv) {
+	DIE(aTHX_ "Not a format reference");
+    }
     cv = GvFORM(fgv);
     if (!cv) {
-	if (fgv) {
-	    SV * const tmpsv = sv_newmortal();
-	    const char *name;
-	    gv_efullname4(tmpsv, fgv, NULL, FALSE);
-	    name = SvPV_nolen_const(tmpsv);
-	    if (name && *name)
-		DIE(aTHX_ "Undefined format \"%s\" called", name);
-	}
+	SV * const tmpsv = sv_newmortal();
+	const char *name;
+	gv_efullname4(tmpsv, fgv, NULL, FALSE);
+	name = SvPV_nolen_const(tmpsv);
+	if (name && *name)
+	    DIE(aTHX_ "Undefined format \"%s\" called", name);
 	DIE(aTHX_ "Not a format reference");
     }
     if (CvCLONE(cv))
@@ -1301,16 +1302,18 @@ PP(pp_leavewrite)
     dVAR; dSP;
     GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
     register IO * const io = GvIOp(gv);
-    PerlIO * const ofp = IoOFP(io);
+    PerlIO *ofp;
     PerlIO *fp;
     SV **newsp;
     I32 gimme;
     register PERL_CONTEXT *cx;
 
+    if (!io || !(ofp = IoOFP(io)))
+        goto forget_top;
+
     DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
 	  (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
-    if (!io || !ofp)
-	goto forget_top;
+
     if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
 	PL_formtarget != PL_toptarget)
     {
@@ -1374,15 +1377,13 @@ PP(pp_leavewrite)
 	    gv_efullname4(sv, fgv, NULL, FALSE);
 	    name = SvPV_nolen_const(sv);
 	    if (name && *name)
-		DIE(aTHX_ "Undefined top format \"%s\" called",name);
+		DIE(aTHX_ "Undefined top format \"%s\" called", name);
+	    else
+		DIE(aTHX_ "Undefined top format called");
 	}
-	/* why no:
-	else
-	    DIE(aTHX_ "Undefined top format called");
-	?*/
-	if (CvCLONE(cv))
+	if (cv && CvCLONE(cv))
 	    cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
-	return doform(cv,gv,PL_op);
+	return doform(cv, gv, PL_op);
     }
 
   forget_top:
@@ -1776,11 +1777,13 @@ PP(pp_send)
     IO *io;
     SV *bufsv;
     const char *buffer;
-    Size_t length = 0;
     SSize_t retval;
     STRLEN blen;
+    STRLEN orig_blen_bytes;
     MAGIC *mg;
     const int op_type = PL_op->op_type;
+    bool doing_utf8;
+    U8 *tmpbuf = NULL;
     
     GV *const gv = (GV*)*++MARK;
     if (PL_op->op_type == OP_SYSWRITE
@@ -1812,19 +1815,6 @@ PP(pp_send)
 
     bufsv = *++MARK;
 
-    if (op_type == OP_SYSWRITE) {
-	if (MARK >= SP) {
-	    length = (Size_t) sv_len(bufsv);
-	} else {
-#if Size_t_size > IVSIZE
-	    length = (Size_t)SvNVx(*++MARK);
-#else
-	    length = (Size_t)SvIVx(*++MARK);
-#endif
-	    if ((SSize_t)length < 0)
-		DIE(aTHX_ "Negative length");
-	}
-    }
     SETERRNO(0,0);
     io = GvIO(gv);
     if (!io || !IoIFP(io)) {
@@ -1835,43 +1825,111 @@ PP(pp_send)
 	goto say_undef;
     }
 
+    /* Do this first to trigger any overloading.  */
+    buffer = SvPV_const(bufsv, blen);
+    orig_blen_bytes = blen;
+    doing_utf8 = DO_UTF8(bufsv);
+
     if (PerlIO_isutf8(IoIFP(io))) {
 	if (!SvUTF8(bufsv)) {
-	    bufsv = sv_2mortal(newSVsv(bufsv));
-	    buffer = sv_2pvutf8(bufsv, &blen);
-	} else
-	    buffer = SvPV_const(bufsv, blen);
+	    /* We don't modify the original scalar.  */
+	    tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
+	    buffer = (char *) tmpbuf;
+	    doing_utf8 = TRUE;
+	}
     }
-    else {
-	 if (DO_UTF8(bufsv)) {
-	      /* Not modifying source SV, so making a temporary copy. */
-	      bufsv = sv_2mortal(newSVsv(bufsv));
-	      sv_utf8_downgrade(bufsv, FALSE);
-	 }
-	 buffer = SvPV_const(bufsv, blen);
+    else if (doing_utf8) {
+	STRLEN tmplen = blen;
+	U8 *result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
+	if (!doing_utf8) {
+	    tmpbuf = result;
+	    buffer = (char *) tmpbuf;
+	    blen = tmplen;
+	}
+	else {
+	    assert((char *)result == buffer);
+	    Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
+	}
     }
 
     if (op_type == OP_SYSWRITE) {
+	Size_t length = 0; /* This length is in characters.  */
+	STRLEN blen_chars;
 	IV offset;
-	if (DO_UTF8(bufsv)) {
-	    /* length and offset are in chars */
-	    blen   = sv_len_utf8(bufsv);
+
+	if (doing_utf8) {
+	    if (tmpbuf) {
+		/* The SV is bytes, and we've had to upgrade it.  */
+		blen_chars = orig_blen_bytes;
+	    } else {
+		/* The SV really is UTF-8.  */
+		if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
+		    /* Don't call sv_len_utf8 again because it will call magic
+		       or overloading a second time, and we might get back a
+		       different result.  */
+		    blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
+		} else {
+		    /* It's safe, and it may well be cached.  */
+		    blen_chars = sv_len_utf8(bufsv);
+		}
+	    }
+	} else {
+	    blen_chars = blen;
+	}
+
+	if (MARK >= SP) {
+	    length = blen_chars;
+	} else {
+#if Size_t_size > IVSIZE
+	    length = (Size_t)SvNVx(*++MARK);
+#else
+	    length = (Size_t)SvIVx(*++MARK);
+#endif
+	    if ((SSize_t)length < 0) {
+		Safefree(tmpbuf);
+		DIE(aTHX_ "Negative length");
+	    }
 	}
+
 	if (MARK < SP) {
 	    offset = SvIVx(*++MARK);
 	    if (offset < 0) {
-		if (-offset > (IV)blen)
+		if (-offset > (IV)blen_chars) {
+		    Safefree(tmpbuf);
 		    DIE(aTHX_ "Offset outside string");
-		offset += blen;
-	    } else if (offset >= (IV)blen && blen > 0)
+		}
+		offset += blen_chars;
+	    } else if (offset >= (IV)blen_chars && blen_chars > 0) {
+		Safefree(tmpbuf);
 		DIE(aTHX_ "Offset outside string");
+	    }
 	} else
 	    offset = 0;
-	if (length > blen - offset)
-	    length = blen - offset;
-	if (DO_UTF8(bufsv)) {
-	    buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
-	    length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
+	if (length > blen_chars - offset)
+	    length = blen_chars - offset;
+	if (doing_utf8) {
+	    /* Here we convert length from characters to bytes.  */
+	    if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
+		/* Either we had to convert the SV, or the SV is magical, or
+		   the SV has overloading, in which case we can't or mustn't
+		   or mustn't call it again.  */
+
+		buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
+		length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
+	    } else {
+		/* It's a real UTF-8 SV, and it's not going to change under
+		   us.  Take advantage of any cache.  */
+		I32 start = offset;
+		I32 len_I32 = length;
+
+		/* Convert the start and end character positions to bytes.
+		   Remember that the second argument to sv_pos_u2b is relative
+		   to the first.  */
+		sv_pos_u2b(bufsv, &start, &len_I32);
+
+		buffer += start;
+		length = len_I32;
+	    }
 	}
 	else {
 	    buffer = buffer+offset;
@@ -1907,11 +1965,15 @@ PP(pp_send)
     else
 	DIE(aTHX_ PL_no_sock_func, "send");
 #endif
+
     if (retval < 0)
 	goto say_undef;
     SP = ORIGMARK;
-    if (DO_UTF8(bufsv))
+    if (doing_utf8)
         retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
+
+    if (tmpbuf)
+	Safefree(tmpbuf);
 #if Size_t_size > IVSIZE
     PUSHn(retval);
 #else
@@ -1920,6 +1982,8 @@ PP(pp_send)
     RETURN;
 
   say_undef:
+    if (tmpbuf)
+	Safefree(tmpbuf);
     SP = ORIGMARK;
     RETPUSHUNDEF;
 }
@@ -2276,7 +2340,7 @@ PP(pp_socket)
     if (!gv || !io) {
 	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 	    report_evil_fh(gv, io, PL_op->op_type);
-	if (IoIFP(io))
+	if (io && IoIFP(io))
 	    do_close(gv, FALSE);
 	SETERRNO(EBADF,LIB_INVARG);
 	RETPUSHUNDEF;
@@ -2332,9 +2396,9 @@ PP(pp_sockpair)
 	    if (!gv2 || !io2)
 		report_evil_fh(gv1, io2, PL_op->op_type);
 	}
-	if (IoIFP(io1))
+	if (io1 && IoIFP(io1))
 	    do_close(gv1, FALSE);
-	if (IoIFP(io2))
+	if (io2 && IoIFP(io2))
 	    do_close(gv2, FALSE);
 	RETPUSHUNDEF;
     }
@@ -4012,7 +4076,8 @@ PP(pp_system)
 	    SP = ORIGMARK;
 	    if (did_pipes) {
 		int errkid;
-		int n = 0, n1;
+		unsigned n = 0;
+		SSize_t n1;
 
 		while (n < sizeof(int)) {
 		    n1 = PerlLIO_read(pp[0],