/*
- $Id: Encode.xs,v 2.9 2006/05/03 18:24:10 dankogai Exp $
+ $Id: Encode.xs,v 2.14 2007/05/29 18:15:32 dankogai Exp $
*/
#define PERL_NO_GET_CONTEXT
UTF8_ALLOW_NON_CONTINUATION | \
UTF8_ALLOW_LONG))
-static SV* fallback_cb = (SV*)NULL ;
-
void
Encode_XSEncoding(pTHX_ encode_t * enc)
{
#define ERR_DECODE_NOMAP "%s \"\\x%02" UVXf "\" does not map to Unicode"
static SV *
-do_fallback_cb(pTHX_ UV ch)
+do_fallback_cb(pTHX_ UV ch, SV *fallback_cb)
{
dSP;
int argc;
- SV* retval;
+ SV *temp, *retval;
ENTER;
SAVETMPS;
PUSHMARK(sp);
argc = call_sv(fallback_cb, G_SCALAR);
SPAGAIN;
if (argc != 1){
- croak("fallback sub must return scalar!");
+ croak("fallback sub must return scalar!");
}
- retval = newSVsv(POPs);
+ temp = newSVsv(POPs);
PUTBACK;
FREETMPS;
LEAVE;
+ retval = newSVpv("",0);
+ sv_catsv(retval, temp);
+ SvREFCNT_dec(temp);
return retval;
}
static SV *
encode_method(pTHX_ const encode_t * enc, const encpage_t * dir, SV * src,
- int check, STRLEN * offset, SV * term, int * retcode)
+ int check, STRLEN * offset, SV * term, int * retcode,
+ SV *fallback_cb)
{
STRLEN slen;
U8 *s = (U8 *) SvPV(src, slen);
}
if (check & (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
SV* subchar =
- (fallback_cb != (SV*)NULL) ? do_fallback_cb(aTHX_ ch) :
- newSVpvf(check & ENCODE_PERLQQ ? "\\x{%04"UVxf"}" :
+ (fallback_cb != &PL_sv_undef)
+ ? do_fallback_cb(aTHX_ ch, fallback_cb)
+ : newSVpvf(check & ENCODE_PERLQQ ? "\\x{%04"UVxf"}" :
check & ENCODE_HTMLCREF ? "&#%" UVuf ";" :
"&#x%" UVxf ";", (UV)ch);
sdone += slen + clen;
if (check &
(ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
SV* subchar =
- (fallback_cb != (SV*)NULL) ?
- do_fallback_cb(aTHX_ (UV)s[slen]) :
- newSVpvf("\\x%02" UVXf, (UV)s[slen]);
+ (fallback_cb != &PL_sv_undef)
+ ? do_fallback_cb(aTHX_ (UV)s[slen], fallback_cb)
+ : newSVpvf("\\x%02" UVXf, (UV)s[slen]);
sdone += slen + 1;
ddone += dlen + SvCUR(subchar);
sv_catsv(dst, subchar);
);
#if 1 /* perl-5.8.6 and older do not check UTF8_ALLOW_LONG */
if (strict && uv > PERL_UNICODE_MAX)
- ulen = -1;
+ ulen = (STRLEN) -1;
#endif
if (ulen == -1) {
if (strict) {
/* Native bytes - can always encode */
U8 *d = (U8 *) SvGROW(dst, 2*slen+1); /* +1 or assertion will botch */
while (s < e) {
- UV uv = NATIVE_TO_UNI((UV) *s++);
+ UV uv = NATIVE_TO_UNI((UV) *s);
+ s++; /* Above expansion of NATIVE_TO_UNI() is safer this way. */
if (UNI_IS_INVARIANT(uv))
*d++ = (U8)UTF_TO_NATIVE(uv);
else {
}
void
-Method_cat_decode(obj, dst, src, off, term, check = 0)
+Method_cat_decode(obj, dst, src, off, term, check_sv = &PL_sv_no)
SV * obj
SV * dst
SV * src
SV * off
SV * term
-int check
+SV * check_sv
CODE:
{
+ int check;
+ SV *fallback_cb = &PL_sv_undef;
encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
STRLEN offset = (STRLEN)SvIV(off);
int code = 0;
if (SvUTF8(src)) {
sv_utf8_downgrade(src, FALSE);
}
+ if (SvROK(check_sv)){
+ fallback_cb = check_sv;
+ check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as FB_PERLQQ */
+ }else{
+ check = SvIV(check_sv);
+ }
sv_catsv(dst, encode_method(aTHX_ enc, enc->t_utf8, src, check,
- &offset, term, &code));
+ &offset, term, &code, fallback_cb));
SvIV_set(off, (IV)offset);
if (code == ENCODE_FOUND_TERM) {
ST(0) = &PL_sv_yes;
CODE:
{
int check;
+ SV *fallback_cb = &PL_sv_undef;
encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
if (SvUTF8(src)) {
sv_utf8_downgrade(src, FALSE);
}
if (SvROK(check_sv)){
- if (fallback_cb == (SV*)NULL){
- fallback_cb = newSVsv(check_sv); /* First time */
- }else{
- SvSetSV(fallback_cb, check_sv); /* Been here before */
- }
- check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as FB_PERLQQ */
+ fallback_cb = check_sv;
+ check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as FB_PERLQQ */
}else{
- fallback_cb = (SV*)NULL;
- check = SvIV(check_sv);
+ check = SvIV(check_sv);
}
ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check,
- NULL, Nullsv, NULL);
+ NULL, Nullsv, NULL, fallback_cb);
SvUTF8_on(ST(0));
XSRETURN(1);
}
-
-
void
Method_encode(obj,src,check_sv = &PL_sv_no)
SV * obj
CODE:
{
int check;
+ SV *fallback_cb = &PL_sv_undef;
encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
sv_utf8_upgrade(src);
if (SvROK(check_sv)){
- if (fallback_cb == (SV*)NULL){
- fallback_cb = newSVsv(check_sv); /* First time */
- }else{
- SvSetSV(fallback_cb, check_sv); /* Been here before */
- }
- check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as FB_PERLQQ */
+ fallback_cb = check_sv;
+ check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as FB_PERLQQ */
}else{
- fallback_cb = (SV*)NULL;
- check = SvIV(check_sv);
+ check = SvIV(check_sv);
}
ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check,
- NULL, Nullsv, NULL);
+ NULL, Nullsv, NULL, fallback_cb);
XSRETURN(1);
}
XSRETURN(1);
}
+void
+Method_mime_name(obj)
+SV * obj
+CODE:
+{
+ encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
+ SV *retval;
+ eval_pv("require Encode::MIME::Name", 0);
+
+ if (SvTRUE(get_sv("@", 0))) {
+ ST(0) = &PL_sv_undef;
+ }else{
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(sp);
+ XPUSHs(sv_2mortal(newSVpvn(enc->name[0], strlen(enc->name[0]))));
+ PUTBACK;
+ call_pv("Encode::MIME::Name::get_mime_name", G_SCALAR);
+ SPAGAIN;
+ retval = newSVsv(POPs);
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ /* enc->name[0] */
+ ST(0) = retval;
+ }
+ XSRETURN(1);
+}
+
MODULE = Encode PACKAGE = Encode
PROTOTYPES: ENABLE
/* Must do things the slow way */
U8 *dest;
/* We need a copy to pass to check() */
- U8 *src = (U8*)savepv((char *)s);
+ U8 *src = s;
U8 *send = s + len;
+ U8 *d0;
New(83, dest, len, U8); /* I think */
+ d0 = dest;
while (s < send) {
if (*s < 0x80){
*dest++ = (U8)uv;
}
}
+ RETVAL = dest - d0;
+ sv_usepvn(sv, (char *)dest, RETVAL);
+ SvUTF8_off(sv);
} else {
RETVAL = (utf8_to_bytes(s, &len) ? len : 0);
}
{
if (SvGMAGICAL(sv)) /* it could be $1, for example */
sv = newSVsv(sv); /* GMAGIG will be done */
- if (SvPOK(sv)) {
RETVAL = SvUTF8(sv) ? TRUE : FALSE;
if (RETVAL &&
check &&
!is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
RETVAL = FALSE;
- } else {
- RETVAL = FALSE;
- }
if (sv != ST(0))
SvREFCNT_dec(sv); /* it was a temp copy */
}
projects / p5sagit/p5-mst-13.2.git / blobdiff