X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FEncode%2FEncode.xs;h=9bd8a4ce1e0cbf575d6649b4c13d58c00e4e2e4e;hb=5129552cc421a69f6981a03ac0ecc86b5722d1e6;hp=52fee5a6764e6e14fa1d2aa8488babf8c4b6705e;hpb=9dbbe3891ce90facc5523d60b4d6ccb1aef29b75;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs
index 52fee5a..9bd8a4c 100644
--- a/ext/Encode/Encode.xs
+++ b/ext/Encode/Encode.xs
@@ -5,10 +5,10 @@
 #include "XSUB.h"
 #define U8 U8
 #include "encode.h"
-#include "8859.h"
-#include "EBCDIC.h"
-#include "Symbols.h"
-
+/* #include "8859.h" */
+/* #include "EBCDIC.h" */
+/* #include "Symbols.h" */
+#include "defcodes.h"
 
 #define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) {dTHX;   \
                          Perl_croak(aTHX_ "panic_unimplemented"); \
@@ -91,7 +91,7 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
     if (!SvROK(e->enc)) {
 	e->enc = Nullsv;
 	errno = EINVAL;
-	Perl_warner(aTHX_ WARN_IO, "Cannot find encoding \"%" SVf "\"",
+	Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
 		    arg);
 	code = -1;
     }
@@ -118,7 +118,7 @@ PerlIOEncode_popped(pTHX_ PerlIO * f)
     }
     if (e->dataSV) {
 	SvREFCNT_dec(e->dataSV);
-	e->bufsv = Nullsv;
+	e->dataSV = Nullsv;
     }
     return 0;
 }
@@ -227,7 +227,7 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
 	    SvPVX(e->dataSV) = (char *) ptr;
 	    SvLEN(e->dataSV) = 0;  /* Hands off sv.c - it isn't yours */
 	    SvCUR_set(e->dataSV,use);
-	    SvPOK_on(e->dataSV);
+	    SvPOK_only(e->dataSV);
 	}
 	SvUTF8_off(e->dataSV);
 	PUSHMARK(sp);
@@ -255,7 +255,7 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
 	       (The copy is a pain - need a put-it-here option for decode.)
 	     */
 	    sv_setpvn(e->bufsv,s,len);
-	    e->base.ptr = e->base.buf = (U8*)SvPVX(e->bufsv);
+	    e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv);
 	    e->base.end = e->base.ptr + SvCUR(e->bufsv);
 	    PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
 	    SvUTF8_on(e->bufsv);
@@ -328,6 +328,11 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
 	    if (PerlIO_flush(PerlIONext(f)) != 0) {
 		code = -1;
 	    }
+	    if (SvCUR(e->bufsv)) {
+		/* Did not all translate */
+		e->base.ptr = e->base.buf+SvCUR(e->bufsv);
+		return code;
+	    }
 	}
 	else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
 	    /* read case */
@@ -351,6 +356,7 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
 		SvPVX(str) = (char*)e->base.ptr;
 		SvLEN(str) = 0;
 		SvCUR_set(str, e->base.end - e->base.ptr);
+		SvPOK_only(str);
 		SvUTF8_on(str);
 		PUSHMARK(sp);
 		XPUSHs(e->enc);
@@ -384,6 +390,9 @@ PerlIOEncode_close(pTHX_ PerlIO * f)
     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
     IV code = PerlIOBase_close(aTHX_ f);
     if (e->bufsv) {
+	if (e->base.buf && e->base.ptr > e->base.buf) {
+	    Perl_croak(aTHX_ "Close with partial character");
+	}
 	SvREFCNT_dec(e->bufsv);
 	e->bufsv = Nullsv;
     }
@@ -402,6 +411,9 @@ PerlIOEncode_tell(pTHX_ PerlIO * f)
        the UTF8 we have in bufefr and then ask layer below
      */
     PerlIO_flush(f);
+    if (b->buf && b->ptr > b->buf) {
+	Perl_croak(aTHX_ "Cannot tell at partial character");
+    }
     return PerlIO_tell(PerlIONext(f));
 }
 
