/*
- $Id: Encode.xs,v 1.45 2002/05/07 16:22:42 dankogai Exp dankogai $
+ $Id: Encode.xs,v 1.46 2002/05/20 15:25:44 dankogai Exp dankogai $
*/
#define PERL_NO_GET_CONTEXT
goto ENCODE_END;
}
- while (code = do_encode(dir, s, &slen, d, dlen, &dlen, !check))
+ while( (code = do_encode(dir, s, &slen, d, dlen, &dlen, !check)) )
{
SvCUR_set(dst, dlen+ddone);
SvPOK_only(dst);
else {
if (check & ENCODE_DIE_ON_ERR){
Perl_croak(aTHX_ ERR_DECODE_NOMAP,
- PTR2UV(enc->name[0]), (U8)s[slen]);
+ enc->name[0], (UV)s[slen]);
return &PL_sv_undef; /* never reaches but be safe */
}
if (check & ENCODE_WARN_ON_ERR){
Perl_warner(
aTHX_ packWARN(WARN_UTF8),
ERR_DECODE_NOMAP,
- PTR2UV(enc->name[0]), (U8)s[slen]);
+ enc->name[0], (UV)s[slen]);
}
if (check & ENCODE_RETURN_ON_ERR){
goto ENCODE_SET_SRC;
return dst;
}
+MODULE = Encode PACKAGE = Encode::utf8 PREFIX = Method_
+
+void
+Method_decode(obj,src,check = 0)
+SV * obj
+SV * src
+int check
+CODE:
+{
+ STRLEN slen;
+ U8 *s = (U8 *) SvPV(src, slen);
+ U8 *e = (U8 *) SvEND(src);
+ SV *dst = newSV(slen);
+ SvPOK_only(dst);
+ SvCUR_set(dst,0);
+ while (s < e) {
+ if (UTF8_IS_INVARIANT(*s) || UTF8_IS_START(*s)) {
+ U8 skip = UTF8SKIP(s);
+ if ((s + skip) > e) {
+ /* Partial character - done */
+ break;
+ }
+ 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 */
+ 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* perlqq = newSVpvf("\\x%02" UVXf, (UV)*s);
+ sv_catsv(dst, perlqq);
+ SvREFCNT_dec(perlqq);
+ } else {
+ sv_catpv(dst, FBCHAR_UTF8);
+ }
+ s++;
+ }
+ *SvEND(dst) = '\0';
+
+ /* Clear out translated part of source unless asked not to */
+ if (check && !(check & ENCODE_LEAVE_SRC)){
+ slen = e-s;
+ if (slen) {
+ sv_setpvn(src, (char*)s, slen);
+ }
+ SvCUR_set(src, slen);
+ }
+ SvUTF8_on(dst);
+ ST(0) = sv_2mortal(dst);
+ XSRETURN(1);
+}
+
+void
+Method_encode(obj,src,check = 0)
+SV * obj
+SV * src
+int check
+CODE:
+{
+ STRLEN slen;
+ U8 *s = (U8 *) SvPV(src, slen);
+ U8 *e = (U8 *) SvEND(src);
+ SV *dst = newSV(slen);
+ if (SvUTF8(src)) {
+ /* Already encoded - trust it and just copy the octets */
+ sv_setpvn(dst,(char *)s,(e-s));
+ s = e;
+ }
+ else {
+ /* Native bytes - can always encode */
+ U8 *d = (U8 *) SvGROW(dst,2*slen);
+ while (s < e) {
+ UV uv = NATIVE_TO_UNI((UV) *s++);
+ if (UNI_IS_INVARIANT(uv))
+ *d++ = (U8)UTF_TO_NATIVE(uv);
+ else {
+ *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
+ *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
+ }
+ }
+ SvCUR_set(dst, d- (U8 *)SvPVX(dst));
+ *SvEND(dst) = '\0';
+ }
+
+ /* Clear out translated part of source unless asked not to */
+ if (check && !(check & ENCODE_LEAVE_SRC)){
+ slen = e-s;
+ if (slen) {
+ sv_setpvn(src, (char*)s, slen);
+ }
+ SvCUR_set(src, slen);
+ }
+ SvPOK_only(dst);
+ SvUTF8_off(dst);
+ ST(0) = sv_2mortal(dst);
+ XSRETURN(1);
+}
+
MODULE = Encode PACKAGE = Encode::XS PREFIX = Method_
PROTOTYPES: ENABLE
SV * obj
CODE:
{
- encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
+ /* encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); */
ST(0) = &PL_sv_no;
XSRETURN(1);
}
SV * obj
CODE:
{
- encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
+ /* encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); */
/* require_pv(PERLIO_FILENAME); */
eval_pv("require PerlIO::encoding", 0);