Retract #15745 for now; won't work without more Encode fixes.

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

diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs
index bf2fd51..741b679 100644 (file)
--- a/ext/Encode/Encode.xs
+++ b/ext/Encode/Encode.xs
@@ -1,14 +1,18 @@
 #define PERL_NO_GET_CONTEXT
-
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
 #define U8 U8
 #include "encode.h"
-#include "8859.h"
-#include "EBCDIC.h"
-#include "Symbols.h"
+#include "def_t.h"
+
+#define ENCODE_XS_PROFILE 0 /* set 1 to profile.
+                              t/encoding.t dumps core because of
+                              Perl_warner and PerlIO don't work well */
 
+#define ENCODE_XS_USEFP   1 /* set 0 to disable floating point to calculate
+                              buffer size for encode_method().
+                              1 is recommended. 2 restores NI-S original  */
 
 #define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) {dTHX;   \
                          Perl_croak(aTHX_ "panic_unimplemented"); \
@@ -91,7 +95,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;
     }
@@ -494,7 +498,10 @@ encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src,
     STRLEN tlen  = slen;
     STRLEN ddone = 0;
     STRLEN sdone = 0;
-    SV *dst = sv_2mortal(newSV(slen+1));
+
+    /* We allocate slen+1.  
+        PerlIO dumps core if this value is smaller than this. */
+    SV *dst = sv_2mortal(newSV(slen+1)); 
     if (slen) {
        U8 *d = (U8 *) SvPVX(dst);
        STRLEN dlen = SvLEN(dst)-1;
@@ -503,8 +510,8 @@ encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src,
            SvCUR_set(dst, dlen+ddone);
            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);
+#if ENCODE_XS_PROFILE >= 3
+           Perl_warn(aTHX_ "code=%d @ s=%d/%d/%d d=%d/%d/%d\n",code,slen,sdone,tlen,dlen,ddone,SvLEN(dst)-1);
 #endif
        
            if (code == ENCODE_FALLBACK || code == ENCODE_PARTIAL)
@@ -512,18 +519,30 @@ encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src,
 
            switch (code) {
            case ENCODE_NOSPACE:
-               {
-                   STRLEN need ;
+           {   
+                   STRLEN more, sleft;
                    sdone += slen;
                    ddone += dlen;
-                   if (sdone) {
-                       need = (tlen*SvLEN(dst)+sdone-1)/sdone+UTF8_MAXLEN;
-                   }
-                   else {
-                       need = SvLEN(dst) + UTF8_MAXLEN;
+                   sleft = tlen - sdone;
+                   if (sdone) { /* has src ever been processed ? */
+#if   ENCODE_XS_USEFP == 2
+                           more = (1.0*tlen*SvLEN(dst)+sdone-1)/sdone
+                                   - SvLEN(dst);
+#elif ENCODE_XS_USEFP
+                           more = (1.0*SvLEN(dst)+1)/sdone * sleft;
+#else
+                           /* safe until SvLEN(dst) == MAX_INT/16 */
+                           more = (16*SvLEN(dst)+1)/sdone/16 * sleft;
+#endif
                    }
-               
-                   d = (U8 *) SvGROW(dst, need);
+                   more += UTF8_MAXLEN; /* insurance policy */
+#if ENCODE_XS_PROFILE >= 2
+                 Perl_warn(aTHX_ 
+                 "more=%d, sdone=%d, sleft=%d, SvLEN(dst)=%d\n",
+                           more, sdone, sleft, SvLEN(dst));
+#endif
+                   d = (U8 *) SvGROW(dst, SvLEN(dst) + more);
+                   /* dst need to grow need MORE bytes! */
                    if (ddone >= SvLEN(dst)) {
                        Perl_croak(aTHX_ "Destination couldn't be grown.");
                    }
@@ -532,7 +551,7 @@ encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src,
                    s   += slen;
                    slen = tlen-sdone;
                    continue;
-               }
+           }
 
            case ENCODE_NOREP:
                if (dir == enc->f_utf8) {
@@ -541,7 +560,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]);
@@ -555,10 +574,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;
 
@@ -574,7 +595,15 @@ encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src,
        if (check) {
            sdone = SvCUR(src) - (slen+sdone);
            if (sdone) {
+#if 1
+               /* FIXME: A Move() is dangerous - PV could be mmap'ed readonly
+                  SvOOK would be ideal - but sv_backoff does not understand SvLEN == 0
+                  type SVs and sv_clear() calls it ...
+                */
+                sv_setpvn(src, (char*)s+slen, sdone);
+#else
                Move(s + slen, SvPVX(src), sdone , U8);
+#endif
            }
            SvCUR_set(src, sdone);
        }
@@ -583,6 +612,16 @@ encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src,
        SvCUR_set(dst, 0);
        SvPOK_only(dst);
     }
+#if ENCODE_XS_PROFILE
+    if (SvCUR(dst) > SvCUR(src)){
+           Perl_warn(aTHX_ 
+                     "SvLEN(dst)=%d, SvCUR(dst)=%d. "
+                     "%d bytes unused(%f %%)\n",
+                     SvLEN(dst), SvCUR(dst), SvLEN(dst) - SvCUR(dst), 
+                     (SvLEN(dst) - SvCUR(dst))*1.0/SvLEN(dst)*100.0);
+           
+    }
+#endif      
     *SvEND(dst) = '\0';
     return dst;
 }
@@ -780,7 +819,5 @@ 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 "def_t.exh"
 }