/*
- $Id: Encode.xs,v 1.29 2002/04/19 05:36:43 dankogai Exp $
+ $Id: Encode.xs,v 1.42 2002/04/29 06:54:06 dankogai Exp $
*/
#define PERL_NO_GET_CONTEXT
#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
return (y)0; /* fool picky compilers */ \
}
/**/
+
UNIMPLEMENTED(_encoded_utf8_to_bytes, I32)
UNIMPLEMENTED(_encoded_bytes_to_utf8, I32)
- void
+void
Encode_XSEncoding(pTHX_ encode_t * enc)
{
dSP;
if (dir == enc->f_utf8) {
STRLEN clen;
UV ch =
- utf8n_to_uvuni(s+slen, (SvCUR(src)-slen), &clen, UTF8_ALLOW_ANY|UTF8_CHECK_ONLY);
+ 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",
goto ENCODE_SET_SRC;
}else if (check & ENCODE_PERLQQ){
SV* perlqq =
- sv_2mortal(newSVpvf("\\x{%04x}", ch));
+ 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("&#%" UVuf ";", ch));
+ sdone += slen + clen;
+ ddone += dlen + SvCUR(htmlcref);
+ sv_catsv(dst, htmlcref);
+ }else if (check & ENCODE_XMLCREF){
+ SV* xmlcref =
+ sv_2mortal(newSVpvf("&#x%" UVxf ";", ch));
+ sdone += slen + clen;
+ ddone += dlen + SvCUR(xmlcref);
+ sv_catsv(dst, xmlcref);
} else {
/* fallback char */
sdone += slen + clen;
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 & ENCODE_PERLQQ){
+ }else if (check &
+ (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
SV* perlqq =
- sv_2mortal(newSVpvf("\\x%02X", s[slen]));
+ sv_2mortal(newSVpvf("\\x%02" UVXf, s[slen]));
sdone += slen + 1;
ddone += dlen + SvCUR(perlqq);
sv_catsv(dst, perlqq);
}
}
/* settle variables when fallback */
- d = (U8*)SvEND(dst);
- dlen = SvLEN(dst)-ddone-1;
- s = (U8*)SvPVX(src) + sdone;
+ d = (U8 *)SvEND(dst);
+ dlen = SvLEN(dst) - ddone - 1;
+ 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);
XSRETURN(1);
}
+void
+Method_needs_lines(obj)
+SV * obj
+CODE:
+{
+ encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
+ ST(0) = &PL_sv_no;
+ XSRETURN(1);
+}
+
+void
+Method_perlio_ok(obj)
+SV * obj
+CODE:
+{
+ encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
+ /* 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);
+}
+
MODULE = Encode PACKAGE = Encode
PROTOTYPES: ENABLE
OUTPUT:
RETVAL
-PROTOTYPES: DISABLE
-
-
int
DIE_ON_ERR()
CODE:
RETVAL
int
+HTMLCREF()
+CODE:
+ RETVAL = ENCODE_HTMLCREF;
+OUTPUT:
+ RETVAL
+
+int
+XMLCREF()
+CODE:
+ RETVAL = ENCODE_XMLCREF;
+OUTPUT:
+ RETVAL
+
+int
FB_DEFAULT()
CODE:
RETVAL = ENCODE_FB_DEFAULT;
OUTPUT:
RETVAL
+int
+FB_HTMLCREF()
+CODE:
+ RETVAL = ENCODE_FB_HTMLCREF;
+OUTPUT:
+ RETVAL
+
+int
+FB_XMLCREF()
+CODE:
+ RETVAL = ENCODE_FB_XMLCREF;
+OUTPUT:
+ RETVAL
+
BOOT:
{
#include "def_t.h"