libunicode-string-perl/String.xs

/* $Id$
 *
 * Copyright 1997-1999, Gisle Aas.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the same terms as Perl itself.
 */

#ifdef __cplusplus
extern "C" {
#endif
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef __cplusplus
}
#endif

#include "patchlevel.h"
#if PATCHLEVEL <= 4 && !defined(PL_dowarn)
   #define PL_dowarn dowarn
#endif

#ifdef G_WARN_ON
   #define DOWARN (PL_dowarn & G_WARN_ON)
#else
   #define DOWARN PL_dowarn
#endif


MODULE = Unicode::String	PACKAGE = Unicode::String

PROTOTYPES: DISABLE

SV*
latin1(self,...)
	SV* self

	PREINIT:
	SV*    newsv;
	SV*    str;

	CODE:
        RETVAL = 0;
	if (!sv_isobject(self)) {
	    newsv = self;
	    RETVAL = self = newSV(0);
	    newSVrv(self, "Unicode::String");
	} else if (items > 1) {
	    newsv = ST(1);
        } else {
	    newsv = 0;
        }

	str = SvRV(self);
	if (GIMME_V != G_VOID && !RETVAL) {
            U8 *beg, *s;
	    STRLEN len;
            U16* usp = (U16*)SvPV(str,len);
	    len /= 2;
	    RETVAL = newSV(len+1);
	    SvPOK_on(RETVAL);
	    beg = s = (U8*)SvPVX(RETVAL);
	    while (len--) {
	        U16 us = ntohs(*usp++);
                if (us > 255) {
		    if (us == 0xFEFF) {
			/* ignore BYTE ORDER MARK */
                    } else {
			if (DOWARN) warn("Data outside latin1 range (pos=%d, ch=U+%x)", s - beg, us);
		    }
		} else {
	            *s++ = us;
                }
	    }
	    SvCUR_set(RETVAL, s - beg);
            *s='\0';
        }

	if (newsv) {
            U16 *usp;
            STRLEN len;
	    STRLEN my_na;
	    U8 *s = (U8*)SvPV(newsv, len);
	    SvGROW(str, len*2 + 2);
	    SvPOK_on(str);
	    SvCUR_set(str,len*2);
	    usp = (U16*)SvPV(str,my_na);
            while (len--) {
	       *usp++ = htons((U16)*s++);
            }
	    *usp = 0;
        }
	if (!RETVAL)
	    RETVAL = newSViv(0);

	OUTPUT:
	RETVAL

SV*
ucs4(self,...)
	SV* self

	PREINIT:
	SV*    newsv;
	SV*    str;

	CODE:
	RETVAL = 0;
	if (!sv_isobject(self)) {
	    newsv = self;
	    RETVAL = self = newSV(0);
            newSVrv(self, "Unicode::String");
	} else if (items > 1) {
	    newsv = ST(1);
        } else {
	    newsv = 0;
        }

	str = SvRV(self);

	if (GIMME_V != G_VOID && !RETVAL) {
            U32* to, *beg;
	    STRLEN len;   /* source length */
	    U16* from = (U16*)SvPV(str, len);
	    STRLEN my_na;
	    len /= 2;
	    RETVAL = newSV(len*4 + 1);
	    SvPOK_on(RETVAL);
	    beg = to = (U32*)SvPV(RETVAL, my_na);
            while (len--) {
		U16 us = ntohs(*from++);
		if (us >= 0xD800 && us <= 0xDFFF) {  /* surrogate */
                    U16 low = len ? ntohs(*from) : 0;
                    if (us >= 0xDC00 || low < 0xDC00 || low > 0xDFFF) {
			/* bad surrogate pair */
			if (DOWARN) warn("Bad surrogate pair U+%04x U+%04x", us, low);
		    } else {
			len--; from++;
			*to++ = htonl((us-0xD800)*0x400 + low-0xDC00 + 0x10000);
                    }
	        } else {
		    *to++ = htonl(us);
                }
            }
	    SvCUR_set(RETVAL, (to - beg) * 4);
	    SvPVX(RETVAL)[SvCUR(RETVAL)] = '\0';
	}

	if (newsv) {
	    STRLEN len;
	    U32* from = (U32*)SvPV(newsv, len);
	    len /= 4;
	    SvGROW(str, len*2 + 1);  /* enough if we don't need surrogates */
	    SvPOK_on(str);
            SvCUR_set(str, 0);
	    while (len--) {
                U32 uc = ntohl(*from++);  /* XXX should look for swapped FEFF */
		if (uc > 0xFFFF) {
		    if (uc > 0x10FFFF) {
			/* can't be represented */
			if (DOWARN) warn("UCS4 char (0x%08x) can not be encoded as UTF16", uc);
                    } else {
			/* generate two surrogates */
			U16 high, low;
			uc -= 0x10000;
			high = htons(uc/0x400 + 0xD800);
			low  = htons(uc%0x400 + 0xDC00);
			sv_catpvn(str, (char*)&high, 2);
			sv_catpvn(str, (char*)&low,  2);
                    }
		} else {
                    U16 s = htons(uc);
		    sv_catpvn(str, (char*)&s, 2);
		}
	    }
	    /* ensure '\0' termination of string */
	    SvGROW(str, SvCUR(str)+1);
	    SvPVX(str)[SvCUR(str)] = '\0';
	}

	if (!RETVAL)
	    RETVAL = newSViv(0);

	OUTPUT:
	RETVAL


