}
if (e->dataSV) {
SvREFCNT_dec(e->dataSV);
- e->bufsv = Nullsv;
+ e->dataSV = Nullsv;
}
return 0;
}
if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
use = e->base.bufsiz - SvCUR(e->dataSV);
}
- sv_catpvn(e->dataSV,ptr,use);
+ sv_catpvn(e->dataSV,(char*)ptr,use);
}
else {
/* Create a "dummy" SV to represent the available data from layer below */
SvPVX(e->dataSV) = (char *) ptr;
SvLEN(e->dataSV) = 0; /* Hands off sv.c - it isn't yours */
SvCUR_set(e->dataSV,use);
- SvPOK_on(e->dataSV);
+ SvPOK_only(e->dataSV);
}
SvUTF8_off(e->dataSV);
PUSHMARK(sp);
/* Now get translated string (forced to UTF-8) and use as buffer */
if (SvPOK(uni)) {
s = SvPVutf8(uni, len);
- if (len && !is_utf8_string(s,len)) {
+ if (len && !is_utf8_string((U8*)s,len)) {
Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s);
}
}
(The copy is a pain - need a put-it-here option for decode.)
*/
sv_setpvn(e->bufsv,s,len);
- e->base.ptr = e->base.buf = SvPVX(e->bufsv);
+ e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv);
e->base.end = e->base.ptr + SvCUR(e->bufsv);
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
SvUTF8_on(e->bufsv);
XPUSHs(e->enc);
SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
SvUTF8_on(e->bufsv);
- Perl_warn(aTHX_ "flush %_",e->bufsv);
XPUSHs(e->bufsv);
XPUSHs(&PL_sv_yes);
PUTBACK;
- if (perl_call_method("encode", G_SCALAR) != 1)
- code = -1;
+ if (perl_call_method("encode", G_SCALAR) != 1) {
+ Perl_die(aTHX_ "panic: encode did not return a value");
+ }
SPAGAIN;
str = POPs;
PUTBACK;
if (PerlIO_flush(PerlIONext(f)) != 0) {
code = -1;
}
+ if (SvCUR(e->bufsv)) {
+ /* Did not all translate */
+ e->base.ptr = e->base.buf+SvCUR(e->bufsv);
+ return code;
+ }
}
else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
/* read case */
SAVETMPS;
str = sv_newmortal();
sv_upgrade(str, SVt_PV);
- SvPVX(str) = e->base.ptr;
+ SvPVX(str) = (char*)e->base.ptr;
SvLEN(str) = 0;
SvCUR_set(str, e->base.end - e->base.ptr);
+ SvPOK_only(str);
SvUTF8_on(str);
PUSHMARK(sp);
XPUSHs(e->enc);
XPUSHs(str);
XPUSHs(&PL_sv_yes);
PUTBACK;
- if (perl_call_method("encode", G_SCALAR) != 1)
- code = -1;
+ if (perl_call_method("encode", G_SCALAR) != 1) {
+ Perl_die(aTHX_ "panic: encode did not return a value");
+ }
SPAGAIN;
str = POPs;
PUTBACK;
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
IV code = PerlIOBase_close(aTHX_ f);
if (e->bufsv) {
+ if (e->base.buf && e->base.ptr > e->base.buf) {
+ Perl_croak(aTHX_ "Close with partial character");
+ }
SvREFCNT_dec(e->bufsv);
e->bufsv = Nullsv;
}
the UTF8 we have in bufefr and then ask layer below
*/
PerlIO_flush(f);
+ if (b->buf && b->ptr > b->buf) {
+ Perl_croak(aTHX_ "Cannot tell at partial character");
+ }
return PerlIO_tell(PerlIONext(f));
}
PerlIO_funcs PerlIO_encode = {
"encoding",
sizeof(PerlIOEncode),
- PERLIO_K_BUFFERED,
+ PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
PerlIOEncode_pushed,
PerlIOEncode_popped,
PerlIOBuf_open,
void
call_failure(SV * routine, U8 * done, U8 * dest, U8 * orig)
{
+ /* Exists for breakpointing */
}
static SV *
{
STRLEN slen;
U8 *s = (U8 *) SvPV(src, slen);
- STRLEN tlen = slen;
+ STRLEN tlen = slen;
+ STRLEN ddone = 0;
+ STRLEN sdone = 0;
SV *dst = sv_2mortal(newSV(slen+1));
if (slen) {
U8 *d = (U8 *) SvPVX(dst);
STRLEN dlen = SvLEN(dst)-1;
int code;
while ((code = do_encode(dir, s, &slen, d, dlen, &dlen, !check))) {
- SvCUR_set(dst, dlen);
- SvPOK_on(dst);
+ SvCUR_set(dst, dlen+ddone);
+ SvPOK_only(dst);
#if 0
- Perl_warn(aTHX_ "code=%d @ s=%d/%d d=%d",code,slen,tlen,dlen);
+ Perl_warn(aTHX_ "code=%d @ s=%d/%d/%d d=%d/%d/%d",code,slen,sdone,tlen,dlen,ddone,SvLEN(dst)-1);
#endif
if (code == ENCODE_FALLBACK || code == ENCODE_PARTIAL)
switch (code) {
case ENCODE_NOSPACE:
{
- STRLEN done = tlen-slen;
STRLEN need ;
- if (done) {
- need = (tlen*dlen)/done+1;
+ sdone += slen;
+ ddone += dlen;
+ if (sdone) {
+ need = (tlen*SvLEN(dst)+sdone-1)/sdone+UTF8_MAXLEN;
}
else {
- need = dlen + UTF8_MAXLEN;
+ need = SvLEN(dst) + UTF8_MAXLEN;
}
d = (U8 *) SvGROW(dst, need);
- if (dlen >= SvLEN(dst)) {
- Perl_croak(aTHX_
- "Destination couldn't be grown (the need may be miscalculated).");
+ if (ddone >= SvLEN(dst)) {
+ Perl_croak(aTHX_ "Destination couldn't be grown.");
}
- dlen = SvLEN(dst);
- slen = tlen;
- break;
+ dlen = SvLEN(dst)-ddone-1;
+ d += ddone;
+ s += slen;
+ slen = tlen-sdone;
+ continue;
}
case ENCODE_NOREP:
}
}
else {
- /* UTF-8 is supposed to be "Universal" so should not happen */
- Perl_croak(aTHX_ "%s '%.*s' does not map to UTF-8",
- enc->name[0], (int) (SvCUR(src) - slen),
- s + slen);
+ /* UTF-8 is supposed to be "Universal" so should not happen
+ for real characters, but some encodings have non-assigned
+ codes which may occur.
+ */
+ Perl_croak(aTHX_ "%s \"\\x%02X\" does not map to Unicode",
+ enc->name[0], (U8) s[slen]);
}
break;
return &PL_sv_undef;
}
}
- SvCUR_set(dst, dlen);
- SvPOK_on(dst);
+ SvCUR_set(dst, dlen+ddone);
+ SvPOK_only(dst);
if (check) {
- if (slen < SvCUR(src)) {
- Move(s + slen, s, SvCUR(src) - slen, U8);
+ sdone = SvCUR(src) - (slen+sdone);
+ if (sdone) {
+ Move(s + slen, SvPVX(src), sdone , U8);
}
- SvCUR_set(src, SvCUR(src) - slen);
- *SvEND(src) = '\0';
+ SvCUR_set(src, sdone);
}
}
else {
SvCUR_set(dst, 0);
- SvPOK_on(dst);
+ SvPOK_only(dst);
}
*SvEND(dst) = '\0';
return dst;
PROTOTYPES: ENABLE
void
+Method_name(obj)
+SV * obj
+CODE:
+ {
+ encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
+ ST(0) = sv_2mortal(newSVpvn(enc->name[0],strlen(enc->name[0])));
+ XSRETURN(1);
+ }
+
+void
Method_decode(obj,src,check = FALSE)
SV * obj
SV * src
projects / p5sagit/p5-mst-13.2.git / blobdiff