2 * $Id: encoding.xs,v 0.3 2002/04/21 22:14:41 dankogai Exp $
5 #define PERL_NO_GET_CONTEXT
11 #if defined(USE_PERLIO) && !defined(USE_SFIO)
13 /* Define an encoding "layer" in the perliol.h sense.
15 The layer defined here "inherits" in an object-oriented sense from
16 the "perlio" layer with its PerlIOBuf_* "methods". The
17 implementation is particularly efficient as until Encode settles
18 down there is no point in tryint to tune it.
20 The layer works by overloading the "fill" and "flush" methods.
22 "fill" calls "SUPER::fill" in perl terms, then calls the encode OO
23 perl API to convert the encoded data to UTF-8 form, then copies it
24 back to the buffer. The "base class's" read methods then see the
27 "flush" transforms the UTF-8 data deposited by the "base class's
28 write method in the buffer back into the encoded form using the
29 encode OO perl API, then copies data back into the buffer and calls
32 Note that "flush" is _also_ called for read mode - we still do the
33 (back)-translate so that the the base class's "flush" sees the
34 correct number of encoded chars for positioning the seek
35 pointer. (This double translation is the worst performance issue -
36 particularly with all-perl encode engine.)
43 PerlIOBuf base; /* PerlIOBuf stuff */
44 SV *bufsv; /* buffer seen by layers above */
45 SV *dataSV; /* data we have read from layer below */
46 SV *enc; /* the encoding object */
47 SV *chk; /* CHECK in Encode methods */
48 int flags; /* Flags currently just needs lines */
54 PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
56 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
57 SV *sv = &PL_sv_undef;
65 if (call_method("name", G_SCALAR) == 1) {
75 PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
77 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
79 IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
83 * we now "use Encode qw(:fallbacks)" here instead of
84 * PerlIO/encoding.pm. This avoids SEGV when ":encoding()"
85 * is invoked without prior "use Encode". -- dankogai
87 require_pv("Encode.pm");
95 if (call_pv("Encode::find_encoding", G_SCALAR) != 1) {
96 /* should never happen */
97 Perl_die(aTHX_ "Encode::find_encoding did not return a value");
104 if (!SvROK(result) || !SvOBJECT(SvRV(result))) {
106 Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
112 #ifdef USE_NEW_SEQUENCE
116 if (call_method("new_sequence",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
117 Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support new_sequence",
126 e->enc = newSVsv(result);
130 if (call_method("needs_lines",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
131 Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support needs_lines",
138 if (SvTRUE(result)) {
139 e->flags |= NEEDS_LINES;
142 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
145 if (SvIV(result = get_sv("PerlIO::encoding::check", 1)) == 0){
148 if (call_pv("Encode::FB_QUIET", G_SCALAR) != 1) {
149 /* should never happen */
150 Perl_die(aTHX_ "Encode::FB_QUIET did not return a value");
154 e->chk = newSVsv(POPs);
156 sv_setsv(result, e->chk);
158 e->chk = newSVsv(result);
166 PerlIOEncode_popped(pTHX_ PerlIO * f)
168 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
170 SvREFCNT_dec(e->enc);
174 SvREFCNT_dec(e->bufsv);
178 SvREFCNT_dec(e->dataSV);
182 SvREFCNT_dec(e->chk);
189 PerlIOEncode_get_base(pTHX_ PerlIO * f)
191 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
193 e->base.bufsiz = 1024;
195 e->bufsv = newSV(e->base.bufsiz);
196 sv_setpvn(e->bufsv, "", 0);
198 e->base.buf = (STDCHAR *) SvPVX(e->bufsv);
200 e->base.ptr = e->base.buf;
202 e->base.end = e->base.buf;
203 if (e->base.ptr < e->base.buf
204 || e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
205 Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
206 e->base.buf + SvLEN(e->bufsv));
209 if (SvLEN(e->bufsv) < e->base.bufsiz) {
210 SSize_t poff = e->base.ptr - e->base.buf;
211 SSize_t eoff = e->base.end - e->base.buf;
212 e->base.buf = (STDCHAR *) SvGROW(e->bufsv, e->base.bufsiz);
213 e->base.ptr = e->base.buf + poff;
214 e->base.end = e->base.buf + eoff;
216 if (e->base.ptr < e->base.buf
217 || e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
218 Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
219 e->base.buf + SvLEN(e->bufsv));
226 PerlIOEncode_fill(pTHX_ PerlIO * f)
228 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
234 if (PerlIO_flush(f) != 0)
237 if (!PerlIO_fast_gets(n)) {
238 /* Things get too messy if we don't have a buffer layer
239 push a :perlio to do the job */
241 n = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
243 Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
249 avail = PerlIO_get_cnt(n);
251 avail = PerlIO_fill(n);
253 avail = PerlIO_get_cnt(n);
256 if (!PerlIO_error(n) && PerlIO_eof(n))
260 if (avail > 0 || (e->flags & NEEDS_LINES)) {
261 STDCHAR *ptr = PerlIO_get_ptr(n);
262 SSize_t use = (avail >= 0) ? avail : 0;
266 e->base.ptr = e->base.end = (STDCHAR *) Nullch;
267 (void) PerlIOEncode_get_base(aTHX_ f);
269 e->dataSV = newSV(0);
270 if (SvTYPE(e->dataSV) < SVt_PV) {
271 sv_upgrade(e->dataSV,SVt_PV);
273 if (e->flags & NEEDS_LINES) {
274 /* Encoding needs whole lines (e.g. iso-2022-*)
275 search back from end of available data for
278 STDCHAR *nl = ptr+use-1;
285 if (nl >= ptr && *nl == '\n') {
286 /* found a line - take up to and including that */
289 else if (avail > 0) {
290 /* No line, but not EOF - append avail to the pending data */
291 sv_catpvn(e->dataSV, (char*)ptr, use);
292 PerlIO_set_ptrcnt(n, ptr+use, 0);
295 else if (!SvCUR(e->dataSV)) {
299 if (SvCUR(e->dataSV)) {
300 /* something left over from last time - create a normal
301 SV with new data appended
303 if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
304 if (e->flags & NEEDS_LINES) {
305 /* Have to grow buffer */
306 e->base.bufsiz = use + SvCUR(e->dataSV);
307 PerlIOEncode_get_base(aTHX_ f);
310 use = e->base.bufsiz - SvCUR(e->dataSV);
313 sv_catpvn(e->dataSV,(char*)ptr,use);
316 /* Create a "dummy" SV to represent the available data from layer below */
317 if (SvLEN(e->dataSV) && SvPVX(e->dataSV)) {
318 Safefree(SvPVX(e->dataSV));
320 if (use > (SSize_t)e->base.bufsiz) {
321 if (e->flags & NEEDS_LINES) {
322 /* Have to grow buffer */
323 e->base.bufsiz = use;
324 PerlIOEncode_get_base(aTHX_ f);
327 use = e->base.bufsiz;
330 SvPVX(e->dataSV) = (char *) ptr;
331 SvLEN(e->dataSV) = 0; /* Hands off sv.c - it isn't yours */
332 SvCUR_set(e->dataSV,use);
333 SvPOK_only(e->dataSV);
335 SvUTF8_off(e->dataSV);
341 if (call_method("decode", G_SCALAR) != 1) {
342 Perl_die(aTHX_ "panic: decode did not return a value");
347 /* Now get translated string (forced to UTF-8) and use as buffer */
349 s = SvPVutf8(uni, len);
350 #ifdef PARANOID_ENCODE_CHECKS
351 if (len && !is_utf8_string((U8*)s,len)) {
352 Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s);
358 /* if decode gave us back dataSV then data may vanish when
359 we do ptrcnt adjust - so take our copy now.
360 (The copy is a pain - need a put-it-here option for decode.)
362 sv_setpvn(e->bufsv,s,len);
363 e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv);
364 e->base.end = e->base.ptr + SvCUR(e->bufsv);
365 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
368 /* Adjust ptr/cnt not taking anything which
369 did not translate - not clear this is a win */
370 /* compute amount we took */
371 use -= SvCUR(e->dataSV);
372 PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
373 /* and as we did not take it it isn't pending */
374 SvCUR_set(e->dataSV,0);
376 /* Got nothing - assume partial character so we need some more */
377 /* Make sure e->dataSV is a normal SV before re-filling as
378 buffer alias will change under us
380 s = SvPV(e->dataSV,len);
381 sv_setpvn(e->dataSV,s,len);
382 PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
392 PerlIOBase(f)->flags |= PERLIO_F_EOF;
394 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
400 PerlIOEncode_flush(pTHX_ PerlIO * f)
402 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
405 if (e->bufsv && (e->base.ptr > e->base.buf)) {
411 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
412 /* Write case encode the buffer and write() to layer below */
417 SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
422 if (call_method("encode", G_SCALAR) != 1) {
423 Perl_die(aTHX_ "panic: encode did not return a value");
429 count = PerlIO_write(PerlIONext(f),s,len);
430 if ((STRLEN)count != len) {
435 if (PerlIO_flush(PerlIONext(f)) != 0) {
438 if (SvCUR(e->bufsv)) {
439 /* Did not all translate */
440 e->base.ptr = e->base.buf+SvCUR(e->bufsv);
444 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
446 /* if we have any untranslated stuff then unread that first */
447 if (e->dataSV && SvCUR(e->dataSV)) {
448 s = SvPV(e->dataSV, len);
449 count = PerlIO_unread(PerlIONext(f),s,len);
450 if ((STRLEN)count != len) {
454 /* See if there is anything left in the buffer */
455 if (e->base.ptr < e->base.end) {
456 /* Bother - have unread data.
457 re-encode and unread() to layer below
461 str = sv_newmortal();
462 sv_upgrade(str, SVt_PV);
463 SvPVX(str) = (char*)e->base.ptr;
465 SvCUR_set(str, e->base.end - e->base.ptr);
473 if (call_method("encode", G_SCALAR) != 1) {
474 Perl_die(aTHX_ "panic: encode did not return a value");
480 count = PerlIO_unread(PerlIONext(f),s,len);
481 if ((STRLEN)count != len) {
488 e->base.ptr = e->base.end = e->base.buf;
489 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
495 PerlIOEncode_close(pTHX_ PerlIO * f)
497 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
498 IV code = PerlIOBase_close(aTHX_ f);
501 if (e->base.buf && e->base.ptr > e->base.buf) {
502 Perl_croak(aTHX_ "Close with partial character");
504 SvREFCNT_dec(e->bufsv);
510 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
515 PerlIOEncode_tell(pTHX_ PerlIO * f)
517 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
518 /* Unfortunately the only way to get a postion is to (re-)translate,
519 the UTF8 we have in bufefr and then ask layer below
522 if (b->buf && b->ptr > b->buf) {
523 Perl_croak(aTHX_ "Cannot tell at partial character");
525 return PerlIO_tell(PerlIONext(f));
529 PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
530 CLONE_PARAMS * params, int flags)
532 if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) {
533 PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode);
534 PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode);
536 fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
543 PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
545 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
546 if (e->flags & NEEDS_LINES) {
548 const char *ptr = (const char *) vbuf;
549 const char *end = ptr+count;
551 const char *nl = ptr;
552 while (nl < end && *nl++ != '\n') /* empty body */;
553 done = PerlIOBuf_write(aTHX_ f, ptr, nl-ptr);
554 if (done != nl-ptr) {
561 if (ptr[-1] == '\n') {
562 if (PerlIOEncode_flush(aTHX_ f) != 0) {
567 return (SSize_t) (ptr - (const char *) vbuf);
570 return PerlIOBuf_write(aTHX_ f, vbuf, count);
574 PerlIO_funcs PerlIO_encode = {
576 sizeof(PerlIOEncode),
577 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
595 PerlIOBase_setlinebuf,
596 PerlIOEncode_get_base,
600 PerlIOBuf_set_ptrcnt,
602 #endif /* encode layer */
604 MODULE = PerlIO::encoding PACKAGE = PerlIO::encoding
611 PerlIO_define_layer(aTHX_ &PerlIO_encode);