/*
- $Id: Encode.xs,v 1.39 2002/04/26 03:02:04 dankogai Exp $
+ $Id: Encode.xs,v 1.46 2002/05/20 15:25:44 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
}
+#define ERR_ENCODE_NOMAP "\"\\x{%04" UVxf "}\" does not map to %s"
+#define ERR_DECODE_NOMAP "%s \"\\x%02" UVXf "\" does not map to Unicode"
+
static SV *
encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src,
int check)
goto ENCODE_END;
}
- while (code = do_encode(dir, s, &slen, d, dlen, &dlen, !check))
+ while( (code = do_encode(dir, s, &slen, d, dlen, &dlen, !check)) )
{
SvCUR_set(dst, dlen+ddone);
SvPOK_only(dst);
more = (1.0*tlen*SvLEN(dst)+sdone-1)/sdone
- SvLEN(dst);
#elif ENCODE_XS_USEFP
- more = (1.0*SvLEN(dst)+1)/sdone * sleft;
+ more = (STRLEN)((1.0*SvLEN(dst)+1)/sdone * sleft);
#else
/* safe until SvLEN(dst) == MAX_INT/16 */
more = (16*SvLEN(dst)+1)/sdone/16 * sleft;
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",
- 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",
- ch,enc->name[0]);
- }
- goto ENCODE_SET_SRC;
- }else if (check & ENCODE_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("&#%" 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;
- ddone += dlen + enc->replen;
- sv_catpvn(dst, (char*)enc->rep, enc->replen);
- }
+ Perl_croak(aTHX_ ERR_ENCODE_NOMAP,
+ (UV)ch, enc->name[0]);
+ return &PL_sv_undef; /* never reaches but be safe */
+ }
+ if (check & ENCODE_WARN_ON_ERR){
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ ERR_ENCODE_NOMAP, (UV)ch, enc->name[0]);
+ }
+ if (check & ENCODE_RETURN_ON_ERR){
+ goto ENCODE_SET_SRC;
+ }
+ if (check & ENCODE_PERLQQ){
+ SV* perlqq =
+ sv_2mortal(newSVpvf("\\x{%04"UVxf"}", (UV)ch));
+ sdone += slen + clen;
+ ddone += dlen + SvCUR(perlqq);
+ sv_catsv(dst, perlqq);
+ }else if (check & ENCODE_HTMLCREF){
+ SV* htmlcref =
+ sv_2mortal(newSVpvf("&#%" UVuf ";", (UV)ch));
+ sdone += slen + clen;
+ ddone += dlen + SvCUR(htmlcref);
+ sv_catsv(dst, htmlcref);
+ }else if (check & ENCODE_XMLCREF){
+ SV* xmlcref =
+ sv_2mortal(newSVpvf("&#x%" UVxf ";", (UV)ch));
+ sdone += slen + clen;
+ ddone += dlen + SvCUR(xmlcref);
+ sv_catsv(dst, xmlcref);
+ } else {
+ /* fallback char */
+ sdone += slen + clen;
+ ddone += dlen + enc->replen;
+ sv_catpvn(dst, (char*)enc->rep, enc->replen);
}
}
/* decoding */
else {
if (check & ENCODE_DIE_ON_ERR){
- Perl_croak(
- aTHX_ "%s \"\\x%02X\" 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)",
- enc->name[0], (U8) s[slen], code);
- }
- goto ENCODE_SET_SRC;
- }else if (check &
- (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
- SV* perlqq =
- sv_2mortal(newSVpvf("\\x%02X", 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);
- }
+ Perl_croak(aTHX_ ERR_DECODE_NOMAP,
+ enc->name[0], (UV)s[slen]);
+ return &PL_sv_undef; /* never reaches but be safe */
+ }
+ if (check & ENCODE_WARN_ON_ERR){
+ Perl_warner(
+ aTHX_ packWARN(WARN_UTF8),
+ ERR_DECODE_NOMAP,
+ enc->name[0], (UV)s[slen]);
+ }
+ if (check & ENCODE_RETURN_ON_ERR){
+ goto ENCODE_SET_SRC;
+ }
+ if (check &
+ (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
+ SV* perlqq =
+ sv_2mortal(newSVpvf("\\x%02" UVXf, (UV)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);
}
}
/* settle variables when fallback */
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);
SV * obj
CODE:
{
- encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
+ /* encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); */
ST(0) = &PL_sv_no;
XSRETURN(1);
}
SV * obj
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{
+ /* 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);
}