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