X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FEncode%2FEncode.xs;h=cdb1965bdaa0e825c875b8af87897338e8cef67e;hb=38e01200a459ddde320bc183e649514489a7e488;hp=a7acd88e67268c5469780d6cb32eac05b89b56a6;hpb=0e06870bf080a38cda51c06c6612359afc2334e1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs index a7acd88..cdb1965 100644 --- a/ext/Encode/Encode.xs +++ b/ext/Encode/Encode.xs @@ -14,7 +14,7 @@ UNIMPLEMENTED(_encoded_utf8_to_bytes, I32) UNIMPLEMENTED(_encoded_bytes_to_utf8, I32) -#ifdef USE_PERLIO +#if defined(USE_PERLIO) && !defined(USE_SFIO) /* Define an encoding "layer" in the perliol.h sense. The layer defined here "inherits" in an object-oriented sense from the "perlio" layer with its PerlIOBuf_* "methods". @@ -60,16 +60,24 @@ PerlIOEncode_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len) ENTER; SAVETMPS; PUSHMARK(sp); - XPUSHs(sv_2mortal(newSVpv("Encode",0))); XPUSHs(sv_2mortal(newSVpvn(arg,len))); PUTBACK; - if (perl_call_method("getEncoding",G_SCALAR) != 1) - return -1; + if (perl_call_pv("Encode::find_encoding",G_SCALAR) != 1) + { + /* should never happen */ + Perl_die(aTHX_ "Encode::find_encoding did not return a value"); + return -1; + } SPAGAIN; e->enc = POPs; PUTBACK; if (!SvROK(e->enc)) - return -1; + { + e->enc = Nullsv; + errno = EINVAL; + Perl_warner(aTHX_ WARN_IO, "Cannot find encoding \"%.*s\"", (int) len, arg); + return -1; + } SvREFCNT_inc(e->enc); FREETMPS; LEAVE; @@ -158,7 +166,7 @@ PerlIOEncode_fill(PerlIO *f) XPUSHs(e->bufsv); XPUSHs(&PL_sv_yes); PUTBACK; - if (perl_call_method("toUnicode",G_SCALAR) != 1) + if (perl_call_method("decode",G_SCALAR) != 1) code = -1; SPAGAIN; uni = POPs; @@ -214,7 +222,7 @@ PerlIOEncode_flush(PerlIO *f) XPUSHs(e->bufsv); XPUSHs(&PL_sv_yes); PUTBACK; - if (perl_call_method("fromUnicode",G_SCALAR) != 1) + if (perl_call_method("encode",G_SCALAR) != 1) code = -1; SPAGAIN; str = POPs; @@ -316,15 +324,25 @@ PerlIO_funcs PerlIO_encode = { PerlIOBuf_get_cnt, PerlIOBuf_set_ptrcnt, }; -#endif +#endif /* encode layer */ void Encode_Define(pTHX_ encode_t *enc) { - HV *hash = get_hv("Encode::encoding",GV_ADD|GV_ADDMULTI); + dSP; HV *stash = gv_stashpv("Encode::XS", TRUE); SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash); - hv_store(hash,enc->name,strlen(enc->name),sv,0); + int i = 0; + PUSHMARK(sp); + XPUSHs(sv); + while (enc->name[i]) + { + const char *name = enc->name[i++]; + XPUSHs(sv_2mortal(newSVpvn(name,strlen(name)))); + } + PUTBACK; + call_pv("Encode::define_encoding",G_DISCARD); + SvREFCNT_dec(sv); } void call_failure (SV *routine, U8* done, U8* dest, U8* orig) {} @@ -367,8 +385,8 @@ encode_method(pTHX_ encode_t *enc, encpage_t *dir, SV *src, int check) if (!check && ckWARN_d(WARN_UTF8)) { STRLEN clen; - UV ch = utf8_to_uv(s+slen,(SvCUR(src)-slen),&clen,0); - Perl_warner(aTHX_ WARN_UTF8, "\"\\x{%x}\" does not map to %s", ch, enc->name); + UV ch = utf8n_to_uvuni(s+slen,(SvCUR(src)-slen),&clen,0); + Perl_warner(aTHX_ WARN_UTF8, "\"\\N{U+%"UVxf"}\" does not map to %s", ch, enc->name[0]); /* FIXME: Skip over the character, copy in replacement and continue * but that is messy so for now just fail. */ @@ -383,7 +401,7 @@ encode_method(pTHX_ encode_t *enc, encpage_t *dir, SV *src, int check) { /* UTF-8 is supposed to be "Universal" so should not happen */ Perl_croak(aTHX_ "%s '%.*s' does not map to UTF-8", - enc->name, (SvCUR(src)-slen),s+slen); + enc->name[0], (int)(SvCUR(src)-slen),s+slen); } break; @@ -391,13 +409,13 @@ encode_method(pTHX_ encode_t *enc, encpage_t *dir, SV *src, int check) if (!check && ckWARN_d(WARN_UTF8)) { Perl_warner(aTHX_ WARN_UTF8, "Partial %s character", - (dir == enc->f_utf8) ? "UTF-8" : enc->name); + (dir == enc->f_utf8) ? "UTF-8" : enc->name[0]); } return &PL_sv_undef; default: Perl_croak(aTHX_ "Unexpected code %d converting %s %s", - code, (dir == enc->f_utf8) ? "to" : "from",enc->name); + code, (dir == enc->f_utf8) ? "to" : "from",enc->name[0]); return &PL_sv_undef; } } @@ -438,7 +456,7 @@ bool sv_utf8_decode(sv) SV * sv -void +STRLEN sv_utf8_upgrade(sv) SV * sv @@ -447,12 +465,12 @@ sv_utf8_downgrade(sv,failok=0) SV * sv bool failok -MODULE = Encode PACKAGE = Encode::XS PREFIX = Encode_ +MODULE = Encode PACKAGE = Encode::XS PREFIX = Method_ PROTOTYPES: ENABLE void -Encode_toUnicode(obj,src,check = 0) +Method_decode(obj,src,check = 0) SV * obj SV * src int check @@ -465,7 +483,7 @@ CODE: } void -Encode_fromUnicode(obj,src,check = 0) +Method_encode(obj,src,check = 0) SV * obj SV * src int check @@ -569,88 +587,16 @@ _utf8_to_bytes(sv, ...) OUTPUT: RETVAL -SV * -_chars_to_utf8(sv, from, ...) - SV * sv - SV * from - CODE: - { - SV * check = items == 3 ? ST(2) : Nullsv; - RETVAL = &PL_sv_undef; - } - OUTPUT: - RETVAL - -SV * -_utf8_to_chars(sv, to, ...) - SV * sv - SV * to - CODE: - { - SV * check = items == 3 ? ST(2) : Nullsv; - RETVAL = &PL_sv_undef; - } - OUTPUT: - RETVAL - -SV * -_utf8_to_chars_check(sv, ...) - SV * sv - CODE: - { - SV * check = items == 2 ? ST(1) : Nullsv; - RETVAL = &PL_sv_undef; - } - OUTPUT: - RETVAL - -SV * -_bytes_to_chars(sv, from, ...) - SV * sv - SV * from - CODE: - { - SV * check = items == 3 ? ST(2) : Nullsv; - RETVAL = &PL_sv_undef; - } - OUTPUT: - RETVAL - -SV * -_chars_to_bytes(sv, to, ...) - SV * sv - SV * to - CODE: - { - SV * check = items == 3 ? ST(2) : Nullsv; - RETVAL = &PL_sv_undef; - } - OUTPUT: - RETVAL - -SV * -_from_to(sv, from, to, ...) - SV * sv - SV * from - SV * to - CODE: - { - SV * check = items == 4 ? ST(3) : Nullsv; - RETVAL = &PL_sv_undef; - } - OUTPUT: - RETVAL - bool -_is_utf8(sv, ...) - SV * sv +is_utf8(sv, check = FALSE) +SV * sv +bool check CODE: { - SV * check = items == 2 ? ST(1) : Nullsv; if (SvPOK(sv)) { - RETVAL = SvUTF8(sv) ? 1 : 0; + RETVAL = SvUTF8(sv) ? TRUE : FALSE; if (RETVAL && - SvTRUE(check) && + check && !is_utf8_string((U8*)SvPVX(sv), SvCUR(sv))) RETVAL = FALSE; } else { @@ -661,7 +607,7 @@ _is_utf8(sv, ...) RETVAL SV * -_on_utf8(sv) +_utf8_on(sv) SV * sv CODE: { @@ -677,7 +623,7 @@ _on_utf8(sv) RETVAL SV * -_off_utf8(sv) +_utf8_off(sv) SV * sv CODE: { @@ -692,22 +638,9 @@ _off_utf8(sv) OUTPUT: RETVAL -SV * -_utf_to_utf(sv, from, to, ...) - SV * sv - SV * from - SV * to - CODE: - { - SV * check = items == 4 ? ST(3) : Nullsv; - RETVAL = &PL_sv_undef; - } - OUTPUT: - RETVAL - BOOT: { -#ifdef USE_PERLIO +#if defined(USE_PERLIO) && !defined(USE_SFIO) PerlIO_define_layer(&PerlIO_encode); #endif #include "iso8859.def"