[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 "8859.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);
   code = -1;
  }
 else
  {
   SvREFCNT_inc(e->enc);
   PerlIOBase(f)->flags |= PERLIO_F_UTF8;
  }
 FREETMPS;
 LEAVE;
 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)
{
 if ((f = PerlIOBase_dup(aTHX_ f, o, params)))
  {
   PerlIOEncode *fe = PerlIOSelf(f,PerlIOEncode);
   PerlIOEncode *oe = PerlIOSelf(o,PerlIOEncode);
   if (oe->enc)
    {
     fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
    }
  }
 return f;
}

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