[p5sagit/p5-mst-13.2.git] / ext / Encode / Encode.xs

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define U8 U8
#include "encode.h"
#include "iso8859.h"
#include "EBCDIC.h"
#include "Symbols.h"

#define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) {   \
                         Perl_croak(aTHX_ "panic_unimplemented"); \
			 return (y)0; /* fool picky compilers */ \
                         }
UNIMPLEMENTED(_encoded_utf8_to_bytes, I32)
UNIMPLEMENTED(_encoded_bytes_to_utf8, I32)

#if defined(USE_PERLIO) && !defined(USE_SFIO)
/* Define an encoding "layer" in the perliol.h sense.
   The layer defined here "inherits" in an object-oriented sense from the
   "perlio" layer with its PerlIOBuf_* "methods".
   The implementation is particularly efficient as until Encode settles down
   there is no point in tryint to tune it.

   The layer works by overloading the "fill" and "flush" methods.

   "fill" calls "SUPER::fill" in perl terms, then calls the encode OO perl API
   to convert the encoded data to UTF-8 form, then copies it back to the
   buffer. The "base class's" read methods then see the UTF-8 data.

   "flush" transforms the UTF-8 data deposited by the "base class's write
   method in the buffer back into the encoded form using the encode OO perl API,
   then copies data back into the buffer and calls "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 correct number of encoded chars
   for positioning the seek pointer. (This double translation is the worst performance
   issue - particularly with all-perl encode engine.)

*/


#include "perliol.h"

typedef struct
{
 PerlIOBuf	base;         /* PerlIOBuf stuff */
 SV *		bufsv;
 SV *		enc;
} PerlIOEncode;

SV *
PerlIOEncode_getarg(PerlIO *f)
{
 PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
 SV *sv = &PL_sv_undef;
 if (e->enc)
  {
   dSP;
   ENTER;
   SAVETMPS;
   PUSHMARK(sp);
   XPUSHs(e->enc);
   PUTBACK;
   if (perl_call_method("name",G_SCALAR) == 1)
    {
     SPAGAIN;
     sv = newSVsv(POPs);
     PUTBACK;
    }
  }
 return sv;
}

IV
PerlIOEncode_pushed(PerlIO *f, const char *mode, SV *arg)
{
 PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
 dTHX;
 dSP;
 IV code;
 code = PerlIOBuf_pushed(f,mode,Nullsv);
 ENTER;
 SAVETMPS;
 PUSHMARK(sp);
 XPUSHs(arg);
 PUTBACK;
 if (perl_call_pv("Encode::find_encoding",G_SCALAR) != 1)
  {
   /* should never happen */
   Perl_die(aTHX_ "Encode::find_encoding did not return a value");
   return -1;
  }
 SPAGAIN;
 e->enc = POPs;
 PUTBACK;
 if (!SvROK(e->enc))
  {
   e->enc = Nullsv;
   errno  = EINVAL;
   Perl_warner(aTHX_ WARN_IO, "Cannot find encoding \"%_\"", arg);
   return -1;
  }
 SvREFCNT_inc(e->enc);
 FREETMPS;
 LEAVE;
 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
 return code;
}

IV
PerlIOEncode_popped(PerlIO *f)
{
 PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
 dTHX;
 if (e->enc)
  {
   SvREFCNT_dec(e->enc);
   e->enc = Nullsv;
  }
 if (e->bufsv)
  {
   SvREFCNT_dec(e->bufsv);
   e->bufsv = Nullsv;
  }
 return 0;
}

STDCHAR *
PerlIOEncode_get_base(PerlIO *f)
{
 PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
 dTHX;
 if (!e->base.bufsiz)
  e->base.bufsiz = 1024;
 if (!e->bufsv)
  {
   e->bufsv = newSV(e->base.bufsiz);
   sv_setpvn(e->bufsv,"",0);
  }
 e->base.buf = (STDCHAR *)SvPVX(e->bufsv);
 if (!e->base.ptr)
  e->base.ptr = e->base.buf;
 if (!e->base.end)
  e->base.end = e->base.buf;
 if (e->base.ptr < e->base.buf || e->base.ptr > e->base.buf+SvLEN(e->bufsv))
  {
   Perl_warn(aTHX_ " ptr %p(%p)%p",
             e->base.buf,e->base.ptr,e->base.buf+SvLEN(e->bufsv));
   abort();
  }
 if (SvLEN(e->bufsv) < e->base.bufsiz)
  {
   SSize_t poff = e->base.ptr - e->base.buf;
   SSize_t eoff = e->base.end - e->base.buf;
   e->base.buf  = (STDCHAR *)SvGROW(e->bufsv,e->base.bufsiz);
   e->base.ptr  = e->base.buf + poff;
   e->base.end  = e->base.buf + eoff;
  }
 if (e->base.ptr < e->base.buf || e->base.ptr > e->base.buf+SvLEN(e->bufsv))
  {
   Perl_warn(aTHX_ " ptr %p(%p)%p",
             e->base.buf,e->base.ptr,e->base.buf+SvLEN(e->bufsv));
   abort();
  }
 return e->base.buf;
}

