/*
- $Id: Encode.xs,v 1.38 2002/04/24 20:11:14 dankogai Exp dankogai $
+ $Id: Encode.xs,v 1.42 2002/04/29 06:54:06 dankogai Exp $
*/
#define PERL_NO_GET_CONTEXT
#include "XSUB.h"
#define U8 U8
#include "encode.h"
+
+# define PERLIO_MODNAME "PerlIO::encoding"
# define PERLIO_FILENAME "PerlIO/encoding.pm"
/* set 1 or more to profile. t/encoding.t dumps core because of
Perl_warner and PerlIO don't work well */
-#define ENCODE_XS_PROFILE 0
+#define ENCODE_XS_PROFILE 0
/* set 0 to disable floating point to calculate buffer size for
encode_method(). 1 is recommended. 2 restores NI-S original */
-#define ENCODE_XS_USEFP 1
+#define ENCODE_XS_USEFP 1
#define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) {dTHX; \
Perl_croak(aTHX_ "panic_unimplemented"); \
}
case ENCODE_NOREP:
/* encoding */
- if (dir == enc->f_utf8) {
+ if (dir == enc->f_utf8) {
STRLEN clen;
UV ch =
- utf8n_to_uvuni(s+slen, (SvCUR(src)-slen),
+ utf8n_to_uvuni(s+slen, (SvCUR(src)-slen),
&clen, UTF8_ALLOW_ANY|UTF8_CHECK_ONLY);
if (check & ENCODE_DIE_ON_ERR) {
Perl_croak(
- aTHX_ "\"\\N{U+%" UVxf "}\" does not map to %s, %d",
+ aTHX_ "\"\\N{U+%" UVxf "}\" does not map to %s, %d",
ch, enc->name[0], __LINE__);
}else{
if (check & ENCODE_RETURN_ON_ERR){
if (check & ENCODE_WARN_ON_ERR){
Perl_warner(
aTHX_ packWARN(WARN_UTF8),
- "\"\\N{U+%" UVxf "}\" does not map to %s",
+ "\"\\N{U+%" UVxf "}\" does not map to %s",
ch,enc->name[0]);
}
goto ENCODE_SET_SRC;
}else if (check & ENCODE_PERLQQ){
- SV* perlqq =
+ SV* perlqq =
sv_2mortal(newSVpvf("\\x{%04"UVxf"}", ch));
sdone += slen + clen;
ddone += dlen + SvCUR(perlqq);
sv_catsv(dst, perlqq);
}else if (check & ENCODE_HTMLCREF){
- SV* htmlcref =
- sv_2mortal(newSVpvf("&#%d;", ch));
+ SV* htmlcref =
+ sv_2mortal(newSVpvf("&#%" UVuf ";", ch));
sdone += slen + clen;
ddone += dlen + SvCUR(htmlcref);
sv_catsv(dst, htmlcref);
}else if (check & ENCODE_XMLCREF){
- SV* xmlcref =
+ SV* xmlcref =
sv_2mortal(newSVpvf("&#x%" UVxf ";", ch));
sdone += slen + clen;
ddone += dlen + SvCUR(xmlcref);
sv_catsv(dst, xmlcref);
- } else {
+ } else {
/* fallback char */
sdone += slen + clen;
- ddone += dlen + enc->replen;
- sv_catpvn(dst, (char*)enc->rep, enc->replen);
+ ddone += dlen + enc->replen;
+ sv_catpvn(dst, (char*)enc->rep, enc->replen);
}
- }
+ }
}
/* decoding */
- else {
+ else {
if (check & ENCODE_DIE_ON_ERR){
Perl_croak(
- aTHX_ "%s \"\\x%02X\" does not map to Unicode (%d)",
+ aTHX_ "%s \"\\x%02" UVXf
+ "\" does not map to Unicode (%d)",
enc->name[0], (U8) s[slen], code);
}else{
if (check & ENCODE_RETURN_ON_ERR){
if (check & ENCODE_WARN_ON_ERR){
Perl_warner(
aTHX_ packWARN(WARN_UTF8),
- "%s \"\\x%02X\" does not map to Unicode (%d)",
+ "%s \"\\x%02" UVXf
+ "\" does not map to Unicode (%d)",
enc->name[0], (U8) s[slen], code);
}
goto ENCODE_SET_SRC;
- }else if (check &
+ }else if (check &
(ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
- SV* perlqq =
- sv_2mortal(newSVpvf("\\x%02X", s[slen]));
+ SV* perlqq =
+ sv_2mortal(newSVpvf("\\x%02" UVXf, s[slen]));
sdone += slen + 1;
ddone += dlen + SvCUR(perlqq);
sv_catsv(dst, perlqq);
} else {
sdone += slen + 1;
- ddone += dlen + strlen(FBCHAR_UTF8);
- sv_catpv(dst, FBCHAR_UTF8);
+ ddone += dlen + strlen(FBCHAR_UTF8);
+ sv_catpv(dst, FBCHAR_UTF8);
}
}
}
/* settle variables when fallback */
d = (U8 *)SvEND(dst);
dlen = SvLEN(dst) - ddone - 1;
- s = (U8*)SvPVX(src) + sdone;
+ s = (U8*)SvPVX(src) + sdone;
slen = tlen - sdone;
break;
SvCUR_set(src, sdone);
}
/* warn("check = 0x%X, code = 0x%d\n", check, code); */
- if (code && !(check & ENCODE_RETURN_ON_ERR)) {
- return &PL_sv_undef;
- }
-
+
SvCUR_set(dst, dlen+ddone);
SvPOK_only(dst);
-
+
#if ENCODE_XS_PROFILE
if (SvCUR(dst) > SvCUR(src)){
Perl_warn(aTHX_
(SvLEN(dst) - SvCUR(dst))*1.0/SvLEN(dst)*100.0);
}
#endif
-
+
ENCODE_END:
*SvEND(dst) = '\0';
return dst;
CODE:
{
encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
- require_pv(PERLIO_FILENAME);
- if (hv_exists(get_hv("INC", 0),
- PERLIO_FILENAME, strlen(PERLIO_FILENAME)))
- {
- ST(0) = &PL_sv_yes;
- }else{
+ /* require_pv(PERLIO_FILENAME); */
+
+ eval_pv("require PerlIO::encoding", 0);
+
+ if (SvTRUE(get_sv("@", 0))) {
ST(0) = &PL_sv_no;
+ }else{
+ ST(0) = &PL_sv_yes;
}
XSRETURN(1);
}
CODE:
{
SV * encoding = items == 2 ? ST(1) : Nullsv;
-
+
if (encoding)
RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
else {
/* Must do things the slow way */
U8 *dest;
/* We need a copy to pass to check() */
- U8 *src = (U8*)savepv((char *)s);
+ U8 *src = (U8*)savepv((char *)s);
U8 *send = s + len;
New(83, dest, len, U8); /* I think */
/* Note change to utf8.c variable naming, for variety */
while (ulen--) {
- if ((*s & 0xc0) != 0x80){
- goto failure;
+ if ((*s & 0xc0) != 0x80){
+ goto failure;
} else {
uv = (uv << 6) | (*s++ & 0x3f);
}
OUTPUT:
RETVAL
-int
+int
WARN_ON_ERR()
CODE:
RETVAL = ENCODE_WARN_ON_ERR;