1			/*
     2			 * $Id: encoding.xs,v 0.3 2002/04/21 22:14:41 dankogai Exp $
     3			 */
     4			
     5			#define PERL_NO_GET_CONTEXT
     6			#include "EXTERN.h"
     7			#include "perl.h"
     8			#include "XSUB.h"
     9			#define U8 U8
    10			
    11			#define OUR_DEFAULT_FB	"Encode::PERLQQ"
    12			
    13			#if defined(USE_PERLIO) && !defined(USE_SFIO)
    14			
    15			/* Define an encoding "layer" in the perliol.h sense.
    16			
    17			   The layer defined here "inherits" in an object-oriented sense from
    18			   the "perlio" layer with its PerlIOBuf_* "methods".  The
    19			   implementation is particularly efficient as until Encode settles
    20			   down there is no point in tryint to tune it.
    21			
    22			   The layer works by overloading the "fill" and "flush" methods.
    23			
    24			   "fill" calls "SUPER::fill" in perl terms, then calls the encode OO
    25			   perl API to convert the encoded data to UTF-8 form, then copies it
    26			   back to the buffer. The "base class's" read methods then see the
    27			   UTF-8 data.
    28			
    29			   "flush" transforms the UTF-8 data deposited by the "base class's
    30			   write method in the buffer back into the encoded form using the
    31			   encode OO perl API, then copies data back into the buffer and calls
    32			   "SUPER::flush.
    33			
    34			   Note that "flush" is _also_ called for read mode - we still do the
    35			   (back)-translate so that the base class's "flush" sees the
    36			   correct number of encoded chars for positioning the seek
    37			   pointer. (This double translation is the worst performance issue -
    38			   particularly with all-perl encode engine.)
    39			
    40			*/
    41			
    42			#include "perliol.h"
    43			
    44			typedef struct {
    45			    PerlIOBuf base;		/* PerlIOBuf stuff */
    46			    SV *bufsv;			/* buffer seen by layers above */
    47			    SV *dataSV;			/* data we have read from layer below */
    48			    SV *enc;			/* the encoding object */
    49			    SV *chk;                    /* CHECK in Encode methods */
    50			    int flags;			/* Flags currently just needs lines */
    51			} PerlIOEncode;
    52			
    53			#define NEEDS_LINES	1
    54			
    55			SV *
    56			PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
    57	           5    {
    58	           5        PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    59	           5        SV *sv = &PL_sv_undef;
    60	           5        if (e->enc) {
    61	           5    	dSP;
    62				/* Not 100% sure stack swap is right thing to do during dup ... */
    63	           5    	PUSHSTACKi(PERLSI_MAGIC);
    64	           5    	SPAGAIN;
    65	           5    	ENTER;
    66	           5    	SAVETMPS;
    67	           5    	PUSHMARK(sp);
    68	           5    	XPUSHs(e->enc);
    69	           5    	PUTBACK;
    70	           5    	if (call_method("name", G_SCALAR) == 1) {
    71	           5    	    SPAGAIN;
    72	           5    	    sv = newSVsv(POPs);
    73	           5    	    PUTBACK;
    74				}
    75	           5    	FREETMPS;
    76	           5    	LEAVE;
    77	           5    	POPSTACK;
    78			    }
    79	           5        return sv;
    80			}
    81			
    82			IV
    83			PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs *tab)
    84	         106    {
    85	         106        PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    86	         106        dSP;
    87	         106        IV  code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv,tab);
    88	         106        SV *result = Nullsv;
    89			
    90	         106        PUSHSTACKi(PERLSI_MAGIC);
    91	         106        SPAGAIN;
    92			
    93	         106        ENTER;
    94	         106        SAVETMPS;
    95			
    96	         106        PUSHMARK(sp);
    97	         106        XPUSHs(arg);
    98	         106        PUTBACK;
    99	         106        if (call_pv("Encode::find_encoding", G_SCALAR) != 1) {
   100				/* should never happen */
   101	      ######    	Perl_die(aTHX_ "Encode::find_encoding did not return a value");
   102	      ######    	return -1;
   103			    }
   104	         106        SPAGAIN;
   105	         106        result = POPs;
   106	         106        PUTBACK;
   107			
   108	         106        if (!SvROK(result) || !SvOBJECT(SvRV(result))) {
   109	           2    	e->enc = Nullsv;
   110	           2    	Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
   111					    arg);
   112	           2    	errno = EINVAL;
   113	           2    	code = -1;
   114			    }
   115			    else {
   116			
   117			       /* $enc->renew */
   118	         104    	PUSHMARK(sp);
   119	         104    	XPUSHs(result);
   120	         104    	PUTBACK;
   121	         104    	if (call_method("renew",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
   122	      ######    	    Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support renew method",
   123						arg);
   124				}
   125				else {
   126	         104    	    SPAGAIN;
   127	         104    	    result = POPs;
   128	         104    	    PUTBACK;
   129				}
   130	         104    	e->enc = newSVsv(result);
   131	         104    	PUSHMARK(sp);
   132	         104    	XPUSHs(e->enc);
   133	         104    	PUTBACK;
   134	         104    	if (call_method("needs_lines",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
   135	      ######    	    Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support needs_lines",
   136						arg);
   137				}
   138				else {
   139	         104    	    SPAGAIN;
   140	         104    	    result = POPs;
   141	         104    	    PUTBACK;
   142	         104    	    if (SvTRUE(result)) {
   143	          19    		e->flags |= NEEDS_LINES;
   144				    }
   145				}
   146	         104    	PerlIOBase(f)->flags |= PERLIO_F_UTF8;
   147			    }
   148			
   149	         106        e->chk = newSVsv(get_sv("PerlIO::encoding::fallback", 0));
   150			
   151	         106        FREETMPS;
   152	         106        LEAVE;
   153	         106        POPSTACK;
   154	         106        return code;
   155			}
   156			
   157			IV
   158			PerlIOEncode_popped(pTHX_ PerlIO * f)
   159	         106    {
   160	         106        PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
   161	         106        if (e->enc) {
   162	         104    	SvREFCNT_dec(e->enc);
   163	         104    	e->enc = Nullsv;
   164			    }
   165	         106        if (e->bufsv) {
   166	           7    	SvREFCNT_dec(e->bufsv);
   167	           7    	e->bufsv = Nullsv;
   168			    }
   169	         106        if (e->dataSV) {
   170	          30    	SvREFCNT_dec(e->dataSV);
   171	          30    	e->dataSV = Nullsv;
   172			    }
   173	         106        if (e->chk) {
   174	         106    	SvREFCNT_dec(e->chk);
   175	         106    	e->chk = Nullsv;
   176			    }
   177	         106        return 0;
   178			}
   179			
   180			STDCHAR *
   181			PerlIOEncode_get_base(pTHX_ PerlIO * f)
   182	         462    {
   183	         462        PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
   184	         462        if (!e->base.bufsiz)
   185	          72    	e->base.bufsiz = 1024;
   186	         462        if (!e->bufsv) {
   187	          72    	e->bufsv = newSV(e->base.bufsiz);
   188	          72    	sv_setpvn(e->bufsv, "", 0);
   189			    }
   190	         462        e->base.buf = (STDCHAR *) SvPVX(e->bufsv);
   191	         462        if (!e->base.ptr)
   192	         444    	e->base.ptr = e->base.buf;
   193	         462        if (!e->base.end)
   194	         444    	e->base.end = e->base.buf;
   195	         462        if (e->base.ptr < e->base.buf
   196				|| e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
   197	      ######    	Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
   198					  e->base.buf + SvLEN(e->bufsv));
   199	      ######    	abort();
   200			    }
   201	         462        if (SvLEN(e->bufsv) < e->base.bufsiz) {
   202	           8    	SSize_t poff = e->base.ptr - e->base.buf;
   203	           8    	SSize_t eoff = e->base.end - e->base.buf;
   204	           8    	e->base.buf = (STDCHAR *) SvGROW(e->bufsv, e->base.bufsiz);
   205	           8    	e->base.ptr = e->base.buf + poff;
   206	           8    	e->base.end = e->base.buf + eoff;
   207			    }
   208	         462        if (e->base.ptr < e->base.buf
   209				|| e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
   210	      ######    	Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
   211					  e->base.buf + SvLEN(e->bufsv));
   212	      ######    	abort();
   213			    }
   214	         462        return e->base.buf;
   215			}
   216			
   217			IV
   218			PerlIOEncode_fill(pTHX_ PerlIO * f)
   219	         347    {
   220	         347        PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
   221	         347        dSP;
   222	         347        IV code = 0;
   223	         347        PerlIO *n;
   224	         347        SSize_t avail;
   225			
   226	         347        if (PerlIO_flush(f) != 0)
   227	      ######    	return -1;
   228	         347        n  = PerlIONext(f);
   229	         347        if (!PerlIO_fast_gets(n)) {
   230				/* Things get too messy if we don't have a buffer layer
   231				   push a :perlio to do the job */
   232	      ######    	char mode[8];
   233	      ######    	n  = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
   234	      ######    	if (!n) {
   235	      ######    	    Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
   236				}
   237			    }
   238	         347        PUSHSTACKi(PERLSI_MAGIC);
   239	         347        SPAGAIN;
   240	         347        ENTER;
   241	         347        SAVETMPS;
   242			  retry:
   243	         392        avail = PerlIO_get_cnt(n);
   244	         392        if (avail <= 0) {
   245	         143    	avail = PerlIO_fill(n);
   246	         143    	if (avail == 0) {
   247	         115    	    avail = PerlIO_get_cnt(n);
   248				}
   249				else {
   250	          28    	    if (!PerlIO_error(n) && PerlIO_eof(n))
   251	          28    		avail = 0;
   252				}
   253			    }
   254	         392        if (avail > 0 || (e->flags & NEEDS_LINES)) {
   255	         372    	STDCHAR *ptr = PerlIO_get_ptr(n);
   256	         372    	SSize_t use  = (avail >= 0) ? avail : 0;
   257	         372    	SV *uni;
   258	         372    	char *s;
   259	         372    	STRLEN len = 0;
   260	         372    	e->base.ptr = e->base.end = (STDCHAR *) Nullch;
   261	         372    	(void) PerlIOEncode_get_base(aTHX_ f);
   262	         372    	if (!e->dataSV)
   263	          30    	    e->dataSV = newSV(0);
   264	         372    	if (SvTYPE(e->dataSV) < SVt_PV) {
   265	          30    	    sv_upgrade(e->dataSV,SVt_PV);
   266				}
   267	         372    	if (e->flags & NEEDS_LINES) {
   268				    /* Encoding needs whole lines (e.g. iso-2022-*)
   269				       search back from end of available data for
   270				       and line marker
   271				     */
   272	          80    	    STDCHAR *nl = ptr+use-1;
   273	        3336    	    while (nl >= ptr) {
   274	        3296    		if (*nl == '\n') {
   275	          40    		    break;
   276					}
   277	        3256    		nl--;
   278				    }
   279	          80    	    if (nl >= ptr && *nl == '\n') {
   280					/* found a line - take up to and including that */
   281	          40    		use = (nl+1)-ptr;
   282				    }
   283	          40    	    else if (avail > 0) {
   284					/* No line, but not EOF - append avail to the pending data */
   285	          32    		sv_catpvn(e->dataSV, (char*)ptr, use);
   286	          32    		PerlIO_set_ptrcnt(n, ptr+use, 0);
   287	          32    		goto retry;
   288				    }
   289	           8    	    else if (!SvCUR(e->dataSV)) {
   290	           8    		goto end_of_file;
   291				    }
   292				}
   293	         332    	if (SvCUR(e->dataSV)) {
   294				    /* something left over from last time - create a normal
   295				       SV with new data appended
   296				     */
   297	          45    	    if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
   298	          23    		if (e->flags & NEEDS_LINES) {
   299					    /* Have to grow buffer */
   300	          10    		    e->base.bufsiz = use + SvCUR(e->dataSV);
   301	          10    		    PerlIOEncode_get_base(aTHX_ f);
   302					}
   303					else {
   304	          13    	       use = e->base.bufsiz - SvCUR(e->dataSV);
   305				    }
   306				    }
   307	          45    	    sv_catpvn(e->dataSV,(char*)ptr,use);
   308				}
   309				else {
   310				    /* Create a "dummy" SV to represent the available data from layer below */
   311	         287    	    if (SvLEN(e->dataSV) && SvPVX_const(e->dataSV)) {
   312	          47    		Safefree(SvPVX_mutable(e->dataSV));
   313				    }
   314	         287    	    if (use > (SSize_t)e->base.bufsiz) {
   315	         209    		if (e->flags & NEEDS_LINES) {
   316					    /* Have to grow buffer */
   317	           8    		    e->base.bufsiz = use;
   318	           8    		    PerlIOEncode_get_base(aTHX_ f);
   319					}
   320					else {
   321	         201    	       use = e->base.bufsiz;
   322				    }
   323				    }
   324	         287    	    SvPV_set(e->dataSV, (char *) ptr);
   325	         287    	    SvLEN_set(e->dataSV, 0);  /* Hands off sv.c - it isn't yours */
   326	         287    	    SvCUR_set(e->dataSV,use);
   327	         287    	    SvPOK_only(e->dataSV);
   328				}
   329	         332    	SvUTF8_off(e->dataSV);
   330	         332    	PUSHMARK(sp);
   331	         332    	XPUSHs(e->enc);
   332	         332    	XPUSHs(e->dataSV);
   333	         332    	XPUSHs(e->chk);
   334	         332    	PUTBACK;
   335	         332    	if (call_method("decode", G_SCALAR) != 1) {
   336	      ######    	    Perl_die(aTHX_ "panic: decode did not return a value");
   337				}
   338	         332    	SPAGAIN;
   339	         332    	uni = POPs;
   340	         332    	PUTBACK;
   341				/* Now get translated string (forced to UTF-8) and use as buffer */
   342	         332    	if (SvPOK(uni)) {
   343	         332    	    s = SvPVutf8(uni, len);
   344			#ifdef PARANOID_ENCODE_CHECKS
   345				    if (len && !is_utf8_string((U8*)s,len)) {
   346					Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s);
   347				    }
   348			#endif
   349				}
   350	         332    	if (len > 0) {
   351				    /* Got _something */
   352				    /* if decode gave us back dataSV then data may vanish when
   353				       we do ptrcnt adjust - so take our copy now.
   354				       (The copy is a pain - need a put-it-here option for decode.)
   355				     */
   356	         319    	    sv_setpvn(e->bufsv,s,len);
   357	         319    	    e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv);
   358	         319    	    e->base.end = e->base.ptr + SvCUR(e->bufsv);
   359	         319    	    PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
   360	         319    	    SvUTF8_on(e->bufsv);
   361			
   362				    /* Adjust ptr/cnt not taking anything which
   363				       did not translate - not clear this is a win */
   364				    /* compute amount we took */
   365	         319    	    use -= SvCUR(e->dataSV);
   366	         319    	    PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
   367				    /* and as we did not take it it isn't pending */
   368	         319    	    SvCUR_set(e->dataSV,0);
   369				} else {
   370				    /* Got nothing - assume partial character so we need some more */
   371				    /* Make sure e->dataSV is a normal SV before re-filling as
   372				       buffer alias will change under us
   373				     */
   374	          13    	    s = SvPV(e->dataSV,len);
   375	          13    	    sv_setpvn(e->dataSV,s,len);
   376	          13    	    PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
   377	          13    	    goto retry;
   378				}
   379			    }
   380			    else {
   381			    end_of_file:
   382	          28    	code = -1;
   383	          28    	if (avail == 0)
   384	          28    	    PerlIOBase(f)->flags |= PERLIO_F_EOF;
   385				else
   386	      ######    	    PerlIOBase(f)->flags |= PERLIO_F_ERROR;
   387			    }
   388	         347        FREETMPS;
   389	         347        LEAVE;
   390	         347        POPSTACK;
   391	         347        return code;
   392			}
   393			
   394			IV
   395			PerlIOEncode_flush(pTHX_ PerlIO * f)
   396	        4364    {
   397	        4364        PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
   398	        4364        IV code = 0;
   399			
   400	        4364        if (e->bufsv) {
   401	        4297    	dSP;
   402	        4297    	SV *str;
   403	        4297    	char *s;
   404	        4297    	STRLEN len;
   405	        4297    	SSize_t count = 0;
   406	        4297    	if ((PerlIOBase(f)->flags & PERLIO_F_WRBUF) && (e->base.ptr > e->base.buf)) {
   407				    /* Write case - encode the buffer and write() to layer below */
   408	        2977    	    PUSHSTACKi(PERLSI_MAGIC);
   409	        2977    	    SPAGAIN;
   410	        2977    	    ENTER;
   411	        2977    	    SAVETMPS;
   412	        2977    	    PUSHMARK(sp);
   413	        2977    	    XPUSHs(e->enc);
   414	        2977    	    SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
   415	        2977    	    SvUTF8_on(e->bufsv);
   416	        2977    	    XPUSHs(e->bufsv);
   417	        2977    	    XPUSHs(e->chk);
   418	        2977    	    PUTBACK;
   419	        2977    	    if (call_method("encode", G_SCALAR) != 1) {
   420	      ######    		Perl_die(aTHX_ "panic: encode did not return a value");
   421				    }
   422	        2977    	    SPAGAIN;
   423	        2977    	    str = POPs;
   424	        2977    	    PUTBACK;
   425	        2977    	    s = SvPV(str, len);
   426	        2977    	    count = PerlIO_write(PerlIONext(f),s,len);
   427	        2977    	    if ((STRLEN)count != len) {
   428	      ######    		code = -1;
   429				    }
   430	        2977    	    FREETMPS;
   431	        2977    	    LEAVE;
   432	        2977    	    POPSTACK;
   433	        2977    	    if (PerlIO_flush(PerlIONext(f)) != 0) {
   434	      ######    		code = -1;
   435				    }
   436	        2977    	    if (SvCUR(e->bufsv)) {
   437					/* Did not all translate */
   438	         105    		e->base.ptr = e->base.buf+SvCUR(e->bufsv);
   439	         105    		return code;
   440				    }
   441				}
   442	        1320    	else if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
   443				    /* read case */
   444				    /* if we have any untranslated stuff then unread that first */
   445				    /* FIXME - unread is fragile is there a better way ? */
   446	         376    	    if (e->dataSV && SvCUR(e->dataSV)) {
   447	      ######    		s = SvPV(e->dataSV, len);
   448	      ######    		count = PerlIO_unread(PerlIONext(f),s,len);
   449	      ######    		if ((STRLEN)count != len) {
   450	      ######    		    code = -1;
   451					}
   452	      ######    		SvCUR_set(e->dataSV,0);
   453				    }
   454				    /* See if there is anything left in the buffer */
   455	         376    	    if (e->base.ptr < e->base.end) {
   456					/* Bother - have unread data.
   457					   re-encode and unread() to layer below
   458					 */
   459	           1    		PUSHSTACKi(PERLSI_MAGIC);
   460	           1    		SPAGAIN;
   461	           1    		ENTER;
   462	           1    		SAVETMPS;
   463	           1    		str = sv_newmortal();
   464	           1    		sv_upgrade(str, SVt_PV);
   465	           1    		SvPV_set(str, (char*)e->base.ptr);
   466	           1    		SvLEN_set(str, 0);
   467	           1    		SvCUR_set(str, e->base.end - e->base.ptr);
   468	           1    		SvPOK_only(str);
   469	           1    		SvUTF8_on(str);
   470	           1    		PUSHMARK(sp);
   471	           1    		XPUSHs(e->enc);
   472	           1    		XPUSHs(str);
   473	           1    		XPUSHs(e->chk);
   474	           1    		PUTBACK;
   475	           1    		if (call_method("encode", G_SCALAR) != 1) {
   476	      ######    		     Perl_die(aTHX_ "panic: encode did not return a value");
   477					}
   478	           1    		SPAGAIN;
   479	           1    		str = POPs;
   480	           1    		PUTBACK;
   481	           1    		s = SvPV(str, len);
   482	           1    		count = PerlIO_unread(PerlIONext(f),s,len);
   483	           1    		if ((STRLEN)count != len) {
   484	      ######    		    code = -1;
   485					}
   486	           1    		FREETMPS;
   487	           1    		LEAVE;
   488	           1    		POPSTACK;
   489				    }
   490				}
   491	        4192    	e->base.ptr = e->base.end = e->base.buf;
   492	        4192    	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
   493			    }
   494	        4259        return code;
   495			}
   496			
   497			IV
   498			PerlIOEncode_close(pTHX_ PerlIO * f)
   499	          66    {
   500	          66        PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
   501	          66        IV code;
   502	          66        if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
   503				/* Discard partial character */
   504	          27    	if (e->dataSV) {
   505	          27    	    SvCUR_set(e->dataSV,0);
   506				}
   507				/* Don't back decode and unread any pending data */
   508	          27    	e->base.ptr = e->base.end = e->base.buf;
   509			    }
   510	          66        code = PerlIOBase_close(aTHX_ f);
   511	          66        if (e->bufsv) {
   512				/* This should only fire for write case */
   513	          65    	if (e->base.buf && e->base.ptr > e->base.buf) {
   514	      ######    	    Perl_croak(aTHX_ "Close with partial character");
   515				}
   516	          65    	SvREFCNT_dec(e->bufsv);
   517	          65    	e->bufsv = Nullsv;
   518			    }
   519	          66        e->base.buf = NULL;
   520	          66        e->base.ptr = NULL;
   521	          66        e->base.end = NULL;
   522	          66        PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
   523	          66        return code;
   524			}
   525			
   526			Off_t
   527			PerlIOEncode_tell(pTHX_ PerlIO * f)
   528	           1    {
   529	           1        PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
   530			    /* Unfortunately the only way to get a postion is to (re-)translate,
   531			       the UTF8 we have in bufefr and then ask layer below
   532			     */
   533	           1        PerlIO_flush(f);
   534	           1        if (b->buf && b->ptr > b->buf) {
   535	      ######    	Perl_croak(aTHX_ "Cannot tell at partial character");
   536			    }
   537	           1        return PerlIO_tell(PerlIONext(f));
   538			}
   539			
   540			PerlIO *
   541			PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
   542					 CLONE_PARAMS * params, int flags)
   543	           2    {
   544	           2        if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) {
   545	           2    	PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode);
   546	           2    	PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode);
   547	           2    	if (oe->enc) {
   548	           2    	    fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
   549				}
   550			    }
   551	           2        return f;
   552			}
   553			
   554			SSize_t
   555			PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
   556	        1977    {
   557	        1977        PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
   558	        1977        if (e->flags & NEEDS_LINES) {
   559	         924    	SSize_t done = 0;
   560	         924    	const char *ptr = (const char *) vbuf;
   561	         924    	const char *end = ptr+count;
   562	        2764    	while (ptr < end) {
   563	        1840    	    const char *nl = ptr;
   564	      186720    	    while (nl < end && *nl++ != '\n') /* empty body */;
   565	        1840    	    done = PerlIOBuf_write(aTHX_ f, ptr, nl-ptr);
   566	        1840    	    if (done != nl-ptr) {
   567	      ######    		if (done > 0) {
   568	      ######    		    ptr += done;
   569					}
   570	      ######    		break;
   571				    }
   572	        1840    	    ptr += done;
   573	        1840    	    if (ptr[-1] == '\n') {
   574	        1840    		if (PerlIOEncode_flush(aTHX_ f) != 0) {
   575	         924    		    break;
   576					}
   577				    }
   578				}
   579	         924    	return (SSize_t) (ptr - (const char *) vbuf);
   580			    }
   581			    else {
   582	        1053    	return PerlIOBuf_write(aTHX_ f, vbuf, count);
   583			    }
   584			}
   585			
   586			PerlIO_funcs PerlIO_encode = {
   587			    sizeof(PerlIO_funcs),
   588			    "encoding",
   589			    sizeof(PerlIOEncode),
   590			    PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
   591			    PerlIOEncode_pushed,
   592			    PerlIOEncode_popped,
   593			    PerlIOBuf_open,
   594			    NULL, /* binmode - always pop */
   595			    PerlIOEncode_getarg,
   596			    PerlIOBase_fileno,
   597			    PerlIOEncode_dup,
   598			    PerlIOBuf_read,
   599			    PerlIOBuf_unread,
   600			    PerlIOEncode_write,
   601			    PerlIOBuf_seek,
   602			    PerlIOEncode_tell,
   603			    PerlIOEncode_close,
   604			    PerlIOEncode_flush,
   605			    PerlIOEncode_fill,
   606			    PerlIOBase_eof,
   607			    PerlIOBase_error,
   608			    PerlIOBase_clearerr,
   609			    PerlIOBase_setlinebuf,
   610			    PerlIOEncode_get_base,
   611			    PerlIOBuf_bufsiz,
   612			    PerlIOBuf_get_ptr,
   613			    PerlIOBuf_get_cnt,
   614			    PerlIOBuf_set_ptrcnt,
   615			};
   616			#endif				/* encode layer */
   617			
   618			MODULE = PerlIO::encoding PACKAGE = PerlIO::encoding
   619			
   620			PROTOTYPES: ENABLE
   621			
   622			BOOT:
   623			{
   624	          17        SV *chk = get_sv("PerlIO::encoding::fallback", GV_ADD|GV_ADDMULTI);
   625			    /*
   626			     * we now "use Encode ()" here instead of
   627			     * PerlIO/encoding.pm.  This avoids SEGV when ":encoding()"
   628			     * is invoked without prior "use Encode". -- dankogai
   629			     */
   630	          17        PUSHSTACKi(PERLSI_MAGIC);
   631	          17        SPAGAIN;
   632	          17        if (!get_cv(OUR_DEFAULT_FB, 0)) {
   633			#if 0
   634				/* This would just be an irritant now loading works */
   635				Perl_warner(aTHX_ packWARN(WARN_IO), ":encoding without 'use Encode'");
   636			#endif
   637	           2    	ENTER;
   638				/* Encode needs a lot of stack - it is likely to move ... */
   639	           2    	PUTBACK;
   640				/* The SV is magically freed by load_module */
   641	           2    	load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("Encode", 6), Nullsv, Nullsv);
   642	           2    	SPAGAIN;
   643	           2    	LEAVE;
   644			    }
   645	          17        PUSHMARK(sp);
   646	          17        PUTBACK;
   647	          17        if (call_pv(OUR_DEFAULT_FB, G_SCALAR) != 1) {
   648				    /* should never happen */
   649	      ######    	    Perl_die(aTHX_ "%s did not return a value",OUR_DEFAULT_FB);
   650			    }
   651	          17        SPAGAIN;
   652	          17        sv_setsv(chk, POPs);
   653	          17        PUTBACK;
   654			#ifdef PERLIO_LAYERS
   655	          17        PerlIO_define_layer(aTHX_ &PerlIO_encode);
   656			#endif
   657	          17        POPSTACK;
   658			}
   659			}