IV
PerlIOEncode_fill(PerlIO *f)
{
 PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
 dTHX;
 dSP;
 IV code;
 code = PerlIOBuf_fill(f);
 if (code == 0)
  {
   SV *uni;
   STRLEN len;
   char *s;
   /* Set SV that is the buffer to be buf..ptr */
   SvCUR_set(e->bufsv, e->base.end - e->base.buf);
   SvUTF8_off(e->bufsv);
   ENTER;
   SAVETMPS;
   PUSHMARK(sp);
   XPUSHs(e->enc);
   XPUSHs(e->bufsv);
   XPUSHs(&PL_sv_yes);
   PUTBACK;
   if (perl_call_method("decode",G_SCALAR) != 1)
    code = -1;
   SPAGAIN;
   uni = POPs;
   PUTBACK;
   /* Now get translated string (forced to UTF-8) and copy back to buffer
      don't use sv_setsv as that may "steal" PV from returned temp
      and so free() our known-large-enough buffer.
      sv_setpvn() should do but let us do it long hand.
    */
   s = SvPVutf8(uni,len);
   if (s != SvPVX(e->bufsv))
    {
     e->base.buf = (STDCHAR *)SvGROW(e->bufsv,len);
     Move(s,e->base.buf,len,char);
     SvCUR_set(e->bufsv,len);
    }
   SvUTF8_on(e->bufsv);
   e->base.end    = e->base.buf+len;
   e->base.ptr    = e->base.buf;
   FREETMPS;
   LEAVE;
  }
 return code;
}

IV
PerlIOEncode_flush(PerlIO *f)
{
 PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
 IV code = 0;
 dTHX;
 if (e->bufsv && (PerlIOBase(f)->flags & (PERLIO_F_RDBUF|PERLIO_F_WRBUF)))
  {
   dSP;
   SV *str;
   char *s;
   STRLEN len;
   SSize_t left = 0;
   if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
    {
     /* This is really just a flag to see if we took all the data, if
        we did PerlIOBase_flush avoids a seek to lower layer.
        Need to revisit if we start getting clever with unreads or seeks-in-buffer
      */
     left = e->base.end - e->base.ptr;
    }
   ENTER;
   SAVETMPS;
   PUSHMARK(sp);
   XPUSHs(e->enc);
   SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
   SvUTF8_on(e->bufsv);
   XPUSHs(e->bufsv);
   XPUSHs(&PL_sv_yes);
   PUTBACK;
   if (perl_call_method("encode",G_SCALAR) != 1)
    code = -1;
   SPAGAIN;
   str = POPs;
   PUTBACK;
   s = SvPV(str,len);
   if (s != SvPVX(e->bufsv))
    {
     e->base.buf = (STDCHAR *)SvGROW(e->bufsv,len);
     Move(s,e->base.buf,len,char);
     SvCUR_set(e->bufsv,len);
    }
   SvUTF8_off(e->bufsv);
   e->base.ptr = e->base.buf+len;
   /* restore end != ptr as inequality is used by PerlIOBuf_flush in read case */
   e->base.end = e->base.ptr + left;
   FREETMPS;
   LEAVE;
   if (PerlIOBuf_flush(f) != 0)
    code = -1;
  }
 return code;
}

IV
PerlIOEncode_close(PerlIO *f)
{
 PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
 IV code = PerlIOBase_close(f);
 dTHX;
 if (e->bufsv)
  {
   SvREFCNT_dec(e->bufsv);
   e->bufsv = Nullsv;
  }
 e->base.buf = NULL;
 e->base.ptr = NULL;
 e->base.end = NULL;
 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
 return code;
}

Off_t
PerlIOEncode_tell(PerlIO *f)
{
 dTHX;
 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
 /* Unfortunately the only way to get a postion is to back-translate,
    the UTF8-bytes we have buf..ptr and adjust accordingly.
    But we will try and save any unread data in case stream
    is un-seekable.
  */
 if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF) && b->ptr < b->end)
  {
   Size_t count = b->end - b->ptr;
   PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
   /* Save what we have left to read */
   PerlIOSelf(f,PerlIOBuf)->bufsiz = count;
   PerlIO_unread(f,b->ptr,count);
   /* There isn't any unread data - we just saved it - so avoid the lower seek */
   b->end = b->ptr;
   /* Flush ourselves - now one layer down,
      this does the back translate and adjusts position
    */
   PerlIO_flush(PerlIONext(f));
   /* Set position of the saved data */
   PerlIOSelf(f,PerlIOBuf)->posn = b->posn;
  }
 else
  {
   PerlIO_flush(f);
  }
 return b->posn;
}

PerlIO_funcs PerlIO_encode = {
 "encoding",
 sizeof(PerlIOEncode),
 PERLIO_K_BUFFERED,
 PerlIOEncode_pushed,
 PerlIOEncode_popped,
 PerlIOBuf_open,
 PerlIOEncode_getarg,
 PerlIOBase_fileno,
 PerlIOBuf_read,
 PerlIOBuf_unread,
 PerlIOBuf_write,
 PerlIOBuf_seek,
 PerlIOEncode_tell,
 PerlIOEncode_close,
 PerlIOEncode_flush,
 PerlIOEncode_fill,
 PerlIOBase_eof,
 PerlIOBase_error,
 PerlIOBase_clearerr,
 PerlIOBase_setlinebuf,
 PerlIOEncode_get_base,
 PerlIOBuf_bufsiz,
 PerlIOBuf_get_ptr,
 PerlIOBuf_get_cnt,
 PerlIOBuf_set_ptrcnt,
};
#endif /* encode layer */

void
Encode_Define(pTHX_ encode_t *enc)
{
 dSP;
 HV *stash = gv_stashpv("Encode::XS", TRUE);
 SV *sv    = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
 int i = 0;
 PUSHMARK(sp);
 XPUSHs(sv);
 while (enc->name[i])
  {
   const char *name = enc->name[i++];
   XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
  }
 PUTBACK;
 call_pv("Encode::define_encoding",G_DISCARD);
 SvREFCNT_dec(sv);
}

