view release on metacpan or  search on metacpan

Encode.xs  view on Meta::CPAN

}

static SV *
call_encoding(pTHX_ const char *method, SV *obj, SV *src, SV *check)
{
    dSP;
    I32 count;
    SV *dst = &PL_sv_undef;

    PUSHMARK(sp);

    if (check)
        check = sv_2mortal(newSVsv(check));

    if (!check || SvROK(check) || !SvTRUE_nomg(check) || (SvIV_nomg(check) & ENCODE_LEAVE_SRC))
        src = sv_2mortal(newSVsv(src));

    XPUSHs(obj);
    XPUSHs(src);
    XPUSHs(check ? check : &PL_sv_no);

    PUTBACK;

    count = call_method(method, G_SCALAR);

    SPAGAIN;

    if (count > 0) {
        dst = POPs;
        SvREFCNT_inc(dst);
    }

    PUTBACK;
    return dst;
}


MODULE = Encode		PACKAGE = Encode::utf8	PREFIX = Method_

PROTOTYPES: DISABLE

void
Method_decode(obj,src,check_sv = &PL_sv_no)
SV *	obj
SV *	src
SV *	check_sv
PREINIT:
    STRLEN slen;
    U8 *s;
    U8 *e;
    SV *dst;
    bool renewed = 0;
    IV check;
    bool modify;
    dSP;
INIT:
    SvGETMAGIC(src);
    SvGETMAGIC(check_sv);
    check = SvROK(check_sv) ? ENCODE_PERLQQ|ENCODE_LEAVE_SRC : SvOK(check_sv) ? SvIV_nomg(check_sv) : 0;
    modify = (check && !(check & ENCODE_LEAVE_SRC));
PPCODE:
    if (!SvOK(src))
        XSRETURN_UNDEF;
    s = modify ? (U8 *)SvPV_force_nomg(src, slen) : (U8 *)SvPV_nomg(src, slen);
    if (SvUTF8(src))
        utf8_safe_downgrade(aTHX_ &src, &s, &slen, modify);
    e = s+slen;

    /*
     * PerlIO check -- we assume the object is of PerlIO if renewed
     */
    ENTER; SAVETMPS;
    PUSHMARK(sp);
    XPUSHs(obj);
    PUTBACK;
    if (call_method("renewed",G_SCALAR) == 1) {
    SPAGAIN;
    renewed = (bool)POPi;
    PUTBACK;
#if 0
    fprintf(stderr, "renewed == %d\n", renewed);
#endif
    }
    FREETMPS; LEAVE;
    /* end PerlIO check */

    dst = sv_2mortal(newSV(slen>0?slen:1)); /* newSV() abhors 0 -- inaba */
    s = process_utf8(aTHX_ dst, s, e, check_sv, 0, strict_utf8(aTHX_ obj), renewed);

    /* Clear out translated part of source unless asked not to */
    if (modify) {
        slen = e-s;
        sv_setpvn(src, (char*)s, slen);
        SvSETMAGIC(src);
    }
    SvUTF8_on(dst);
    if (SvTAINTED(src)) SvTAINTED_on(dst); /* propagate taintedness */
    ST(0) = dst;
    XSRETURN(1);

void
Method_encode(obj,src,check_sv = &PL_sv_no)
SV *	obj
SV *	src
SV *	check_sv
PREINIT:
    STRLEN slen;
    U8 *s;
    U8 *e;
    SV *dst;
    IV check;
    bool modify;
INIT:
    SvGETMAGIC(src);
    SvGETMAGIC(check_sv);
    check = SvROK(check_sv) ? ENCODE_PERLQQ|ENCODE_LEAVE_SRC : SvOK(check_sv) ? SvIV_nomg(check_sv) : 0;
    modify = (check && !(check & ENCODE_LEAVE_SRC));
PPCODE:
    if (!SvOK(src))
        XSRETURN_UNDEF;
    s = modify ? (U8 *)SvPV_force_nomg(src, slen) : (U8 *)SvPV_nomg(src, slen);
    e = s+slen;
    dst = sv_2mortal(newSV(slen>0?slen:1)); /* newSV() abhors 0 -- inaba */
    if (SvUTF8(src)) {
    /* Already encoded */
    if (strict_utf8(aTHX_ obj)) {
        s = process_utf8(aTHX_ dst, s, e, check_sv, 1, 1, 0);
    }
        else {
            /* trust it and just copy the octets */
    	    sv_setpvn(dst,(char *)s,(e-s));
        s = e;
        }
    }
    else {
        /* Native bytes - can always encode */
        U8 *d = (U8 *) SvGROW(dst, 2*slen+1); /* +1 or assertion will botch */
        while (s < e) {
#ifdef append_utf8_from_native_byte
            append_utf8_from_native_byte(*s, &d);
            s++;
#else
            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 {
                *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
                *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
            }
#endif
        }
        SvCUR_set(dst, d- (U8 *)SvPVX(dst));
        *SvEND(dst) = '\0';
    }

    /* Clear out translated part of source unless asked not to */
    if (modify) {
        slen = e-s;
        sv_setpvn(src, (char*)s, slen);
        SvSETMAGIC(src);
    }
    SvPOK_only(dst);
    SvUTF8_off(dst);
    if (SvTAINTED(src)) SvTAINTED_on(dst); /* propagate taintedness */
    ST(0) = dst;
    XSRETURN(1);

MODULE = Encode		PACKAGE = Encode::XS	PREFIX = Method_

PROTOTYPES: DISABLE

SV *
Method_renew(obj)
SV *	obj
CODE:
    PERL_UNUSED_VAR(obj);
    RETVAL = newSVsv(obj);