[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)
{
 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 "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	{
9f16d962	331	if ((f = PerlIOBase_dup(aTHX_ f, o, params)))
	332	{
	333	PerlIOEncode *fe = PerlIOSelf(f,PerlIOEncode);
	334	PerlIOEncode *oe = PerlIOSelf(o,PerlIOEncode);
	335	if (oe->enc)
	336	{
	337	fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
	338	}
	339	}
	340	return f;
8cf8f3d1	341	}
8cf8f3d1	342
33af2bc7	343	PerlIO_funcs PerlIO_encode = {
72e44f29	344	"encoding",
33af2bc7	345	sizeof(PerlIOEncode),
33af2bc7	346	PERLIO_K_BUFFERED,
33af2bc7	347	PerlIOEncode_pushed,
33af2bc7	348	PerlIOEncode_popped,
e3f3bf95	349	PerlIOBuf_open,
	350	PerlIOEncode_getarg,
	351	PerlIOBase_fileno,
8cf8f3d1	352	PerlIOEncode_dup,
33af2bc7	353	PerlIOBuf_read,
	354	PerlIOBuf_unread,
	355	PerlIOBuf_write,
	356	PerlIOBuf_seek,
72e44f29	357	PerlIOEncode_tell,
33af2bc7	358	PerlIOEncode_close,
	359	PerlIOEncode_flush,
	360	PerlIOEncode_fill,
	361	PerlIOBase_eof,
	362	PerlIOBase_error,
	363	PerlIOBase_clearerr,
f6c77cf1	364	PerlIOBase_setlinebuf,
33af2bc7	365	PerlIOEncode_get_base,
	366	PerlIOBuf_bufsiz,
	367	PerlIOBuf_get_ptr,
	368	PerlIOBuf_get_cnt,
	369	PerlIOBuf_set_ptrcnt,
	370	};
9df9a5cd	371	#endif /* encode layer */
33af2bc7	372
2f2b4ff2	373	void
	374	Encode_Define(pTHX_ encode_t *enc)
	375	{
51ef4e11	376	dSP;
2f2b4ff2	377	HV *stash = gv_stashpv("Encode::XS", TRUE);
2f2b4ff2	378	SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
dcda1f94	379	int i = 0;
51ef4e11	380	PUSHMARK(sp);
51ef4e11	381	XPUSHs(sv);
dcda1f94	382	while (enc->name[i])
	383	{
	384	const char *name = enc->name[i++];
51ef4e11	385	XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
dcda1f94	386	}
51ef4e11	387	PUTBACK;
51ef4e11	388	call_pv("Encode::define_encoding",G_DISCARD);
dcda1f94	389	SvREFCNT_dec(sv);
2f2b4ff2	390	}
2f2b4ff2	391
183a2d84	392	void call_failure (SV routine, U8 done, U8* dest, U8* orig) {}
67e989fb	393
2f2b4ff2	394	static SV *
	395	encode_method(pTHX_ encode_t enc, encpage_t dir, SV *src, int check)
	396	{
	397	STRLEN slen;
	398	U8 s = (U8 ) SvPV(src,slen);
	399	SV dst = sv_2mortal(newSV(2slen+1));
	400	if (slen)
	401	{
	402	U8 d = (U8 ) SvGROW(dst, 2*slen+1);
	403	STRLEN dlen = SvLEN(dst);
	404	int code;
9b37254d	405	while ((code = do_encode(dir,s,&slen,d,dlen,&dlen,!check)))
2f2b4ff2	406	{
	407	SvCUR_set(dst,dlen);
	408	SvPOK_on(dst);
9b37254d	409
	410	if (code == ENCODE_FALLBACK)
	411	break;
	412
2f2b4ff2	413	switch(code)
	414	{
	415	case ENCODE_NOSPACE:
	416	{
	417	STRLEN need = (slen) ? (SvLEN(dst)*SvCUR(src)/slen) : (dlen + UTF8_MAXLEN);
	418	if (need <= SvLEN(dst))
	419	need += UTF8_MAXLEN;
	420	d = (U8 *) SvGROW(dst, need);
	421	dlen = SvLEN(dst);
	422	slen = SvCUR(src);
	423	break;
	424	}
	425
	426	case ENCODE_NOREP:
	427	if (dir == enc->f_utf8)
	428	{
	429	if (!check && ckWARN_d(WARN_UTF8))
	430	{
	431	STRLEN clen;
9041c2e3	432	UV ch = utf8n_to_uvuni(s+slen,(SvCUR(src)-slen),&clen,0);
9041c2e3	433	Perl_warner(aTHX_ WARN_UTF8, "\"\\N{U+%"UVxf"}\" does not map to %s", ch, enc->name[0]);
2f2b4ff2	434	/* FIXME: Skip over the character, copy in replacement and continue
	435	* but that is messy so for now just fail.
	436	*/
	437	return &PL_sv_undef;
	438	}
	439	else
	440	{
	441	return &PL_sv_undef;
	442	}
	443	}
	444	else
	445	{
	446	/* UTF-8 is supposed to be "Universal" so should not happen */
	447	Perl_croak(aTHX_ "%s '%.*s' does not map to UTF-8",
dcda1f94	448	enc->name[0], (int)(SvCUR(src)-slen),s+slen);
2f2b4ff2	449	}
	450	break;
	451
	452	case ENCODE_PARTIAL:
	453	if (!check && ckWARN_d(WARN_UTF8))
	454	{
	455	Perl_warner(aTHX_ WARN_UTF8, "Partial %s character",
dcda1f94	456	(dir == enc->f_utf8) ? "UTF-8" : enc->name[0]);
2f2b4ff2	457	}
	458	return &PL_sv_undef;
	459
	460	default:
	461	Perl_croak(aTHX_ "Unexpected code %d converting %s %s",
dcda1f94	462	code, (dir == enc->f_utf8) ? "to" : "from",enc->name[0]);
2f2b4ff2	463	return &PL_sv_undef;
	464	}
	465	}
	466	SvCUR_set(dst,dlen);
	467	SvPOK_on(dst);
	468	if (check)
	469	{
	470	if (slen < SvCUR(src))
	471	{
	472	Move(s+slen,s,SvCUR(src)-slen,U8);
	473	}
	474	SvCUR_set(src,SvCUR(src)-slen);
	475	}
	476	}
8040349a	477	else
	478	{
	479	SvCUR_set(dst,slen);
	480	SvPOK_on(dst);
	481	}
2f2b4ff2	482	return dst;
	483	}
	484