void call_failure (SV *routine, U8* done, U8* dest, U8* orig) {}

static SV *
encode_method(pTHX_ encode_t *enc, encpage_t *dir, SV *src, int check)
{
 STRLEN slen;
 U8 *s = (U8 *) SvPV(src,slen);
 SV *dst = sv_2mortal(newSV(2*slen+1));
 if (slen)
  {
   U8 *d = (U8 *) SvGROW(dst, 2*slen+1);
   STRLEN dlen = SvLEN(dst);
   int code;
   while ((code = do_encode(dir,s,&slen,d,dlen,&dlen,!check)))
    {
     SvCUR_set(dst,dlen);
     SvPOK_on(dst);

     if (code == ENCODE_FALLBACK)
      break;

     switch(code)
      {
       case ENCODE_NOSPACE:
        {
         STRLEN need = (slen) ? (SvLEN(dst)*SvCUR(src)/slen) : (dlen + UTF8_MAXLEN);
         if (need <= SvLEN(dst))
          need += UTF8_MAXLEN;
         d = (U8 *) SvGROW(dst, need);
         dlen = SvLEN(dst);
         slen = SvCUR(src);
         break;
        }

       case ENCODE_NOREP:
        if (dir == enc->f_utf8)
         {
          if (!check && ckWARN_d(WARN_UTF8))
           {
            STRLEN clen;
            UV ch = utf8n_to_uvuni(s+slen,(SvCUR(src)-slen),&clen,0);
            Perl_warner(aTHX_ WARN_UTF8, "\"\\N{U+%"UVxf"}\" does not map to %s", ch, enc->name[0]);
            /* FIXME: Skip over the character, copy in replacement and continue
             * but that is messy so for now just fail.
             */
            return &PL_sv_undef;
           }
          else
           {
            return &PL_sv_undef;
           }
         }
        else
         {
          /* UTF-8 is supposed to be "Universal" so should not happen */
          Perl_croak(aTHX_ "%s '%.*s' does not map to UTF-8",
                 enc->name[0], (int)(SvCUR(src)-slen),s+slen);
         }
        break;

       case ENCODE_PARTIAL:
         if (!check && ckWARN_d(WARN_UTF8))
          {
           Perl_warner(aTHX_ WARN_UTF8, "Partial %s character",
                       (dir == enc->f_utf8) ? "UTF-8" : enc->name[0]);
          }
         return &PL_sv_undef;

       default:
        Perl_croak(aTHX_ "Unexpected code %d converting %s %s",
                 code, (dir == enc->f_utf8) ? "to" : "from",enc->name[0]);
        return &PL_sv_undef;
      }
    }
   SvCUR_set(dst,dlen);
   SvPOK_on(dst);
   if (check)
    {
     if (slen < SvCUR(src))
      {
       Move(s+slen,s,SvCUR(src)-slen,U8);
      }
     SvCUR_set(src,SvCUR(src)-slen);
    }
  }
 return dst;
}

MODULE = Encode		PACKAGE = Encode::XS	PREFIX = Method_

PROTOTYPES: ENABLE

void
Method_decode(obj,src,check = 0)
SV *	obj
SV *	src
int	check
CODE:
 {
  encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
  ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check);
  SvUTF8_on(ST(0));
  XSRETURN(1);
 }

void
Method_encode(obj,src,check = 0)
SV *	obj
SV *	src
int	check
CODE:
 {
  encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
  sv_utf8_upgrade(src);
  ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check);
  XSRETURN(1);
 }

MODULE = Encode         PACKAGE = Encode

PROTOTYPES: ENABLE

I32
_bytes_to_utf8(sv, ...)
        SV *    sv
      CODE:
        {
          SV * encoding = items == 2 ? ST(1) : Nullsv;

          if (encoding)
            RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
          else {
            STRLEN len;
            U8*    s = (U8*)SvPV(sv, len);
            U8*    converted;

            converted = bytes_to_utf8(s, &len); /* This allocs */
            sv_setpvn(sv, (char *)converted, len);
            SvUTF8_on(sv); /* XXX Should we? */
            Safefree(converted);                /* ... so free it */
            RETVAL = len;
          }
        }
      OUTPUT:
        RETVAL

I32
_utf8_to_bytes(sv, ...)
        SV *    sv
      CODE:
        {
          SV * to    = items > 1 ? ST(1) : Nullsv;
          SV * check = items > 2 ? ST(2) : Nullsv;

          if (to)
            RETVAL = _encoded_utf8_to_bytes(sv, SvPV_nolen(to));
          else {
            STRLEN len;
            U8 *s = (U8*)SvPV(sv, len);

            if (SvTRUE(check)) {
              /* Must do things the slow way */
              U8 *dest;
              U8 *src  = (U8*)savepv((char *)s); /* We need a copy to pass to check() */
              U8 *send = s + len;

              New(83, dest, len, U8); /* I think */

              while (s < send) {
                if (*s < 0x80)
                  *dest++ = *s++;
                else {
                  STRLEN ulen;
		  UV uv = *s++;

                  /* Have to do it all ourselves because of error routine,
		     aargh. */
		  if (!(uv & 0x40))
		    goto failure;
		  if      (!(uv & 0x20)) { ulen = 2;  uv &= 0x1f; }
		  else if (!(uv & 0x10)) { ulen = 3;  uv &= 0x0f; }
		  else if (!(uv & 0x08)) { ulen = 4;  uv &= 0x07; }
		  else if (!(uv & 0x04)) { ulen = 5;  uv &= 0x03; }
		  else if (!(uv & 0x02)) { ulen = 6;  uv &= 0x01; }
		  else if (!(uv & 0x01)) { ulen = 7;  uv = 0; }
		  else                   { ulen = 13; uv = 0; }
		
		  /* Note change to utf8.c variable naming, for variety */
		  while (ulen--) {
		    if ((*s & 0xc0) != 0x80)
		      goto failure;
		
		    else
		      uv = (uv << 6) | (*s++ & 0x3f);
		  }
		  if (uv > 256) {
		  failure:
		    call_failure(check, s, dest, src);
		    /* Now what happens? */
		  }
		  *dest++ = (U8)uv;
               }
               }
	    } else
	      RETVAL = (utf8_to_bytes(s, &len) ? len : 0);
	  }
	}
      OUTPUT:
	RETVAL

