Upgrade to Encode 0.96, from Dan Kogai.

[p5sagit/p5-mst-13.2.git] / ext / Encode / Encode.xs

diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs
index 52fee5a..9bd8a4c 100644 (file)
--- 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"
 }