Refactoring to Sv*_set() macros - patch #5

[perl5.git] / ext / PerlIO / encoding / encoding.xs

diff --git a/ext/PerlIO/encoding/encoding.xs b/ext/PerlIO/encoding/encoding.xs
index 0293cee..e743f3f 100644 (file)
--- a/ext/PerlIO/encoding/encoding.xs
+++ b/ext/PerlIO/encoding/encoding.xs
@@ -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.
@@ -30,7 +32,7 @@
    "SUPER::flush.
 
    Note that "flush" is _also_ called for read mode - we still do the
-   (back)-translate so that the the base class's "flush" sees the
+   (back)-translate so that the base class's "flush" sees the
    correct number of encoded chars for positioning the seek
    pointer. (This double translation is the worst performance issue -
    particularly with all-perl encode engine.)
@@ -49,7 +51,6 @@ typedef struct {
 } PerlIOEncode;
 
 #define NEEDS_LINES    1
-#define OUR_DEFAULT_FB "Encode::FB_QUIET"
 
 SV *
 PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
@@ -79,11 +80,11 @@ PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
 }
 
 IV
-PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
+PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs *tab)
 {
     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
     dSP;
-    IV  code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
+    IV  code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv,tab);
     SV *result = Nullsv;
 
     PUSHSTACKi(PERLSI_MAGIC);
@@ -112,12 +113,13 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
        code = -1;
     }
     else {
-#ifdef USE_NEW_SEQUENCE
+
+       /* $enc->renew */
        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",
+       if (call_method("renew",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
+           Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support renew method",
                        arg);
        }
        else {
@@ -125,7 +127,6 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
            result = POPs;
            PUTBACK;
        }
-#endif
        e->enc = newSVsv(result);
        PUSHMARK(sp);
        XPUSHs(e->enc);
@@ -145,7 +146,7 @@ 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;
@@ -320,8 +321,8 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
               use = e->base.bufsiz;
            }
            }
-           SvPVX(e->dataSV) = (char *) ptr;
-           SvLEN(e->dataSV) = 0;  /* Hands off sv.c - it isn't yours */
+           SvPV_set(e->dataSV, (char *) ptr);
+           SvLEN_set(e->dataSV, 0);  /* Hands off sv.c - it isn't yours */
            SvCUR_set(e->dataSV,use);
            SvPOK_only(e->dataSV);
        }
@@ -396,14 +397,14 @@ 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;
@@ -438,15 +439,17 @@ 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 ((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) {
@@ -459,8 +462,8 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
                SAVETMPS;
                str = sv_newmortal();
                sv_upgrade(str, SVt_PV);
-               SvPVX(str) = (char*)e->base.ptr;
-               SvLEN(str) = 0;
+               SvPV_set(str, (char*)e->base.ptr);
+               SvLEN_set(str, 0);
                SvCUR_set(str, e->base.end - e->base.ptr);
                SvPOK_only(str);
                SvUTF8_on(str);
@@ -495,9 +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");
        }
@@ -572,12 +584,14 @@ PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 }
 
 PerlIO_funcs PerlIO_encode = {
+    sizeof(PerlIO_funcs),
     "encoding",
     sizeof(PerlIOEncode),
     PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
     PerlIOEncode_pushed,
     PerlIOEncode_popped,
     PerlIOBuf_open,
+    NULL, /* binmode - always pop */
     PerlIOEncode_getarg,
     PerlIOBase_fileno,
     PerlIOEncode_dup,
@@ -607,7 +621,7 @@ PROTOTYPES: ENABLE
 
 BOOT:
 {
-    SV *chk = get_sv("PerlIO::encoding::check", GV_ADD|GV_ADDMULTI);
+    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()"
@@ -615,7 +629,7 @@ BOOT:
      */
     PUSHSTACKi(PERLSI_MAGIC);
     SPAGAIN;
-    if (!gv_stashpvn("Encode", 6, FALSE)) {
+    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'");
@@ -628,7 +642,6 @@ BOOT:
        SPAGAIN;
        LEAVE;
     }
-#ifdef PERLIO_LAYERS
     PUSHMARK(sp);
     PUTBACK;
     if (call_pv(OUR_DEFAULT_FB, G_SCALAR) != 1) {
@@ -638,6 +651,7 @@ BOOT:
     SPAGAIN;
     sv_setsv(chk, POPs);
     PUTBACK;
+#ifdef PERLIO_LAYERS
     PerlIO_define_layer(aTHX_ &PerlIO_encode);
 #endif
     POPSTACK;