[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(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
{
 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(pTHX_ PerlIO *f, const char *mode, SV *arg)
{
 PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
 dSP;
 IV code;
 code = PerlIOBuf_pushed(aTHX_ 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(pTHX_ PerlIO *f)
{
 PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
 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(pTHX_ PerlIO *f)
{
 PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
 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(pTHX_ PerlIO *f)
{
 PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
 dSP;
 IV code;
 code = PerlIOBuf_fill(aTHX_ 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(pTHX_ 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)
    )
  {
   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(aTHX_ f) != 0)
    code = -1;
  }
 return code;
}

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