X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FPerlIO%2Fencoding%2Fencoding.xs;h=df911ed705a59884f0a79841c55fefa308d2b7d8;hb=15af043884e0520355045b5d53efce3cdf6f3094;hp=a864c8aa18e92f696ae933d9ae006d5e1c677c7b;hpb=5f682c053747030c533c13711625f2209c5ae077;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/PerlIO/encoding/encoding.xs b/ext/PerlIO/encoding/encoding.xs index a864c8a..df911ed 100644 --- a/ext/PerlIO/encoding/encoding.xs +++ b/ext/PerlIO/encoding/encoding.xs @@ -1,5 +1,5 @@ /* - * $Id$ + * $Id: encoding.xs,v 0.3 2002/04/21 22:14:41 dankogai Exp $ */ #define PERL_NO_GET_CONTEXT @@ -8,6 +8,8 @@ #include "XSUB.h" #define U8 U8 +#define OUR_DEFAULT_FB "Encode::PERLQQ" + #if defined(USE_PERLIO) && !defined(USE_SFIO) /* Define an encoding "layer" in the perliol.h sense. @@ -50,12 +52,6 @@ typedef struct { #define NEEDS_LINES 1 -#if 0 -#define OUR_ENCODE_FB "Encode::FB_PERLQQ" -#else -#define OUR_ENCODE_FB "Encode::FB_QUIET" -#endif - SV * PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) { @@ -63,6 +59,9 @@ PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) SV *sv = &PL_sv_undef; if (e->enc) { dSP; + /* Not 100% sure stack swap is right thing to do during dup ... */ + PUSHSTACKi(PERLSI_MAGIC); + SPAGAIN; ENTER; SAVETMPS; PUSHMARK(sp); @@ -73,6 +72,9 @@ PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) sv = newSVsv(POPs); PUTBACK; } + FREETMPS; + LEAVE; + POPSTACK; } return sv; } @@ -82,9 +84,12 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg) { PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); dSP; - IV code; + IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv); SV *result = Nullsv; - code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv); + + PUSHSTACKi(PERLSI_MAGIC); + SPAGAIN; + ENTER; SAVETMPS; @@ -141,10 +146,11 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg) PerlIOBase(f)->flags |= PERLIO_F_UTF8; } - e->chk = newSVsv(get_sv("PerlIO::encoding::check",0)); + e->chk = newSVsv(get_sv("PerlIO::encoding::fallback", 0)); FREETMPS; LEAVE; + POPSTACK; return code; } @@ -166,7 +172,7 @@ PerlIOEncode_popped(pTHX_ PerlIO * f) } if (e->chk) { SvREFCNT_dec(e->chk); - e->dataSV = Nullsv; + e->chk = Nullsv; } return 0; } @@ -216,6 +222,7 @@ PerlIOEncode_fill(pTHX_ PerlIO * f) IV code = 0; PerlIO *n; SSize_t avail; + if (PerlIO_flush(f) != 0) return -1; n = PerlIONext(f); @@ -228,6 +235,8 @@ PerlIOEncode_fill(pTHX_ PerlIO * f) Perl_die(aTHX_ "panic: cannot push :perlio for %p",f); } } + PUSHSTACKi(PERLSI_MAGIC); + SPAGAIN; ENTER; SAVETMPS; retry: @@ -273,7 +282,7 @@ PerlIOEncode_fill(pTHX_ PerlIO * f) } else if (avail > 0) { /* No line, but not EOF - append avail to the pending data */ - sv_catpvn(e->dataSV, ptr, use); + sv_catpvn(e->dataSV, (char*)ptr, use); PerlIO_set_ptrcnt(n, ptr+use, 0); goto retry; } @@ -292,8 +301,8 @@ PerlIOEncode_fill(pTHX_ PerlIO * f) PerlIOEncode_get_base(aTHX_ f); } else { - use = e->base.bufsiz - SvCUR(e->dataSV); - } + use = e->base.bufsiz - SvCUR(e->dataSV); + } } sv_catpvn(e->dataSV,(char*)ptr,use); } @@ -309,8 +318,8 @@ PerlIOEncode_fill(pTHX_ PerlIO * f) PerlIOEncode_get_base(aTHX_ f); } else { - use = e->base.bufsiz; - } + use = e->base.bufsiz; + } } SvPVX(e->dataSV) = (char *) ptr; SvLEN(e->dataSV) = 0; /* Hands off sv.c - it isn't yours */ @@ -367,18 +376,19 @@ PerlIOEncode_fill(pTHX_ PerlIO * f) PerlIO_set_ptrcnt(n, ptr+use, (avail-use)); goto retry; } - FREETMPS; - LEAVE; - return code; } else { end_of_file: + code = -1; if (avail == 0) PerlIOBase(f)->flags |= PERLIO_F_EOF; else PerlIOBase(f)->flags |= PERLIO_F_ERROR; - return -1; } + FREETMPS; + LEAVE; + POPSTACK; + return code; } IV @@ -386,14 +396,17 @@ PerlIOEncode_flush(pTHX_ PerlIO * f) { PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); IV code = 0; - if (e->bufsv && (e->base.ptr > e->base.buf)) { + + if (e->bufsv) { dSP; SV *str; char *s; STRLEN len; SSize_t count = 0; - if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) { - /* Write case encode the buffer and write() to layer below */ + if ((PerlIOBase(f)->flags & PERLIO_F_WRBUF) && (e->base.ptr > e->base.buf)) { + /* Write case - encode the buffer and write() to layer below */ + PUSHSTACKi(PERLSI_MAGIC); + SPAGAIN; ENTER; SAVETMPS; PUSHMARK(sp); @@ -411,11 +424,12 @@ PerlIOEncode_flush(pTHX_ PerlIO * f) PUTBACK; s = SvPV(str, len); count = PerlIO_write(PerlIONext(f),s,len); - if (count != len) { + if ((STRLEN)count != len) { code = -1; } FREETMPS; LEAVE; + POPSTACK; if (PerlIO_flush(PerlIONext(f)) != 0) { code = -1; } @@ -425,21 +439,25 @@ PerlIOEncode_flush(pTHX_ PerlIO * f) return code; } } - else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { + else if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { /* read case */ /* if we have any untranslated stuff then unread that first */ + /* FIXME - unread is fragile is there a better way ? */ if (e->dataSV && SvCUR(e->dataSV)) { s = SvPV(e->dataSV, len); count = PerlIO_unread(PerlIONext(f),s,len); - if (count != len) { + if ((STRLEN)count != len) { code = -1; } + SvCUR_set(e->dataSV,0); } /* See if there is anything left in the buffer */ if (e->base.ptr < e->base.end) { /* Bother - have unread data. re-encode and unread() to layer below */ + PUSHSTACKi(PERLSI_MAGIC); + SPAGAIN; ENTER; SAVETMPS; str = sv_newmortal(); @@ -462,11 +480,12 @@ PerlIOEncode_flush(pTHX_ PerlIO * f) PUTBACK; s = SvPV(str, len); count = PerlIO_unread(PerlIONext(f),s,len); - if (count != len) { + if ((STRLEN)count != len) { code = -1; } FREETMPS; LEAVE; + POPSTACK; } } e->base.ptr = e->base.end = e->base.buf; @@ -479,8 +498,18 @@ IV PerlIOEncode_close(pTHX_ PerlIO * f) { PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); - IV code = PerlIOBase_close(aTHX_ f); + IV code; + if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { + /* Discard partial character */ + if (e->dataSV) { + SvCUR_set(e->dataSV,0); + } + /* Don't back decode and unread any pending data */ + e->base.ptr = e->base.end = e->base.buf; + } + code = PerlIOBase_close(aTHX_ f); if (e->bufsv) { + /* This should only fire for write case */ if (e->base.buf && e->base.ptr > e->base.buf) { Perl_croak(aTHX_ "Close with partial character"); } @@ -561,6 +590,7 @@ PerlIO_funcs PerlIO_encode = { PerlIOEncode_pushed, PerlIOEncode_popped, PerlIOBuf_open, + NULL, /* binmode - always pop */ PerlIOEncode_getarg, PerlIOBase_fileno, PerlIOEncode_dup, @@ -590,20 +620,38 @@ PROTOTYPES: ENABLE BOOT: { - SV *sv = get_sv("PerlIO::encoding::check", GV_ADD|GV_ADDMULTI); - sv_setiv(sv,0); + SV *chk = get_sv("PerlIO::encoding::fallback", GV_ADD|GV_ADDMULTI); + /* + * we now "use Encode ()" here instead of + * PerlIO/encoding.pm. This avoids SEGV when ":encoding()" + * is invoked without prior "use Encode". -- dankogai + */ + PUSHSTACKi(PERLSI_MAGIC); + SPAGAIN; + if (!get_cv(OUR_DEFAULT_FB, 0)) { +#if 0 + /* This would just be an irritant now loading works */ + Perl_warner(aTHX_ packWARN(WARN_IO), ":encoding without 'use Encode'"); +#endif + ENTER; + /* Encode needs a lot of stack - it is likely to move ... */ + PUTBACK; + /* The SV is magically freed by load_module */ + load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("Encode", 6), Nullsv, Nullsv); + SPAGAIN; + LEAVE; + } PUSHMARK(sp); PUTBACK; - if (call_pv(OUR_ENCODE_FB, G_SCALAR) != 1) { - Perl_warner(aTHX_ packWARN(WARN_IO), - "Call to %s failed!",OUR_ENCODE_FB); - } - else { - SPAGAIN; - sv_setsv(sv,POPs); - PUTBACK; + if (call_pv(OUR_DEFAULT_FB, G_SCALAR) != 1) { + /* should never happen */ + Perl_die(aTHX_ "%s did not return a value",OUR_DEFAULT_FB); } + SPAGAIN; + sv_setsv(chk, POPs); + PUTBACK; #ifdef PERLIO_LAYERS - PerlIO_define_layer(aTHX_ &PerlIO_encode); + PerlIO_define_layer(aTHX_ &PerlIO_encode); #endif + POPSTACK; }