/* $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++;
}
}