SV*
utf8(self,...)
	SV* self

	PREINIT:
	SV*    newsv;
	SV*    str;

	CODE:
	RETVAL = 0;
	if (!sv_isobject(self)) {
	    newsv = self;
	    RETVAL = self = newSV(0);
            newSVrv(self, "Unicode::String");
	} else if (items > 1) {
	    newsv = ST(1);
        } else {
	    newsv = 0;
        }

	str = SvRV(self);
	if (GIMME_V != G_VOID && !RETVAL) {
	    /* encode str */
	    STRLEN len;
	    U16* from = (U16*)SvPV(str, len);
	    len /= 2;
	    RETVAL = newSV(len*1.2 + 1);  /* guess osuitable for euro-text */
	    SvPOK_on(RETVAL);
	    SvCUR_set(RETVAL, 0);
            while (len--) {
		register U32 us = ntohs(*from++);
	        if (us >= 0xD800 && us <= 0xDFFF) {  /* surrogate */
                    U16 low = len ? ntohs(*from) : 0;
                    if (us >= 0xDC00 || low < 0xDC00 || low > 0xDFFF) {
			/* bad surrogate pair */
			if (DOWARN) warn("Bad surrogate pair U+%04x U+%04x", us, low);
		    } else {
			len--; from++;
			us = (us-0xD800)*0x400 + low-0xDC00 + 0x10000;
                    }
                }
		if (us < 0x80) {
		    U8 c = us;
		    sv_catpvn(RETVAL, (char*)&c, 1);
                } else if (us < 0x800) {
		    U8 c[2];
                    c[1] = (us & 0077) | 0200;
                    c[0] = (us >> 6)   | 0300;
                    sv_catpvn(RETVAL, (char*)c, 2);
                } else if (us < 0x10000) {
		    U8 c[3];
                    c[2] = (us & 0077) | 0200; us >>= 6;
		    c[1] = (us & 0077) | 0200; us >>= 6;
		    c[0] =  us         | 0340;
	            sv_catpvn(RETVAL, (char*)c, 3);
                } else if (us < 0x200000) {
                    U8 c[4];
                    c[3] = (us & 0077) | 0200; us >>= 6;
                    c[2] = (us & 0077) | 0200; us >>= 6;
		    c[1] = (us & 0077) | 0200; us >>= 6;
		    c[0] =  us         | 0360;
	            sv_catpvn(RETVAL, (char*)c, 4);
                } else {
		     /* this can't really happen since we start with utf16 */
	             if (DOWARN) warn("Large char (%08X) ignored", us);
                }
	    }
	    /* ensure '\0' termination of string */
	    SvGROW(str, SvCUR(str)+1);
	    SvPVX(str)[SvCUR(str)] = '\0';
	}

	if (newsv) {
	    /* decode new */
	    STRLEN len;
	    U8* from = (U8*)SvPV(newsv, len);
	    SvGROW(str, len + 1);  /* must be at least this big */
	    SvPOK_on(str);
            SvCUR_set(str, 0);
            while (len--) {
	        U8 s[2];
		U8 u = *from++;
                if (u < 0x80) {
                    s[0] = '\0';
                    s[1] = u;
		    sv_catpvn(str, (char*)s, 2);
                } else if ((u & 0340) == 0300) {
                    /* 2 bytes to decode */
		    if (!len) {
			if (DOWARN) warn("Missing second byte of utf8 encoded char");
                    } else {
			U8 u2 = *from;
			if ((u2 & 0300) != 0200) {
			    if (DOWARN) warn("Bad second byte of utf8 encoded char");
                        } else {
			    from++; len--;  /* consume it */
			    s[0] = (u & 0037) >> 2;
			    s[1] = ((u & 0003) << 6) | (u2 & 0077);
			    sv_catpvn(str, (char*)s, 2);
			}
		    }
                } else if ((u & 0360) == 0340) {
		    /* 3 bytes to decode */
		    if (len < 2) {
			if (DOWARN) warn("Missing 2nd or 3rd byte of utf8 encoded char");
                    } else {
			U8 u2 = from[0];
			U8 u3 = from[1];
			if ((u2 & 0300) != 0200 || (u3 & 0300) != 0200) {
			    if (DOWARN) warn("Bad 2nd or 3rd byte of utf8 encoded char");
                        } else {
			    from += 2; len -= 2; /* consume them */
			    s[0] = (u  << 4) | (u2 & 0077) >> 2;
			    s[1] = (u2 << 6) | (u3 & 0077);
			    sv_catpvn(str, (char*)s, 2);
			}
                    }
                } else if ((u & 0370) == 0360) {
		    /* 4 bytes to decode, encoded using surrogates */
	            if (len < 3) {
			if (DOWARN) warn("Missing 2nd, 3rd or 4th byte of utf8 encoded char");
                    } else {
			if ((from[0] & 0300) != 0200 ||
			    (from[1] & 0300) != 0200 ||
			    (from[2] & 0300) != 0200)
			{
			    if (DOWARN) warn("Bad 2nd, 3rd or 4th byte of utf8 encoded char");
			} else {
			    U32 c = (u & 0007) << 6;
			    c |= (from[0] & 0077); c <<= 6;
			    c |= (from[1] & 0077); c <<= 6;
			    c |= (from[2] & 0077);
			    from += 3; len -= 3;
			    /* c must now be encoded as two surrogates */
			    if (c > 0x10FFFF) {
				if (DOWARN) warn("Can't represent 0x%08X as utf16", c);
                            } else {
				/* generate two surrogates */
				U16 high, low;
				c -= 0x10000;
				high = htons(c/0x400 + 0xD800);
				low  = htons(c%0x400 + 0xDC00);
				sv_catpvn(str, (char*)&high, 2);
				sv_catpvn(str, (char*)&low,  2);
			    }
			}
		    }
                } else if ((u & 0374) == 0370) {
                    /* 5 bytes to decode, can't happend */
		    if (DOWARN) warn("Can't represent 5 byte encoded chars");
                } else {
		    if (DOWARN) warn("Bad utf8 byte (0x%02X) ignored", u);
                }
            }
	}

	if (!RETVAL)
	    RETVAL = newSViv(0);

	OUTPUT:
	RETVAL

