/*
- $Id: Encode.xs,v 2.1 2004/10/22 19:35:52 dankogai Exp $
+ $Id: Encode.xs,v 2.4 2005/05/16 18:46:36 dankogai Exp dankogai $
*/
#define PERL_NO_GET_CONTEXT
UNIMPLEMENTED(_encoded_utf8_to_bytes, I32)
UNIMPLEMENTED(_encoded_bytes_to_utf8, I32)
+#define UTF8_ALLOW_STRICT 0
+#define UTF8_ALLOW_NONSTRICT (UTF8_ALLOW_ANY & \
+ ~(UTF8_ALLOW_CONTINUATION | \
+ UTF8_ALLOW_NON_CONTINUATION | \
+ UTF8_ALLOW_LONG))
+
void
Encode_XSEncoding(pTHX_ encode_t * enc)
{
return dst;
}
-MODULE = Encode PACKAGE = Encode::utf8 PREFIX = Method_
-
-PROTOTYPES: DISABLE
+static bool
+strict_utf8(pTHX_ SV* sv)
+{
+ HV* hv;
+ SV** svp;
+ sv = SvRV(sv);
+ if (!sv || SvTYPE(sv) != SVt_PVHV)
+ return 0;
+ hv = (HV*)sv;
+ svp = hv_fetch(hv, "strict_utf8", 11, 0);
+ if (!svp)
+ return 0;
+ return SvTRUE(*svp);
+}
-void
-Method_renew(obj)
-SV * obj
-CODE:
+static U8*
+process_utf8(pTHX_ SV* dst, U8* s, U8* e, int check,
+ bool encode, bool strict, bool stop_at_partial)
{
- XSRETURN(1);
+ UV uv;
+ STRLEN ulen;
+
+ SvPOK_only(dst);
+ SvCUR_set(dst,0);
+
+ while (s < e) {
+ if (UTF8_IS_INVARIANT(*s)) {
+ sv_catpvn(dst, (char *)s, 1);
+ s++;
+ continue;
+ }
+
+ if (UTF8_IS_START(*s)) {
+ U8 skip = UTF8SKIP(s);
+ if ((s + skip) > e) {
+ /* Partial character */
+ /* XXX could check that rest of bytes are UTF8_IS_CONTINUATION(ch) */
+ if (stop_at_partial)
+ break;
+
+ goto malformed_byte;
+ }
+
+ uv = utf8n_to_uvuni(s, e - s, &ulen,
+ UTF8_CHECK_ONLY | (strict ? UTF8_ALLOW_STRICT :
+ UTF8_ALLOW_NONSTRICT)
+ );
+#if 1 /* perl-5.8.6 and older do not check UTF8_ALLOW_LONG */
+ if (strict && uv > PERL_UNICODE_MAX)
+ ulen = -1;
+#endif
+ if (ulen == -1) {
+ if (strict) {
+ uv = utf8n_to_uvuni(s, e - s, &ulen,
+ UTF8_CHECK_ONLY | UTF8_ALLOW_NONSTRICT);
+ if (ulen == -1)
+ goto malformed_byte;
+ goto malformed;
+ }
+ goto malformed_byte;
+ }
+
+
+ /* Whole char is good */
+ sv_catpvn(dst,(char *)s,skip);
+ s += skip;
+ continue;
+ }
+
+ /* If we get here there is something wrong with alleged UTF-8 */
+ malformed_byte:
+ uv = (UV)*s;
+ ulen = 1;
+
+ malformed:
+ if (check & ENCODE_DIE_ON_ERR){
+ if (encode)
+ Perl_croak(aTHX_ ERR_ENCODE_NOMAP, uv, "utf8");
+ else
+ Perl_croak(aTHX_ ERR_DECODE_NOMAP, "utf8", uv);
+ }
+ if (check & ENCODE_WARN_ON_ERR){
+ if (encode)
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ ERR_ENCODE_NOMAP, uv, "utf8");
+ else
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ ERR_DECODE_NOMAP, "utf8", uv);
+ }
+ if (check & ENCODE_RETURN_ON_ERR) {
+ break;
+ }
+ if (check & (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
+ SV* subchar = newSVpvf(check & ENCODE_PERLQQ ? (ulen == 1 ? "\\x%02" UVXf : "\\x{%04" UVXf "}"):
+ check & ENCODE_HTMLCREF ? "&#%" UVuf ";" :
+ "&#x%" UVxf ";", uv);
+ sv_catsv(dst, subchar);
+ SvREFCNT_dec(subchar);
+ } else {
+ sv_catpv(dst, FBCHAR_UTF8);
+ }
+ s += ulen;
+ }
+ *SvEND(dst) = '\0';
+
+ return s;
}
+
+MODULE = Encode PACKAGE = Encode::utf8 PREFIX = Method_
+
+PROTOTYPES: DISABLE
+
void
Method_decode_xs(obj,src,check = 0)
SV * obj
U8 *s = (U8 *) SvPV(src, slen);
U8 *e = (U8 *) SvEND(src);
SV *dst = newSV(slen>0?slen:1); /* newSV() abhors 0 -- inaba */
- SvPOK_only(dst);
- SvCUR_set(dst,0);
+
+ /*
+ * PerlIO check -- we assume the object is of PerlIO if renewed
+ */
+ int renewed = 0;
+ dSP; ENTER; SAVETMPS;
+ PUSHMARK(sp);
+ XPUSHs(obj);
+ PUTBACK;
+ if (call_method("renewed",G_SCALAR) == 1) {
+ SPAGAIN;
+ renewed = POPi;
+ PUTBACK;
+#if 0
+ fprintf(stderr, "renewed == %d\n", renewed);
+#endif
+ }
+ FREETMPS; LEAVE;
+ /* end PerlIO check */
+
if (SvUTF8(src)) {
s = utf8_to_bytes(s,&slen);
if (s) {
croak("Cannot decode string with wide characters");
}
}
- while (s < e) {
- if (UTF8_IS_INVARIANT(*s) || UTF8_IS_START(*s)) {
- U8 skip = UTF8SKIP(s);
- if ((s + skip) > e) {
- /* Partial character - done */
- goto decode_utf8_fallback;
- }
- else if (is_utf8_char(s)) {
- /* Whole char is good */
- sv_catpvn(dst,(char *)s,skip);
- s += skip;
- continue;
- }
- else {
- /* starts ok but isn't "good" */
- }
- }
- else {
- /* Invalid start byte */
- }
- /* If we get here there is something wrong with alleged UTF-8 */
- decode_utf8_fallback:
- if (check & ENCODE_DIE_ON_ERR){
- Perl_croak(aTHX_ ERR_DECODE_NOMAP, "utf8", (UV)*s);
- XSRETURN(0);
- }
- if (check & ENCODE_WARN_ON_ERR){
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
- ERR_DECODE_NOMAP, "utf8", (UV)*s);
- }
- if (check & ENCODE_RETURN_ON_ERR) {
- break;
- }
- if (check & (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
- SV* subchar = newSVpvf("\\x%02" UVXf, (UV)*s);
- sv_catsv(dst, subchar);
- SvREFCNT_dec(subchar);
- } else {
- sv_catpv(dst, FBCHAR_UTF8);
- }
- s++;
- }
- *SvEND(dst) = '\0';
+
+ s = process_utf8(aTHX_ dst, s, e, check, 0, strict_utf8(aTHX_ obj), renewed);
/* Clear out translated part of source unless asked not to */
if (check && !(check & ENCODE_LEAVE_SRC)){
U8 *e = (U8 *) SvEND(src);
SV *dst = newSV(slen>0?slen:1); /* newSV() abhors 0 -- inaba */
if (SvUTF8(src)) {
- /* Already encoded - trust it and just copy the octets */
- sv_setpvn(dst,(char *)s,(e-s));
- s = e;
+ /* Already encoded */
+ if (strict_utf8(aTHX_ obj)) {
+ s = process_utf8(aTHX_ dst, s, e, check, 1, 1, 0);
+ }
+ else {
+ /* trust it and just copy the octets */
+ sv_setpvn(dst,(char *)s,(e-s));
+ s = e;
+ }
}
else {
/* Native bytes - can always encode */
XSRETURN(1);
}
+int
+Method_renewed(obj)
+SV * obj
+CODE:
+ RETVAL = 0;
+OUTPUT:
+ RETVAL
+
void
Method_name(obj)
SV * obj
}
sv_catsv(dst, encode_method(aTHX_ enc, enc->t_utf8, src, check,
&offset, term, &code));
- SvIVX(off) = (IV)offset;
+ SvIV_set(off, (IV)offset);
if (code == ENCODE_FOUND_TERM) {
ST(0) = &PL_sv_yes;
}else{