X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FEncode%2FEncode.xs;h=6e3684ef0dbfb921a2bed63d2ec7406587db645d;hb=0a1f2d144e4463451f8627bd1c6ca420a59b01b0;hp=cca1ddcd7b0e54cfc2fe351190508819a5f9aa1d;hpb=5fcc867f61c50d5a1d39c892190ca98e4c69a548;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs index cca1ddc..6e3684e 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". @@ -48,28 +48,58 @@ typedef struct SV * enc; } PerlIOEncode; +SV * +PerlIOEncode_getarg(PerlIO *f) +{ + PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); + SV *sv = &PL_sv_undef; + if (e->enc) + { + dSP; + ENTER; + SAVETMPS; + PUSHMARK(sp); + XPUSHs(e->enc); + PUTBACK; + if (perl_call_method("name",G_SCALAR) == 1) + { + SPAGAIN; + sv = newSVsv(POPs); + PUTBACK; + } + } + return sv; +} IV -PerlIOEncode_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len) +PerlIOEncode_pushed(PerlIO *f, const char *mode, SV *arg) { PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); dTHX; dSP; IV code; - code = PerlIOBuf_pushed(f,mode,Nullch,0); + code = PerlIOBuf_pushed(f,mode,Nullsv); ENTER; SAVETMPS; PUSHMARK(sp); - XPUSHs(sv_2mortal(newSVpv("Encode",0))); - XPUSHs(sv_2mortal(newSVpvn(arg,len))); + XPUSHs(arg); 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 \"%"SVf"\"", arg); + return -1; + } SvREFCNT_inc(e->enc); FREETMPS; LEAVE; @@ -158,7 +188,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; @@ -189,9 +219,11 @@ PerlIOEncode_flush(PerlIO *f) { PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); IV code = 0; - dTHX; - if (e->bufsv && (PerlIOBase(f)->flags & (PERLIO_F_RDBUF|PERLIO_F_WRBUF))) + if (e->bufsv && (PerlIOBase(f)->flags & (PERLIO_F_RDBUF|PERLIO_F_WRBUF)) + &&(e->base.ptr > e->base.buf) + ) { + dTHX; dSP; SV *str; char *s; @@ -214,7 +246,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; @@ -259,6 +291,7 @@ PerlIOEncode_close(PerlIO *f) Off_t PerlIOEncode_tell(PerlIO *f) { + dTHX; PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); /* Unfortunately the only way to get a postion is to back-translate, the UTF8-bytes we have buf..ptr and adjust accordingly. @@ -268,7 +301,7 @@ PerlIOEncode_tell(PerlIO *f) if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF) && b->ptr < b->end) { Size_t count = b->end - b->ptr; - PerlIO_push(f,&PerlIO_pending,"r",Nullch,0); + PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv); /* Save what we have left to read */ PerlIOSelf(f,PerlIOBuf)->bufsiz = count; PerlIO_unread(f,b->ptr,count); @@ -292,12 +325,11 @@ PerlIO_funcs PerlIO_encode = { "encoding", sizeof(PerlIOEncode), PERLIO_K_BUFFERED, - PerlIOBase_fileno, - PerlIOBuf_fdopen, - PerlIOBuf_open, - PerlIOBuf_reopen, PerlIOEncode_pushed, PerlIOEncode_popped, + PerlIOBuf_open, + PerlIOEncode_getarg, + PerlIOBase_fileno, PerlIOBuf_read, PerlIOBuf_unread, PerlIOBuf_write, @@ -309,22 +341,32 @@ PerlIO_funcs PerlIO_encode = { PerlIOBase_eof, PerlIOBase_error, PerlIOBase_clearerr, - PerlIOBuf_setlinebuf, + PerlIOBase_setlinebuf, PerlIOEncode_get_base, PerlIOBuf_bufsiz, PerlIOBuf_get_ptr, 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) {} @@ -340,10 +382,14 @@ encode_method(pTHX_ encode_t *enc, encpage_t *dir, SV *src, int check) U8 *d = (U8 *) SvGROW(dst, 2*slen+1); STRLEN dlen = SvLEN(dst); int code; - while ((code = do_encode(dir,s,&slen,d,dlen,&dlen))) + while ((code = do_encode(dir,s,&slen,d,dlen,&dlen,!check))) { SvCUR_set(dst,dlen); SvPOK_on(dst); + + if (code == ENCODE_FALLBACK) + break; + switch(code) { case ENCODE_NOSPACE: @@ -363,8 +409,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. */ @@ -379,7 +425,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; @@ -387,13 +433,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; } } @@ -408,18 +454,23 @@ encode_method(pTHX_ encode_t *enc, encpage_t *dir, SV *src, int check) SvCUR_set(src,SvCUR(src)-slen); } } + else + { + SvCUR_set(dst,slen); + SvPOK_on(dst); + } return dst; } -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 = FALSE) SV * obj SV * src -int check +bool check CODE: { encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); @@ -429,10 +480,10 @@ CODE: } void -Encode_fromUnicode(obj,src,check = 0) +Method_encode(obj,src,check = FALSE) SV * obj SV * src -int check +bool check CODE: { encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); @@ -533,88 +584,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 { @@ -625,7 +604,7 @@ _is_utf8(sv, ...) RETVAL SV * -_on_utf8(sv) +_utf8_on(sv) SV * sv CODE: { @@ -641,7 +620,7 @@ _on_utf8(sv) RETVAL SV * -_off_utf8(sv) +_utf8_off(sv) SV * sv CODE: { @@ -656,23 +635,10 @@ _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 - PerlIO_define_layer(&PerlIO_encode); +#if defined(USE_PERLIO) && !defined(USE_SFIO) + PerlIO_define_layer(aTHX_ &PerlIO_encode); #endif #include "iso8859.def" #include "EBCDIC.def"