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

#define PERL_NO_GET_CONTEXT

#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) {dTHX;   \
                         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)
{
 dTHX;
 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 \"%"SVf"\"", 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;
 if (e->bufsv && (PerlIOBase(f)->flags & (PERLIO_F_RDBUF|PERLIO_F_WRBUF))
     &&(e->base.ptr > e->base.buf)
    )
  {
   dTHX;
   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 *
PerlIOEncode_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params)
{
 /* FIXME - Almost certainly needs more work */
 return PerlIOBase_dup(aTHX_ f, o, params);
}

PerlIO_funcs PerlIO_encode = {
 "encoding",
 sizeof(PerlIOEncode),
 PERLIO_K_BUFFERED,
 PerlIOEncode_pushed,
 PerlIOEncode_popped,
 PerlIOBuf_open,
 PerlIOEncode_getarg,
 PerlIOBase_fileno,
 PerlIOEncode_dup,
 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);
    }
  }
 else
  {
   SvCUR_set(dst,slen);
   SvPOK_on(dst);
  }
 return dst;
}

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

PROTOTYPES: ENABLE

void
Method_decode(obj,src,check = FALSE)
SV *	obj
SV *	src
bool	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 = FALSE)
SV *	obj
SV *	src
bool	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);

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