50d26985	485	MODULE = Encode PACKAGE = Encode::XS PREFIX = Method_
2f2b4ff2	486
	487	PROTOTYPES: ENABLE
	488
	489	void
691638dd	490	Method_decode(obj,src,check = FALSE)
2f2b4ff2	491	SV * obj
2f2b4ff2	492	SV * src
691638dd	493	bool check
2f2b4ff2	494	CODE:
	495	{
	496	encode_t enc = INT2PTR(encode_t , SvIV(SvRV(obj)));
	497	ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check);
	498	SvUTF8_on(ST(0));
	499	XSRETURN(1);
	500	}
	501
	502	void
691638dd	503	Method_encode(obj,src,check = FALSE)
2f2b4ff2	504	SV * obj
2f2b4ff2	505	SV * src
691638dd	506	bool check
2f2b4ff2	507	CODE:
	508	{
	509	encode_t enc = INT2PTR(encode_t , SvIV(SvRV(obj)));
	510	sv_utf8_upgrade(src);
	511	ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check);
	512	XSRETURN(1);
	513	}
	514
67e989fb	515	MODULE = Encode PACKAGE = Encode
2c674647	516
	517	PROTOTYPES: ENABLE
	518
67e989fb	519	I32
2c674647	520	_bytes_to_utf8(sv, ...)
67e989fb	521	SV * sv
2c674647	522	CODE:
67e989fb	523	{
	524	SV * encoding = items == 2 ? ST(1) : Nullsv;
	525
	526	if (encoding)
	527	RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
	528	else {
	529	STRLEN len;
183a2d84	530	U8* s = (U8*)SvPV(sv, len);
67e989fb	531	U8* converted;
	532
	533	converted = bytes_to_utf8(s, &len); /* This allocs */
183a2d84	534	sv_setpvn(sv, (char *)converted, len);
67e989fb	535	SvUTF8_on(sv); /* XXX Should we? */
	536	Safefree(converted); /* ... so free it */
	537	RETVAL = len;
	538	}
	539	}
