X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FEncode%2FEncode.xs;h=f3e873883620707031279d50737d61c9dbe022c0;hb=fcf2db383b9625d65c84a8308e9be05a073bed3b;hp=a4670cddf1bc1af1cc5fd94a83bf5c0470cb9eb6;hpb=52744f63cab71e4f408a2490707f42c331bb389e;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs index a4670cd..f3e8738 100644 --- a/ext/Encode/Encode.xs +++ b/ext/Encode/Encode.xs @@ -1,3 +1,5 @@ +#define PERL_NO_GET_CONTEXT + #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -7,14 +9,15 @@ #include "EBCDIC.h" #include "Symbols.h" -#define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) { \ + +#define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) {dTHX; \ Perl_croak(aTHX_ "panic_unimplemented"); \ return (y)0; /* fool picky compilers */ \ } 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,25 +51,47 @@ typedef struct SV * enc; } PerlIOEncode; +SV * +PerlIOEncode_getarg(PerlIO *f) +{ + dTHX; + 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) + if (perl_call_pv("Encode::find_encoding",G_SCALAR) != 1) { /* should never happen */ - Perl_die(aTHX_ "Encode::getEncoding did not return a value"); + Perl_die(aTHX_ "Encode::find_encoding did not return a value"); return -1; } SPAGAIN; @@ -76,7 +101,7 @@ PerlIOEncode_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len) { e->enc = Nullsv; errno = EINVAL; - Perl_warner(aTHX_ WARN_IO, "Cannot find encoding \"%.*s\"", (int) len, arg); + Perl_warner(aTHX_ WARN_IO, "Cannot find encoding \"%"SVf"\"", arg); return -1; } SvREFCNT_inc(e->enc); @@ -167,7 +192,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; @@ -198,9 +223,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; @@ -223,7 +250,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; @@ -268,6 +295,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. @@ -277,7 +305,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); @@ -301,12 +329,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, @@ -318,22 +345,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) {} @@ -376,8 +413,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{%"UVxf"}\" 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. */ @@ -392,7 +429,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, (int)(SvCUR(src)-slen),s+slen); + enc->name[0], (int)(SvCUR(src)-slen),s+slen); } break; @@ -400,13 +437,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; } } @@ -421,50 +458,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 PREFIX = sv_ - -void -valid_utf8(sv) -SV * sv -CODE: - { - STRLEN len; - char *s = SvPV(sv,len); - if (!SvUTF8(sv) || is_utf8_string((U8*)s,len)) - XSRETURN_YES; - else - XSRETURN_NO; - } - -void -sv_utf8_encode(sv) -SV * sv - -bool -sv_utf8_decode(sv) -SV * sv - -void -sv_utf8_upgrade(sv) -SV * sv - -bool -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 = FALSE) SV * obj SV * src -int check +bool check CODE: { encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); @@ -474,10 +484,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))); @@ -528,6 +538,7 @@ _utf8_to_bytes(sv, ...) STRLEN len; U8 *s = (U8*)SvPV(sv, len); + RETVAL = 0; if (SvTRUE(check)) { /* Must do things the slow way */ U8 *dest; @@ -578,88 +589,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 { @@ -670,7 +609,7 @@ _is_utf8(sv, ...) RETVAL SV * -_on_utf8(sv) +_utf8_on(sv) SV * sv CODE: { @@ -686,7 +625,7 @@ _on_utf8(sv) RETVAL SV * -_off_utf8(sv) +_utf8_off(sv) SV * sv CODE: { @@ -701,23 +640,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"