bool
is_utf8(sv, check = FALSE)
SV *	sv
bool	check
      CODE:
	{
	  if (SvPOK(sv)) {
	    RETVAL = SvUTF8(sv) ? TRUE : FALSE;
	    if (RETVAL &&
		check  &&
		!is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
	      RETVAL = FALSE;
	  } else {
	    RETVAL = FALSE;
	  }
	}
      OUTPUT:
	RETVAL

SV *
_utf8_on(sv)
	SV *	sv
      CODE:
	{
	  if (SvPOK(sv)) {
	    SV *rsv = newSViv(SvUTF8(sv));
	    RETVAL = rsv;
	    SvUTF8_on(sv);
	  } else {
	    RETVAL = &PL_sv_undef;
	  }
	}
      OUTPUT:
	RETVAL

SV *
_utf8_off(sv)
	SV *	sv
      CODE:
	{
	  if (SvPOK(sv)) {
	    SV *rsv = newSViv(SvUTF8(sv));
	    RETVAL = rsv;
	    SvUTF8_off(sv);
	  } else {
	    RETVAL = &PL_sv_undef;
	  }
	}
      OUTPUT:
	RETVAL

BOOT:
{
#if defined(USE_PERLIO) && !defined(USE_SFIO)
 PerlIO_define_layer(aTHX_ &PerlIO_encode);
#endif
#include "iso8859.def"
#include "EBCDIC.def"
#include "Symbols.def"
}
Commit	Line	Data
2c674647	1	#include "EXTERN.h"
	2	#include "perl.h"
	3	#include "XSUB.h"
2f2b4ff2	4	#define U8 U8
	5	#include "encode.h"
	6	#include "iso8859.h"
	7	#include "EBCDIC.h"
	8	#include "Symbols.h"
2c674647	9
67e989fb	10	#define UNIMPLEMENTED(x,y) y x (SV sv, char encoding) { \
2f5768b8	11	Perl_croak(aTHX_ "panic_unimplemented"); \
4a83738a	12	return (y)0; /* fool picky compilers */ \
87714904	13	}
67e989fb	14	UNIMPLEMENTED(_encoded_utf8_to_bytes, I32)
	15	UNIMPLEMENTED(_encoded_bytes_to_utf8, I32)
	16
9df9a5cd	17	#if defined(USE_PERLIO) && !defined(USE_SFIO)
72e44f29	18	/* Define an encoding "layer" in the perliol.h sense.
	19	The layer defined here "inherits" in an object-oriented sense from the
	20	"perlio" layer with its PerlIOBuf_* "methods".
	21	The implementation is particularly efficient as until Encode settles down
	22	there is no point in tryint to tune it.
	23
	24	The layer works by overloading the "fill" and "flush" methods.
	25
	26	"fill" calls "SUPER::fill" in perl terms, then calls the encode OO perl API
	27	to convert the encoded data to UTF-8 form, then copies it back to the
	28	buffer. The "base class's" read methods then see the UTF-8 data.
	29
	30	"flush" transforms the UTF-8 data deposited by the "base class's write
	31	method in the buffer back into the encoded form using the encode OO perl API,
	32	then copies data back into the buffer and calls "SUPER::flush.
	33
	34	Note that "flush" is _also_ called for read mode - we still do the (back)-translate
	35	so that the the base class's "flush" sees the correct number of encoded chars
	36	for positioning the seek pointer. (This double translation is the worst performance
	37	issue - particularly with all-perl encode engine.)
	38
	39	*/
	40
	41
33af2bc7	42	#include "perliol.h"
	43
	44	typedef struct
	45	{
	46	PerlIOBuf base; /* PerlIOBuf stuff */
	47	SV * bufsv;
	48	SV * enc;
	49	} PerlIOEncode;
	50
e3f3bf95	51	SV *
	52	PerlIOEncode_getarg(PerlIO *f)
	53	{
	54	PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
	55	SV *sv = &PL_sv_undef;
	56	if (e->enc)
	57	{
	58	dSP;
	59	ENTER;
	60	SAVETMPS;
	61	PUSHMARK(sp);
	62	XPUSHs(e->enc);
	63	PUTBACK;
	64	if (perl_call_method("name",G_SCALAR) == 1)
	65	{
	66	SPAGAIN;
	67	sv = newSVsv(POPs);
	68	PUTBACK;
	69	}
	70	}
	71	return sv;
	72	}