@@ -422,7 +434,7 @@ PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
 PerlIO_funcs PerlIO_encode = {
     "encoding",
     sizeof(PerlIOEncode),
-    PERLIO_K_BUFFERED,
+    PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
     PerlIOEncode_pushed,
     PerlIOEncode_popped,
     PerlIOBuf_open,
@@ -470,6 +482,7 @@ Encode_XSEncoding(pTHX_ encode_t * enc)
 void
 call_failure(SV * routine, U8 * done, U8 * dest, U8 * orig)
 {
+ /* Exists for breakpointing */
 }
 
 static SV *
@@ -488,7 +501,7 @@ encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src,
 	int code;
 	while ((code = do_encode(dir, s, &slen, d, dlen, &dlen, !check))) {
 	    SvCUR_set(dst, dlen+ddone);
-	    SvPOK_on(dst);
+	    SvPOK_only(dst);
 
 #if 0
 	    Perl_warn(aTHX_ "code=%d @ s=%d/%d/%d d=%d/%d/%d",code,slen,sdone,tlen,dlen,ddone,SvLEN(dst)-1);
@@ -528,7 +541,7 @@ encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src,
 			UV ch =
 			    utf8n_to_uvuni(s + slen, (SvCUR(src) - slen),
 					   &clen, 0);
-			Perl_warner(aTHX_ WARN_UTF8,
+			Perl_warner(aTHX_ packWARN(WARN_UTF8),
 				    "\"\\N{U+%" UVxf
 				    "}\" does not map to %s", ch,
 				    enc->name[0]);
@@ -542,10 +555,12 @@ encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src,
 		    }
 		}
 		else {
-		    /* UTF-8 is supposed to be "Universal" so should not happen */
-		    Perl_croak(aTHX_ "%s '%.*s' does not map to UTF-8",
-			       enc->name[0], (int) (SvCUR(src) - slen),
-			       s + slen);
+		    /* UTF-8 is supposed to be "Universal" so should not happen
+		       for real characters, but some encodings have non-assigned
+		       codes which may occur.
+		     */
+		    Perl_croak(aTHX_ "%s \"\\x%02X\" does not map to Unicode (%d)",
+			       enc->name[0], (U8) s[slen], code);
 		}
 		break;
 
@@ -557,19 +572,18 @@ encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src,
 	    }
 	}
 	SvCUR_set(dst, dlen+ddone);
-	SvPOK_on(dst);
+	SvPOK_only(dst);
 	if (check) {
 	    sdone = SvCUR(src) - (slen+sdone);
 	    if (sdone) {
 		Move(s + slen, SvPVX(src), sdone , U8);
 	    }
 	    SvCUR_set(src, sdone);
-	    *SvEND(src) = '\0';
 	}
     }
     else {
 	SvCUR_set(dst, 0);
-	SvPOK_on(dst);
+	SvPOK_only(dst);
     }
     *SvEND(dst) = '\0';
     return dst;
@@ -580,6 +594,16 @@ MODULE = Encode		PACKAGE = Encode::XS	PREFIX = Method_
 PROTOTYPES: ENABLE
 
 void
+Method_name(obj)
+SV *	obj
+CODE:
+ {
+  encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
+  ST(0) = sv_2mortal(newSVpvn(enc->name[0],strlen(enc->name[0])));
+  XSRETURN(1);
+ }
+
+void
 Method_decode(obj,src,check = FALSE)
 SV *	obj
 SV *	src
@@ -758,7 +782,8 @@ BOOT:
 #if defined(USE_PERLIO) && !defined(USE_SFIO)
  PerlIO_define_layer(aTHX_ &PerlIO_encode);
 #endif
-#include "8859_def.h"
-#include "EBCDIC_def.h"
-#include "Symbols_def.h"
+/* #include "8859_def.h" */
+/* #include "EBCDIC_def.h" */
+/* #include "Symbols_def.h" */
+#include "defcodes_def.h"
 }