From: Nick Ing-Simmons Date: Sat, 20 Apr 2002 19:06:04 +0000 (+0000) Subject: Some tweaks for encodings which need lines. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=20de0cb2cf7a24aa48f2f9a26729f1a78e64f396;p=p5sagit%2Fp5-mst-13.2.git Some tweaks for encodings which need lines. Also disabled trial of using fallbacks. p4raw-id: //depot/perlio@16023 --- diff --git a/ext/PerlIO/encoding/encoding.pm b/ext/PerlIO/encoding/encoding.pm index 9aa0e9a..1d9c73f 100644 --- a/ext/PerlIO/encoding/encoding.pm +++ b/ext/PerlIO/encoding/encoding.pm @@ -1,7 +1,8 @@ package PerlIO::encoding; -our $VERSION = '0.02'; +our $VERSION = '0.03'; use XSLoader (); -use Encode; +use Encode (); # Load but do not import anything. +our $check; XSLoader::load 'PerlIO::encoding'; 1; __END__ @@ -15,6 +16,9 @@ PerlIO::encoding - encoding layer open($f, "<:encoding(foo)", "infoo"); open($f, ">:encoding(bar)", "outbar"); + use Encode; + $PerlIO::encoding::check = Encode::FB_PERLQQ(); + =head1 DESCRIPTION Open a filehandle with a transparent encoding filter. @@ -24,6 +28,10 @@ character set and encoding to Perl string data (Unicode and Perl's internal Unicode encoding, UTF-8). On output, convert Perl string data into the specified character set and encoding. +When the layer is pushed the current value of C<$PerlIO::encoding::check> +is saved and used as the check argument when calling the Encodings +encode and decode. + =head1 SEE ALSO L, L, L, L diff --git a/ext/PerlIO/encoding/encoding.xs b/ext/PerlIO/encoding/encoding.xs index ea15e56..5bdc0c7 100644 --- a/ext/PerlIO/encoding/encoding.xs +++ b/ext/PerlIO/encoding/encoding.xs @@ -45,11 +45,16 @@ typedef struct { SV *dataSV; /* data we have read from layer below */ SV *enc; /* the encoding object */ SV *chk; /* CHECK in Encode methods */ + int flags; /* Flags currently just needs lines */ } PerlIOEncode; +#define NEEDS_LINES 1 -#define ENCODE_FB_QUIET "Encode::FB_QUIET" - +#if 0 +#define OUR_ENCODE_FB "Encode::FB_DEFAULT" +#else +#define OUR_ENCODE_FB "Encode::FB_QUIET" +#endif SV * PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) @@ -78,21 +83,12 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg) PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); dSP; IV code; + SV *result = Nullsv; code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv); ENTER; SAVETMPS; PUSHMARK(sp); - PUTBACK; - if (call_pv(ENCODE_FB_QUIET, G_SCALAR|G_NOARGS) != 1) { - Perl_die(aTHX_ "Call to Encode::FB_QUIET failed!"); - code = -1; - } - SPAGAIN; - e->chk = newSVsv(POPs); - PUTBACK; - - PUSHMARK(sp); XPUSHs(arg); PUTBACK; if (call_pv("Encode::find_encoding", G_SCALAR) != 1) { @@ -101,20 +97,55 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg) return -1; } SPAGAIN; - e->enc = POPs; + result = POPs; PUTBACK; - if (!SvROK(e->enc)) { + if (!SvROK(result) || !SvOBJECT(SvRV(result))) { e->enc = Nullsv; - errno = EINVAL; Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"", - arg); + arg); + errno = EINVAL; code = -1; } else { - SvREFCNT_inc(e->enc); +#ifdef USE_NEW_SEQUENCE + PUSHMARK(sp); + XPUSHs(result); + PUTBACK; + if (call_method("new_sequence",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) { + Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support new_sequence", + arg); + } + else { + SPAGAIN; + result = POPs; + PUTBACK; + } +#endif + e->enc = newSVsv(result); + PUSHMARK(sp); + XPUSHs(e->enc); + PUTBACK; + if (call_method("needs_lines",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) { + Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support needs_lines", + arg); + } + else { + SPAGAIN; + result = POPs; + PUTBACK; + if (SvTRUE(result)) { + e->flags |= NEEDS_LINES; + } + } PerlIOBase(f)->flags |= PERLIO_F_UTF8; + if (e->flags & NEEDS_LINES) { + PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; + } } + + e->chk = newSVsv(get_sv("PerlIO::encoding::check",0)); + FREETMPS; LEAVE; return code; @@ -136,6 +167,10 @@ PerlIOEncode_popped(pTHX_ PerlIO * f) SvREFCNT_dec(e->dataSV); e->dataSV = Nullsv; } + if (e->chk) { + SvREFCNT_dec(e->chk); + e->dataSV = Nullsv; + } return 0; } @@ -210,9 +245,9 @@ PerlIOEncode_fill(pTHX_ PerlIO * f) avail = 0; } } - if (avail > 0) { + if (avail > 0 || (e->flags & NEEDS_LINES)) { STDCHAR *ptr = PerlIO_get_ptr(n); - SSize_t use = avail; + SSize_t use = (avail >= 0) ? avail : 0; SV *uni; char *s; STRLEN len = 0; @@ -223,12 +258,45 @@ PerlIOEncode_fill(pTHX_ PerlIO * f) if (SvTYPE(e->dataSV) < SVt_PV) { sv_upgrade(e->dataSV,SVt_PV); } + if (e->flags & NEEDS_LINES) { + /* Encoding needs whole lines (e.g. iso-2022-*) + search back from end of available data for + and line marker + */ + STDCHAR *nl = ptr+use-1; + while (nl >= ptr) { + if (*nl == '\n') { + break; + } + nl--; + } + if (nl >= ptr && *nl == '\n') { + /* found a line - take up to and including that */ + use = (nl+1)-ptr; + } + else if (avail > 0) { + /* No line, but not EOF - append avail to the pending data */ + sv_catpvn(e->dataSV, ptr, use); + PerlIO_set_ptrcnt(n, ptr+use, 0); + goto retry; + } + else if (!SvCUR(e->dataSV)) { + goto end_of_file; + } + } if (SvCUR(e->dataSV)) { /* something left over from last time - create a normal SV with new data appended */ if (use + SvCUR(e->dataSV) > e->base.bufsiz) { - use = e->base.bufsiz - SvCUR(e->dataSV); + if (e->flags & NEEDS_LINES) { + /* Have to grow buffer */ + e->base.bufsiz = use + SvCUR(e->dataSV); + PerlIOEncode_get_base(aTHX_ f); + } + else { + use = e->base.bufsiz - SvCUR(e->dataSV); + } } sv_catpvn(e->dataSV,(char*)ptr,use); } @@ -238,7 +306,14 @@ PerlIOEncode_fill(pTHX_ PerlIO * f) Safefree(SvPVX(e->dataSV)); } if (use > e->base.bufsiz) { - use = e->base.bufsiz; + if (e->flags & NEEDS_LINES) { + /* Have to grow buffer */ + e->base.bufsiz = use; + PerlIOEncode_get_base(aTHX_ f); + } + else { + use = e->base.bufsiz; + } } SvPVX(e->dataSV) = (char *) ptr; SvLEN(e->dataSV) = 0; /* Hands off sv.c - it isn't yours */ @@ -300,6 +375,7 @@ PerlIOEncode_fill(pTHX_ PerlIO * f) return code; } else { + end_of_file: if (avail == 0) PerlIOBase(f)->flags |= PERLIO_F_EOF; else @@ -449,6 +525,16 @@ PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o, return f; } +SSize_t +PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) +{ + SSize_t size = PerlIOBuf_write(aTHX_ f, vbuf, count); + PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); + if (e->flags & NEEDS_LINES) { + } + return size; +} + PerlIO_funcs PerlIO_encode = { "encoding", sizeof(PerlIOEncode), @@ -461,7 +547,7 @@ PerlIO_funcs PerlIO_encode = { PerlIOEncode_dup, PerlIOBuf_read, PerlIOBuf_unread, - PerlIOBuf_write, + PerlIOEncode_write, PerlIOBuf_seek, PerlIOEncode_tell, PerlIOEncode_close, @@ -485,6 +571,19 @@ PROTOTYPES: ENABLE BOOT: { + SV *sv = get_sv("PerlIO::encoding::check", GV_ADD|GV_ADDMULTI); + sv_setiv(sv,0); + 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; + } #ifdef PERLIO_LAYERS PerlIO_define_layer(aTHX_ &PerlIO_encode); #endif