33af2bc7	73
33af2bc7	74	IV
e3f3bf95	75	PerlIOEncode_pushed(PerlIO f, const char mode, SV *arg)
33af2bc7	76	{
	77	PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
	78	dTHX;
	79	dSP;
	80	IV code;
e3f3bf95	81	code = PerlIOBuf_pushed(f,mode,Nullsv);
33af2bc7	82	ENTER;
	83	SAVETMPS;
	84	PUSHMARK(sp);
e3f3bf95	85	XPUSHs(arg);
33af2bc7	86	PUTBACK;
51ef4e11	87	if (perl_call_pv("Encode::find_encoding",G_SCALAR) != 1)
52744f63	88	{
52744f63	89	/* should never happen */
51ef4e11	90	Perl_die(aTHX_ "Encode::find_encoding did not return a value");
52744f63	91	return -1;
52744f63	92	}
33af2bc7	93	SPAGAIN;
	94	e->enc = POPs;
	95	PUTBACK;
	96	if (!SvROK(e->enc))
52744f63	97	{
	98	e->enc = Nullsv;
	99	errno = EINVAL;
e3f3bf95	100	Perl_warner(aTHX_ WARN_IO, "Cannot find encoding \"%_\"", arg);
52744f63	101	return -1;
52744f63	102	}
33af2bc7	103	SvREFCNT_inc(e->enc);
	104	FREETMPS;
	105	LEAVE;
	106	PerlIOBase(f)->flags \|= PERLIO_F_UTF8;
	107	return code;
	108	}
	109
	110	IV
	111	PerlIOEncode_popped(PerlIO *f)
	112	{
	113	PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
	114	dTHX;
	115	if (e->enc)
	116	{
	117	SvREFCNT_dec(e->enc);
	118	e->enc = Nullsv;
	119	}
	120	if (e->bufsv)
	121	{
	122	SvREFCNT_dec(e->bufsv);
	123	e->bufsv = Nullsv;
	124	}
	125	return 0;
	126	}
	127
	128	STDCHAR *
	129	PerlIOEncode_get_base(PerlIO *f)
	130	{
	131	PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
	132	dTHX;
	133	if (!e->base.bufsiz)
	134	e->base.bufsiz = 1024;
	135	if (!e->bufsv)
	136	{
	137	e->bufsv = newSV(e->base.bufsiz);
	138	sv_setpvn(e->bufsv,"",0);
	139	}
62e8870c	140	e->base.buf = (STDCHAR *)SvPVX(e->bufsv);
33af2bc7	141	if (!e->base.ptr)
	142	e->base.ptr = e->base.buf;
	143	if (!e->base.end)
	144	e->base.end = e->base.buf;
	145	if (e->base.ptr < e->base.buf \|\| e->base.ptr > e->base.buf+SvLEN(e->bufsv))
	146	{
	147	Perl_warn(aTHX_ " ptr %p(%p)%p",
	148	e->base.buf,e->base.ptr,e->base.buf+SvLEN(e->bufsv));
	149	abort();
	150	}
	151	if (SvLEN(e->bufsv) < e->base.bufsiz)
	152	{
	153	SSize_t poff = e->base.ptr - e->base.buf;
	154	SSize_t eoff = e->base.end - e->base.buf;
62e8870c	155	e->base.buf = (STDCHAR *)SvGROW(e->bufsv,e->base.bufsiz);
33af2bc7	156	e->base.ptr = e->base.buf + poff;
	157	e->base.end = e->base.buf + eoff;
	158	}
	159	if (e->base.ptr < e->base.buf \|\| e->base.ptr > e->base.buf+SvLEN(e->bufsv))
	160	{
	161	Perl_warn(aTHX_ " ptr %p(%p)%p",
	162	e->base.buf,e->base.ptr,e->base.buf+SvLEN(e->bufsv));
	163	abort();
	164	}
	165	return e->base.buf;
	166	}
	167
