X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FEncode%2FEncode.xs;h=1424071f3a72da1a85dfeda47849e7e30dd39d4e;hb=4ac71550d23cca4632a2bcdfcb1d83a6bf705e45;hp=38e83dce5de54fbd2382db194d966794ce61c108;hpb=656ebd29b326e7cb4e9181b77b10fccb1c1df3c6;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs
index 38e83dc..1424071 100644
--- a/ext/Encode/Encode.xs
+++ b/ext/Encode/Encode.xs
@@ -1,5 +1,5 @@
 /*
- $Id: Encode.xs,v 2.10 2006/06/03 20:28:48 dankogai Exp dankogai $
+ $Id: Encode.xs,v 2.14 2007/05/29 18:15:32 dankogai Exp $
  */
 
 #define PERL_NO_GET_CONTEXT
@@ -35,8 +35,6 @@ UNIMPLEMENTED(_encoded_bytes_to_utf8, I32)
                                 UTF8_ALLOW_NON_CONTINUATION |     \
                                 UTF8_ALLOW_LONG))
 
-static SV* fallback_cb = (SV*)NULL ;
-
 void
 Encode_XSEncoding(pTHX_ encode_t * enc)
 {
@@ -66,11 +64,11 @@ call_failure(SV * routine, U8 * done, U8 * dest, U8 * orig)
 #define ERR_DECODE_NOMAP "%s \"\\x%02" UVXf "\" does not map to Unicode"
 
 static SV *
-do_fallback_cb(pTHX_ UV ch)
+do_fallback_cb(pTHX_ UV ch, SV *fallback_cb)
 {
     dSP;
     int argc;
-    SV* retval;
+    SV *temp, *retval;
     ENTER;
     SAVETMPS;
     PUSHMARK(sp);
@@ -79,18 +77,22 @@ do_fallback_cb(pTHX_ UV ch)
     argc = call_sv(fallback_cb, G_SCALAR);
     SPAGAIN;
     if (argc != 1){
-    croak("fallback sub must return scalar!");
+	croak("fallback sub must return scalar!");
     }
-    retval = newSVsv(POPs);
+    temp = newSVsv(POPs);
     PUTBACK;
     FREETMPS;
     LEAVE;
+    retval = newSVpv("",0);
+    sv_catsv(retval, temp);
+    SvREFCNT_dec(temp);
     return retval;
 }
 
 static SV *
 encode_method(pTHX_ const encode_t * enc, const encpage_t * dir, SV * src,
-          int check, STRLEN * offset, SV * term, int * retcode)
+	      int check, STRLEN * offset, SV * term, int * retcode, 
+	      SV *fallback_cb)
 {
     STRLEN slen;
     U8 *s = (U8 *) SvPV(src, slen);
@@ -192,8 +194,9 @@ encode_method(pTHX_ const encode_t * enc, const encpage_t * dir, SV * src,
         }
         if (check & (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
             SV* subchar = 
-            (fallback_cb != (SV*)NULL) ? do_fallback_cb(aTHX_ ch) :
-            newSVpvf(check & ENCODE_PERLQQ ? "\\x{%04"UVxf"}" :
+            (fallback_cb != &PL_sv_undef)
+		? do_fallback_cb(aTHX_ ch, fallback_cb)
+		: newSVpvf(check & ENCODE_PERLQQ ? "\\x{%04"UVxf"}" :
                  check & ENCODE_HTMLCREF ? "&#%" UVuf ";" :
                  "&#x%" UVxf ";", (UV)ch);
             sdone += slen + clen;
@@ -226,9 +229,9 @@ encode_method(pTHX_ const encode_t * enc, const encpage_t * dir, SV * src,
         if (check &
             (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
             SV* subchar = 
-            (fallback_cb != (SV*)NULL) ? 
-            do_fallback_cb(aTHX_ (UV)s[slen]) :
-            newSVpvf("\\x%02" UVXf, (UV)s[slen]);
+            (fallback_cb != &PL_sv_undef)
+		? do_fallback_cb(aTHX_ (UV)s[slen], fallback_cb) 
+		: newSVpvf("\\x%02" UVXf, (UV)s[slen]);
             sdone += slen + 1;
             ddone += dlen + SvCUR(subchar);
             sv_catsv(dst, subchar);
@@ -333,7 +336,7 @@ process_utf8(pTHX_ SV* dst, U8* s, U8* e, int check,
                                );
 #if 1 /* perl-5.8.6 and older do not check UTF8_ALLOW_LONG */
         if (strict && uv > PERL_UNICODE_MAX)
-        ulen = -1;
+        ulen = (STRLEN) -1;
 #endif
             if (ulen == -1) {
                 if (strict) {
@@ -481,7 +484,8 @@ CODE:
     	/* Native bytes - can always encode */
     U8 *d = (U8 *) SvGROW(dst, 2*slen+1); /* +1 or assertion will botch */
     	while (s < e) {
-    	    UV uv = NATIVE_TO_UNI((UV) *s++);
+    	    UV uv = NATIVE_TO_UNI((UV) *s);
+	    s++; /* Above expansion of NATIVE_TO_UNI() is safer this way. */
             if (UNI_IS_INVARIANT(uv))
             	*d++ = (U8)UTF_TO_NATIVE(uv);
             else {
@@ -538,23 +542,31 @@ CODE:
 }
 
 void
-Method_cat_decode(obj, dst, src, off, term, check = 0)
+Method_cat_decode(obj, dst, src, off, term, check_sv = &PL_sv_no)
 SV *	obj
 SV *	dst
 SV *	src
 SV *	off
 SV *	term
-int	check
+SV *    check_sv
 CODE:
 {
+    int check;
+    SV *fallback_cb = &PL_sv_undef;
     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
     STRLEN offset = (STRLEN)SvIV(off);
     int code = 0;
     if (SvUTF8(src)) {
     	sv_utf8_downgrade(src, FALSE);
     }
+    if (SvROK(check_sv)){
+	fallback_cb = check_sv;
+	check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as FB_PERLQQ */
+    }else{
+	check = SvIV(check_sv);
+    }
     sv_catsv(dst, encode_method(aTHX_ enc, enc->t_utf8, src, check,
-                &offset, term, &code));
+                &offset, term, &code, fallback_cb));
     SvIV_set(off, (IV)offset);
     if (code == ENCODE_FOUND_TERM) {
     ST(0) = &PL_sv_yes;
@@ -572,29 +584,23 @@ SV *	check_sv
 CODE:
 {
     int check;
+    SV *fallback_cb = &PL_sv_undef;
     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
     if (SvUTF8(src)) {
     	sv_utf8_downgrade(src, FALSE);
     }
     if (SvROK(check_sv)){
-    if (fallback_cb == (SV*)NULL){
-            fallback_cb = newSVsv(check_sv); /* First time */
-        }else{
-            SvSetSV(fallback_cb, check_sv); /* Been here before */
-    }
-    check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as FB_PERLQQ */
+	fallback_cb = check_sv;
+	check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as FB_PERLQQ */
     }else{
-    fallback_cb = (SV*)NULL;
-    check = SvIV(check_sv);
+	check = SvIV(check_sv);
     }
     ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check,
-              NULL, Nullsv, NULL);
+              NULL, Nullsv, NULL, fallback_cb);
     SvUTF8_on(ST(0));
     XSRETURN(1);
 }
 
-
-
 void
 Method_encode(obj,src,check_sv = &PL_sv_no)
 SV *	obj
@@ -603,21 +609,17 @@ SV *	check_sv
 CODE:
 {
     int check;
+    SV *fallback_cb = &PL_sv_undef;
     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
     sv_utf8_upgrade(src);
     if (SvROK(check_sv)){
-    if (fallback_cb == (SV*)NULL){
-            fallback_cb = newSVsv(check_sv); /* First time */
-        }else{
-            SvSetSV(fallback_cb, check_sv); /* Been here before */
-    }
-    check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as FB_PERLQQ */
+	fallback_cb = check_sv;
+	check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as FB_PERLQQ */
     }else{
-    fallback_cb = (SV*)NULL;
-    check = SvIV(check_sv);
+	check = SvIV(check_sv);
     }
     ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check,
-              NULL, Nullsv, NULL);
+              NULL, Nullsv, NULL, fallback_cb);
     XSRETURN(1);
 }
 
@@ -649,6 +651,35 @@ CODE:
     XSRETURN(1);
 }
 
+void
+Method_mime_name(obj)
+SV *	obj
+CODE:
+{
+    encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
+    SV *retval;
+    eval_pv("require Encode::MIME::Name", 0);
+
+    if (SvTRUE(get_sv("@", 0))) {
+	ST(0) = &PL_sv_undef;
+    }else{
+	ENTER;
+	SAVETMPS;
+	PUSHMARK(sp);
+	XPUSHs(sv_2mortal(newSVpvn(enc->name[0], strlen(enc->name[0]))));
+	PUTBACK;
+	call_pv("Encode::MIME::Name::get_mime_name", G_SCALAR);
+	SPAGAIN;
+	retval = newSVsv(POPs);
+	PUTBACK;
+	FREETMPS;
+	LEAVE;
+	/* enc->name[0] */
+	ST(0) = retval;
+    }
+    XSRETURN(1);
+}
+
 MODULE = Encode         PACKAGE = Encode
 
 PROTOTYPES: ENABLE
@@ -756,15 +787,11 @@ CODE:
 {
     if (SvGMAGICAL(sv)) /* it could be $1, for example */
     sv = newSVsv(sv); /* GMAGIG will be done */
-    if (SvPOK(sv)) {
     RETVAL = SvUTF8(sv) ? TRUE : FALSE;
     if (RETVAL &&
         check  &&
         !is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
         RETVAL = FALSE;
-    } else {
-    RETVAL = FALSE;
-    }
     if (sv != ST(0))
     SvREFCNT_dec(sv); /* it was a temp copy */
 }