void
byteswap2(...)
	ALIAS:
	   Unicode::String::byteswap2 = 2
	   Unicode::String::byteswap4 = 4

        PREINIT:
        int i; 
        char c;
        STRLEN len; 
        char* str; 

        PPCODE:
	for (i = 0; i < items; i++) {
	    SV* sv = ST(i);
	    STRLEN len;
            char* src = SvPV(sv, len);
            char* dest;

	    if (GIMME_V != G_VOID) {
		SV* dest_sv = sv_2mortal(newSV(len+1));
		SvCUR_set(dest_sv, len);
		*SvEND(dest_sv) = 0;
		SvPOK_on(dest_sv);
		PUSHs(dest_sv);
		dest = SvPVX(dest_sv);
            } else {
		if (SvREADONLY(sv)) {
		    die("byteswap argument #%d is readonly", i+1);
		    continue;  /* probably not */
		}
		dest = src;
            }

	    if (ix == 2) {	
	        while (len >= 2) {
		    char tmp = *src++;
		    *dest++ = *src++;
		    *dest++ = tmp;
		    len -= 2;
                }
            }
	    else { /* ix == 4 */
		while (len >= 4) {
		    char tmp1 = *src++;
		    char tmp2 = *src++;
		    *dest++ = src[1];
		    *dest++ = src[0];
		    src += 2;
		    *dest++ = tmp2;
		    *dest++ = tmp1;
		    len -= 4;
                }
            }

	    if (len) {
		if (DOWARN) 
		    warn("byteswap argument #%d not long enough", i+1);

		/* this will be a no-op unless dest/src are different */
		while (len--)
		   *dest++ = *src++;
            }
	}