33af2bc7	168	IV
	169	PerlIOEncode_fill(PerlIO *f)
	170	{
	171	PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
	172	dTHX;
	173	dSP;
	174	IV code;
33af2bc7	175	code = PerlIOBuf_fill(f);
	176	if (code == 0)
	177	{
	178	SV *uni;
72e44f29	179	STRLEN len;
	180	char *s;
	181	/* Set SV that is the buffer to be buf..ptr */
33af2bc7	182	SvCUR_set(e->bufsv, e->base.end - e->base.buf);
	183	SvUTF8_off(e->bufsv);
	184	ENTER;
	185	SAVETMPS;
	186	PUSHMARK(sp);
	187	XPUSHs(e->enc);
	188	XPUSHs(e->bufsv);
	189	XPUSHs(&PL_sv_yes);
	190	PUTBACK;
50d26985	191	if (perl_call_method("decode",G_SCALAR) != 1)
33af2bc7	192	code = -1;
	193	SPAGAIN;
	194	uni = POPs;
	195	PUTBACK;
72e44f29	196	/* Now get translated string (forced to UTF-8) and copy back to buffer
	197	don't use sv_setsv as that may "steal" PV from returned temp
	198	and so free() our known-large-enough buffer.
	199	sv_setpvn() should do but let us do it long hand.
	200	*/
	201	s = SvPVutf8(uni,len);
	202	if (s != SvPVX(e->bufsv))
	203	{
62e8870c	204	e->base.buf = (STDCHAR *)SvGROW(e->bufsv,len);
72e44f29	205	Move(s,e->base.buf,len,char);
	206	SvCUR_set(e->bufsv,len);
	207	}
	208	SvUTF8_on(e->bufsv);
	209	e->base.end = e->base.buf+len;
33af2bc7	210	e->base.ptr = e->base.buf;
	211	FREETMPS;
	212	LEAVE;
	213	}
	214	return code;
	215	}
	216
	217	IV
	218	PerlIOEncode_flush(PerlIO *f)
	219	{
	220	PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
	221	IV code = 0;
	222	dTHX;
	223	if (e->bufsv && (PerlIOBase(f)->flags & (PERLIO_F_RDBUF\|PERLIO_F_WRBUF)))
	224	{
	225	dSP;
	226	SV *str;
	227	char *s;
	228	STRLEN len;
72e44f29	229	SSize_t left = 0;
	230	if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
	231	{
	232	/* This is really just a flag to see if we took all the data, if
	233	we did PerlIOBase_flush avoids a seek to lower layer.
	234	Need to revisit if we start getting clever with unreads or seeks-in-buffer
	235	*/
	236	left = e->base.end - e->base.ptr;
	237	}
33af2bc7	238	ENTER;
	239	SAVETMPS;
	240	PUSHMARK(sp);
	241	XPUSHs(e->enc);
72e44f29	242	SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
33af2bc7	243	SvUTF8_on(e->bufsv);
	244	XPUSHs(e->bufsv);
	245	XPUSHs(&PL_sv_yes);
	246	PUTBACK;
50d26985	247	if (perl_call_method("encode",G_SCALAR) != 1)
33af2bc7	248	code = -1;
	249	SPAGAIN;
	250	str = POPs;
	251	PUTBACK;
72e44f29	252	s = SvPV(str,len);
	253	if (s != SvPVX(e->bufsv))
	254	{
62e8870c	255	e->base.buf = (STDCHAR *)SvGROW(e->bufsv,len);
72e44f29	256	Move(s,e->base.buf,len,char);
	257	SvCUR_set(e->bufsv,len);
	258	}
33af2bc7	259	SvUTF8_off(e->bufsv);
72e44f29	260	e->base.ptr = e->base.buf+len;
	261	/* restore end != ptr as inequality is used by PerlIOBuf_flush in read case */
	262	e->base.end = e->base.ptr + left;
33af2bc7	263	FREETMPS;
	264	LEAVE;
	265	if (PerlIOBuf_flush(f) != 0)
	266	code = -1;
	267	}
	268	return code;
	269	}
	270
	271	IV
	272	PerlIOEncode_close(PerlIO *f)
	273	{
	274	PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
	275	IV code = PerlIOBase_close(f);
	276	dTHX;
	277	if (e->bufsv)
	278	{
	279	SvREFCNT_dec(e->bufsv);
	280	e->bufsv = Nullsv;
	281	}
	282	e->base.buf = NULL;
	283	e->base.ptr = NULL;
	284	e->base.end = NULL;
	285	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF\|PERLIO_F_WRBUF);
	286	return code;
	287	}
	288
72e44f29	289	Off_t
	290	PerlIOEncode_tell(PerlIO *f)
	291	{
a999f61b	292	dTHX;
72e44f29	293	PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
	294	/* Unfortunately the only way to get a postion is to back-translate,
	295	the UTF8-bytes we have buf..ptr and adjust accordingly.
	296	But we will try and save any unread data in case stream
	297	is un-seekable.
	298	*/
	299	if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF) && b->ptr < b->end)
	300	{
	301	Size_t count = b->end - b->ptr;
e3f3bf95	302	PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
72e44f29	303	/* Save what we have left to read */
	304	PerlIOSelf(f,PerlIOBuf)->bufsiz = count;
	305	PerlIO_unread(f,b->ptr,count);
	306	/* There isn't any unread data - we just saved it - so avoid the lower seek */
	307	b->end = b->ptr;
	308	/* Flush ourselves - now one layer down,
	309	this does the back translate and adjusts position
	310	*/
	311	PerlIO_flush(PerlIONext(f));
	312	/* Set position of the saved data */
	313	PerlIOSelf(f,PerlIOBuf)->posn = b->posn;
	314	}
	315	else
	316	{
	317	PerlIO_flush(f);
	318	}
	319	return b->posn;
	320	}
	321
33af2bc7	322	PerlIO_funcs PerlIO_encode = {
72e44f29	323	"encoding",
33af2bc7	324	sizeof(PerlIOEncode),
33af2bc7	325	PERLIO_K_BUFFERED,
33af2bc7	326	PerlIOEncode_pushed,
33af2bc7	327	PerlIOEncode_popped,
e3f3bf95	328	PerlIOBuf_open,
	329	PerlIOEncode_getarg,
	330	PerlIOBase_fileno,
33af2bc7	331	PerlIOBuf_read,
	332	PerlIOBuf_unread,
	333	PerlIOBuf_write,
	334	PerlIOBuf_seek,
72e44f29	335	PerlIOEncode_tell,
33af2bc7	336	PerlIOEncode_close,
	337	PerlIOEncode_flush,
	338	PerlIOEncode_fill,
	339	PerlIOBase_eof,
	340	PerlIOBase_error,
	341	PerlIOBase_clearerr,
f6c77cf1	342	PerlIOBase_setlinebuf,
33af2bc7	343	PerlIOEncode_get_base,
	344	PerlIOBuf_bufsiz,
	345	PerlIOBuf_get_ptr,
	346	PerlIOBuf_get_cnt,
	347	PerlIOBuf_set_ptrcnt,
	348	};