2c674647	540	OUTPUT:
67e989fb	541	RETVAL
2c674647	542
67e989fb	543	I32
2c674647	544	_utf8_to_bytes(sv, ...)
67e989fb	545	SV * sv
2c674647	546	CODE:
67e989fb	547	{
	548	SV * to = items > 1 ? ST(1) : Nullsv;
	549	SV * check = items > 2 ? ST(2) : Nullsv;
87714904	550
67e989fb	551	if (to)
	552	RETVAL = _encoded_utf8_to_bytes(sv, SvPV_nolen(to));
	553	else {
67e989fb	554	STRLEN len;
b113ac0e	555	U8 s = (U8)SvPV(sv, len);
67e989fb	556
9c5ffd7c	557	RETVAL = 0;
67e989fb	558	if (SvTRUE(check)) {
	559	/* Must do things the slow way */
	560	U8 *dest;
87714904	561	U8 src = (U8)savepv((char )s); / We need a copy to pass to check() */
67e989fb	562	U8 *send = s + len;
	563
	564	New(83, dest, len, U8); /* I think */
	565
	566	while (s < send) {
	567	if (*s < 0x80)
	568	dest++ = s++;
	569	else {
b113ac0e	570	STRLEN ulen;
b113ac0e	571	UV uv = *s++;
87714904	572
67e989fb	573	/* Have to do it all ourselves because of error routine,
	574	aargh. */
	575	if (!(uv & 0x40))
	576	goto failure;
	577	if (!(uv & 0x20)) { ulen = 2; uv &= 0x1f; }
	578	else if (!(uv & 0x10)) { ulen = 3; uv &= 0x0f; }
	579	else if (!(uv & 0x08)) { ulen = 4; uv &= 0x07; }
	580	else if (!(uv & 0x04)) { ulen = 5; uv &= 0x03; }
	581	else if (!(uv & 0x02)) { ulen = 6; uv &= 0x01; }
	582	else if (!(uv & 0x01)) { ulen = 7; uv = 0; }
	583	else { ulen = 13; uv = 0; }
87714904	584
67e989fb	585	/* Note change to utf8.c variable naming, for variety */
	586	while (ulen--) {
	587	if ((*s & 0xc0) != 0x80)
	588	goto failure;
87714904	589
67e989fb	590	else
67e989fb	591	uv = (uv << 6) \| (*s++ & 0x3f);
87714904	592	}
67e989fb	593	if (uv > 256) {
	594	failure:
	595	call_failure(check, s, dest, src);
	596	/* Now what happens? */
	597	}
	598	*dest++ = (U8)uv;
	599	}
	600	}
	601	} else
	602	RETVAL = (utf8_to_bytes(s, &len) ? len : 0);
	603	}
2c674647	604	}
	605	OUTPUT:
	606	RETVAL
	607
2c674647	608	bool
4411f3b6	609	is_utf8(sv, check = FALSE)
	610	SV * sv
	611	bool check
2c674647	612	CODE:
2c674647	613	{
2c674647	614	if (SvPOK(sv)) {
4411f3b6	615	RETVAL = SvUTF8(sv) ? TRUE : FALSE;
2c674647	616	if (RETVAL &&
4411f3b6	617	check &&
2c674647	618	!is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
	619	RETVAL = FALSE;
	620	} else {
	621	RETVAL = FALSE;
	622	}
	623	}
	624	OUTPUT:
	625	RETVAL
	626
	627	SV *
4411f3b6	628	_utf8_on(sv)
2c674647	629	SV * sv
	630	CODE:
	631	{
	632	if (SvPOK(sv)) {
87714904	633	SV *rsv = newSViv(SvUTF8(sv));
2c674647	634	RETVAL = rsv;
	635	SvUTF8_on(sv);
	636	} else {
	637	RETVAL = &PL_sv_undef;
	638	}
	639	}
	640	OUTPUT:
	641	RETVAL
	642
	643	SV *
4411f3b6	644	_utf8_off(sv)
2c674647	645	SV * sv
	646	CODE:
	647	{
	648	if (SvPOK(sv)) {
87714904	649	SV *rsv = newSViv(SvUTF8(sv));
2c674647	650	RETVAL = rsv;
	651	SvUTF8_off(sv);
	652	} else {
	653	RETVAL = &PL_sv_undef;
	654	}
	655	}
	656	OUTPUT:
	657	RETVAL
	658
33af2bc7	659	BOOT:
33af2bc7	660	{
6a59c517	661	#if defined(USE_PERLIO) && !defined(USE_SFIO)
a999f61b	662	PerlIO_define_layer(aTHX_ &PerlIO_encode);
33af2bc7	663	#endif
2f2b4ff2	664	#include "iso8859.def"
	665	#include "EBCDIC.def"
	666	#include "Symbols.def"
33af2bc7	667	}