9df9a5cd	349	#endif /* encode layer */
33af2bc7	350
2f2b4ff2	351	void
	352	Encode_Define(pTHX_ encode_t *enc)
	353	{
51ef4e11	354	dSP;
2f2b4ff2	355	HV *stash = gv_stashpv("Encode::XS", TRUE);
2f2b4ff2	356	SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
dcda1f94	357	int i = 0;
51ef4e11	358	PUSHMARK(sp);
51ef4e11	359	XPUSHs(sv);
dcda1f94	360	while (enc->name[i])
	361	{
	362	const char *name = enc->name[i++];
51ef4e11	363	XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
dcda1f94	364	}
51ef4e11	365	PUTBACK;
51ef4e11	366	call_pv("Encode::define_encoding",G_DISCARD);
dcda1f94	367	SvREFCNT_dec(sv);
2f2b4ff2	368	}
2f2b4ff2	369
183a2d84	370	void call_failure (SV routine, U8 done, U8* dest, U8* orig) {}
67e989fb	371
2f2b4ff2	372	static SV *
	373	encode_method(pTHX_ encode_t enc, encpage_t dir, SV *src, int check)
	374	{
	375	STRLEN slen;
	376	U8 s = (U8 ) SvPV(src,slen);
	377	SV dst = sv_2mortal(newSV(2slen+1));
	378	if (slen)
	379	{
	380	U8 d = (U8 ) SvGROW(dst, 2*slen+1);
	381	STRLEN dlen = SvLEN(dst);
	382	int code;
9b37254d	383	while ((code = do_encode(dir,s,&slen,d,dlen,&dlen,!check)))
2f2b4ff2	384	{
	385	SvCUR_set(dst,dlen);
	386	SvPOK_on(dst);
9b37254d	387
	388	if (code == ENCODE_FALLBACK)
	389	break;
	390
2f2b4ff2	391	switch(code)
	392	{
	393	case ENCODE_NOSPACE:
	394	{
	395	STRLEN need = (slen) ? (SvLEN(dst)*SvCUR(src)/slen) : (dlen + UTF8_MAXLEN);
	396	if (need <= SvLEN(dst))
	397	need += UTF8_MAXLEN;
	398	d = (U8 *) SvGROW(dst, need);
	399	dlen = SvLEN(dst);
	400	slen = SvCUR(src);
	401	break;
	402	}
	403
	404	case ENCODE_NOREP:
	405	if (dir == enc->f_utf8)
	406	{
	407	if (!check && ckWARN_d(WARN_UTF8))
	408	{
	409	STRLEN clen;
9041c2e3	410	UV ch = utf8n_to_uvuni(s+slen,(SvCUR(src)-slen),&clen,0);
9041c2e3	411	Perl_warner(aTHX_ WARN_UTF8, "\"\\N{U+%"UVxf"}\" does not map to %s", ch, enc->name[0]);
2f2b4ff2	412	/* FIXME: Skip over the character, copy in replacement and continue
	413	* but that is messy so for now just fail.
	414	*/
	415	return &PL_sv_undef;
	416	}
	417	else
	418	{
	419	return &PL_sv_undef;
	420	}
	421	}
	422	else
	423	{
	424	/* UTF-8 is supposed to be "Universal" so should not happen */
	425	Perl_croak(aTHX_ "%s '%.*s' does not map to UTF-8",
dcda1f94	426	enc->name[0], (int)(SvCUR(src)-slen),s+slen);
2f2b4ff2	427	}
	428	break;
	429
	430	case ENCODE_PARTIAL:
	431	if (!check && ckWARN_d(WARN_UTF8))
	432	{
	433	Perl_warner(aTHX_ WARN_UTF8, "Partial %s character",
dcda1f94	434	(dir == enc->f_utf8) ? "UTF-8" : enc->name[0]);
2f2b4ff2	435	}
	436	return &PL_sv_undef;
	437
	438	default:
	439	Perl_croak(aTHX_ "Unexpected code %d converting %s %s",
dcda1f94	440	code, (dir == enc->f_utf8) ? "to" : "from",enc->name[0]);
2f2b4ff2	441	return &PL_sv_undef;
	442	}
	443	}
	444	SvCUR_set(dst,dlen);
	445	SvPOK_on(dst);
	446	if (check)
	447	{
	448	if (slen < SvCUR(src))
	449	{
	450	Move(s+slen,s,SvCUR(src)-slen,U8);
	451	}
	452	SvCUR_set(src,SvCUR(src)-slen);
	453	}
	454	}
	455	return dst;
	456	}
	457
50d26985	458	MODULE = Encode PACKAGE = Encode::XS PREFIX = Method_
2f2b4ff2	459
	460	PROTOTYPES: ENABLE
	461
	462	void
50d26985	463	Method_decode(obj,src,check = 0)
2f2b4ff2	464	SV * obj
	465	SV * src
	466	int check
	467	CODE:
	468	{
	469	encode_t enc = INT2PTR(encode_t , SvIV(SvRV(obj)));
	470	ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check);
	471	SvUTF8_on(ST(0));
	472	XSRETURN(1);
	473	}
	474
	475	void
50d26985	476	Method_encode(obj,src,check = 0)
2f2b4ff2	477	SV * obj
	478	SV * src
	479	int check
	480	CODE:
	481	{
	482	encode_t enc = INT2PTR(encode_t , SvIV(SvRV(obj)));
	483	sv_utf8_upgrade(src);
	484	ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check);
	485	XSRETURN(1);
	486	}
	487
67e989fb	488	MODULE = Encode PACKAGE = Encode
2c674647	489
	490	PROTOTYPES: ENABLE
	491
67e989fb	492	I32
2c674647	493	_bytes_to_utf8(sv, ...)
67e989fb	494	SV * sv
2c674647	495	CODE:
67e989fb	496	{
	497	SV * encoding = items == 2 ? ST(1) : Nullsv;
	498
	499	if (encoding)
	500	RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
	501	else {
	502	STRLEN len;
183a2d84	503	U8* s = (U8*)SvPV(sv, len);
67e989fb	504	U8* converted;
	505
	506	converted = bytes_to_utf8(s, &len); /* This allocs */
183a2d84	507	sv_setpvn(sv, (char *)converted, len);
67e989fb	508	SvUTF8_on(sv); /* XXX Should we? */
	509	Safefree(converted); /* ... so free it */
	510	RETVAL = len;
	511	}
	512	}
2c674647	513	OUTPUT:
67e989fb	514	RETVAL
2c674647	515
67e989fb	516	I32
2c674647	517	_utf8_to_bytes(sv, ...)
67e989fb	518	SV * sv
2c674647	519	CODE:
67e989fb	520	{
	521	SV * to = items > 1 ? ST(1) : Nullsv;
	522	SV * check = items > 2 ? ST(2) : Nullsv;
87714904	523
67e989fb	524	if (to)
	525	RETVAL = _encoded_utf8_to_bytes(sv, SvPV_nolen(to));
	526	else {
67e989fb	527	STRLEN len;
b113ac0e	528	U8 s = (U8)SvPV(sv, len);
67e989fb	529
	530	if (SvTRUE(check)) {
	531	/* Must do things the slow way */
	532	U8 *dest;
87714904	533	U8 src = (U8)savepv((char )s); / We need a copy to pass to check() */
67e989fb	534	U8 *send = s + len;
	535
	536	New(83, dest, len, U8); /* I think */
	537
	538	while (s < send) {
	539	if (*s < 0x80)
	540	dest++ = s++;
	541	else {
b113ac0e	542	STRLEN ulen;
b113ac0e	543	UV uv = *s++;
87714904	544
67e989fb	545	/* Have to do it all ourselves because of error routine,
	546	aargh. */
	547	if (!(uv & 0x40))
	548	goto failure;
	549	if (!(uv & 0x20)) { ulen = 2; uv &= 0x1f; }
	550	else if (!(uv & 0x10)) { ulen = 3; uv &= 0x0f; }
	551	else if (!(uv & 0x08)) { ulen = 4; uv &= 0x07; }
	552	else if (!(uv & 0x04)) { ulen = 5; uv &= 0x03; }
	553	else if (!(uv & 0x02)) { ulen = 6; uv &= 0x01; }
	554	else if (!(uv & 0x01)) { ulen = 7; uv = 0; }
	555	else { ulen = 13; uv = 0; }
87714904	556
67e989fb	557	/* Note change to utf8.c variable naming, for variety */
	558	while (ulen--) {
	559	if ((*s & 0xc0) != 0x80)
	560	goto failure;
87714904	561
67e989fb	562	else
67e989fb	563	uv = (uv << 6) \| (*s++ & 0x3f);
87714904	564	}
67e989fb	565	if (uv > 256) {
	566	failure:
	567	call_failure(check, s, dest, src);
	568	/* Now what happens? */
	569	}
	570	*dest++ = (U8)uv;
	571	}
	572	}
	573	} else
	574	RETVAL = (utf8_to_bytes(s, &len) ? len : 0);
	575	}
2c674647	576	}
	577	OUTPUT:
	578	RETVAL
	579
2c674647	580	bool
4411f3b6	581	is_utf8(sv, check = FALSE)
	582	SV * sv
	583	bool check
2c674647	584	CODE:
2c674647	585	{
2c674647	586	if (SvPOK(sv)) {
4411f3b6	587	RETVAL = SvUTF8(sv) ? TRUE : FALSE;
2c674647	588	if (RETVAL &&
4411f3b6	589	check &&
2c674647	590	!is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
	591	RETVAL = FALSE;
	592	} else {
	593	RETVAL = FALSE;
	594	}
	595	}
	596	OUTPUT:
	597	RETVAL
	598
	599	SV *
4411f3b6	600	_utf8_on(sv)
2c674647	601	SV * sv
	602	CODE:
	603	{
	604	if (SvPOK(sv)) {
87714904	605	SV *rsv = newSViv(SvUTF8(sv));
2c674647	606	RETVAL = rsv;
	607	SvUTF8_on(sv);
	608	} else {
	609	RETVAL = &PL_sv_undef;
	610	}
	611	}
	612	OUTPUT:
	613	RETVAL
	614
	615	SV *
4411f3b6	616	_utf8_off(sv)
2c674647	617	SV * sv
	618	CODE:
	619	{
	620	if (SvPOK(sv)) {
87714904	621	SV *rsv = newSViv(SvUTF8(sv));
2c674647	622	RETVAL = rsv;
	623	SvUTF8_off(sv);
	624	} else {
	625	RETVAL = &PL_sv_undef;
	626	}
	627	}
	628	OUTPUT:
	629	RETVAL
	630
33af2bc7	631	BOOT:
33af2bc7	632	{
6a59c517	633	#if defined(USE_PERLIO) && !defined(USE_SFIO)
a999f61b	634	PerlIO_define_layer(aTHX_ &PerlIO_encode);
33af2bc7	635	#endif
2f2b4ff2	636	#include "iso8859.def"
	637	#include "EBCDIC.def"
	638	#include "Symbols.def"
33af2bc7	639	}