/*
- * $Id$
+ * $Id: encoding.xs,v 0.3 2002/04/21 22:14:41 dankogai Exp $
*/
#define PERL_NO_GET_CONTEXT
#include "XSUB.h"
#define U8 U8
+#define OUR_DEFAULT_FB "Encode::PERLQQ"
+
#if defined(USE_PERLIO) && !defined(USE_SFIO)
/* Define an encoding "layer" in the perliol.h sense.
SV *dataSV; /* data we have read from layer below */
SV *enc; /* the encoding object */
SV *chk; /* CHECK in Encode methods */
+ int flags; /* Flags currently just needs lines */
} PerlIOEncode;
-
-#define ENCODE_FB_QUIET "Encode::FB_QUIET"
-
+#define NEEDS_LINES 1
SV *
PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
SV *sv = &PL_sv_undef;
if (e->enc) {
dSP;
+ /* Not 100% sure stack swap is right thing to do during dup ... */
+ PUSHSTACKi(PERLSI_MAGIC);
+ SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK(sp);
sv = newSVsv(POPs);
PUTBACK;
}
+ FREETMPS;
+ LEAVE;
+ POPSTACK;
}
return sv;
}
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
dSP;
- IV code;
- code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
- ENTER;
- SAVETMPS;
+ IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
+ SV *result = Nullsv;
- PUSHMARK(sp);
- PUTBACK;
- if (call_pv(ENCODE_FB_QUIET, G_SCALAR|G_NOARGS) != 1) {
- Perl_die(aTHX_ "Call to Encode::FB_QUIET failed!");
- code = -1;
- }
+ PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
- e->chk = newSVsv(POPs);
- PUTBACK;
+
+ ENTER;
+ SAVETMPS;
PUSHMARK(sp);
XPUSHs(arg);
return -1;
}
SPAGAIN;
- e->enc = POPs;
+ result = POPs;
PUTBACK;
- if (!SvROK(e->enc)) {
+ if (!SvROK(result) || !SvOBJECT(SvRV(result))) {
e->enc = Nullsv;
- errno = EINVAL;
Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
- arg);
+ arg);
+ errno = EINVAL;
code = -1;
}
else {
- SvREFCNT_inc(e->enc);
+#ifdef USE_NEW_SEQUENCE
+ PUSHMARK(sp);
+ XPUSHs(result);
+ PUTBACK;
+ if (call_method("new_sequence",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
+ Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support new_sequence",
+ arg);
+ }
+ else {
+ SPAGAIN;
+ result = POPs;
+ PUTBACK;
+ }
+#endif
+ e->enc = newSVsv(result);
+ PUSHMARK(sp);
+ XPUSHs(e->enc);
+ PUTBACK;
+ if (call_method("needs_lines",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
+ Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support needs_lines",
+ arg);
+ }
+ else {
+ SPAGAIN;
+ result = POPs;
+ PUTBACK;
+ if (SvTRUE(result)) {
+ e->flags |= NEEDS_LINES;
+ }
+ }
PerlIOBase(f)->flags |= PERLIO_F_UTF8;
}
+
+ e->chk = newSVsv(get_sv("PerlIO::encoding::fallback", 0));
+
FREETMPS;
LEAVE;
+ POPSTACK;
return code;
}
SvREFCNT_dec(e->dataSV);
e->dataSV = Nullsv;
}
+ if (e->chk) {
+ SvREFCNT_dec(e->chk);
+ e->chk = Nullsv;
+ }
return 0;
}
IV code = 0;
PerlIO *n;
SSize_t avail;
+
if (PerlIO_flush(f) != 0)
return -1;
n = PerlIONext(f);
Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
}
}
+ PUSHSTACKi(PERLSI_MAGIC);
+ SPAGAIN;
ENTER;
SAVETMPS;
retry:
avail = 0;
}
}
- if (avail > 0) {
+ if (avail > 0 || (e->flags & NEEDS_LINES)) {
STDCHAR *ptr = PerlIO_get_ptr(n);
- SSize_t use = avail;
+ SSize_t use = (avail >= 0) ? avail : 0;
SV *uni;
char *s;
STRLEN len = 0;
if (SvTYPE(e->dataSV) < SVt_PV) {
sv_upgrade(e->dataSV,SVt_PV);
}
+ if (e->flags & NEEDS_LINES) {
+ /* Encoding needs whole lines (e.g. iso-2022-*)
+ search back from end of available data for
+ and line marker
+ */
+ STDCHAR *nl = ptr+use-1;
+ while (nl >= ptr) {
+ if (*nl == '\n') {
+ break;
+ }
+ nl--;
+ }
+ if (nl >= ptr && *nl == '\n') {
+ /* found a line - take up to and including that */
+ use = (nl+1)-ptr;
+ }
+ else if (avail > 0) {
+ /* No line, but not EOF - append avail to the pending data */
+ sv_catpvn(e->dataSV, (char*)ptr, use);
+ PerlIO_set_ptrcnt(n, ptr+use, 0);
+ goto retry;
+ }
+ else if (!SvCUR(e->dataSV)) {
+ goto end_of_file;
+ }
+ }
if (SvCUR(e->dataSV)) {
/* something left over from last time - create a normal
SV with new data appended
*/
if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
+ if (e->flags & NEEDS_LINES) {
+ /* Have to grow buffer */
+ e->base.bufsiz = use + SvCUR(e->dataSV);
+ PerlIOEncode_get_base(aTHX_ f);
+ }
+ else {
use = e->base.bufsiz - SvCUR(e->dataSV);
}
+ }
sv_catpvn(e->dataSV,(char*)ptr,use);
}
else {
if (SvLEN(e->dataSV) && SvPVX(e->dataSV)) {
Safefree(SvPVX(e->dataSV));
}
- if (use > e->base.bufsiz) {
+ if (use > (SSize_t)e->base.bufsiz) {
+ if (e->flags & NEEDS_LINES) {
+ /* Have to grow buffer */
+ e->base.bufsiz = use;
+ PerlIOEncode_get_base(aTHX_ f);
+ }
+ else {
use = e->base.bufsiz;
}
+ }
SvPVX(e->dataSV) = (char *) ptr;
SvLEN(e->dataSV) = 0; /* Hands off sv.c - it isn't yours */
SvCUR_set(e->dataSV,use);
PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
goto retry;
}
- FREETMPS;
- LEAVE;
- return code;
}
else {
+ end_of_file:
+ code = -1;
if (avail == 0)
PerlIOBase(f)->flags |= PERLIO_F_EOF;
else
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
- return -1;
}
+ FREETMPS;
+ LEAVE;
+ POPSTACK;
+ return code;
}
IV
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
IV code = 0;
- if (e->bufsv && (e->base.ptr > e->base.buf)) {
+
+ if (e->bufsv) {
dSP;
SV *str;
char *s;
STRLEN len;
SSize_t count = 0;
- if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
- /* Write case encode the buffer and write() to layer below */
+ if ((PerlIOBase(f)->flags & PERLIO_F_WRBUF) && (e->base.ptr > e->base.buf)) {
+ /* Write case - encode the buffer and write() to layer below */
+ PUSHSTACKi(PERLSI_MAGIC);
+ SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK(sp);
PUTBACK;
s = SvPV(str, len);
count = PerlIO_write(PerlIONext(f),s,len);
- if (count != len) {
+ if ((STRLEN)count != len) {
code = -1;
}
FREETMPS;
LEAVE;
+ POPSTACK;
if (PerlIO_flush(PerlIONext(f)) != 0) {
code = -1;
}
return code;
}
}
- else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
+ else if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
/* read case */
/* if we have any untranslated stuff then unread that first */
+ /* FIXME - unread is fragile is there a better way ? */
if (e->dataSV && SvCUR(e->dataSV)) {
s = SvPV(e->dataSV, len);
count = PerlIO_unread(PerlIONext(f),s,len);
- if (count != len) {
+ if ((STRLEN)count != len) {
code = -1;
}
+ SvCUR_set(e->dataSV,0);
}
/* See if there is anything left in the buffer */
if (e->base.ptr < e->base.end) {
/* Bother - have unread data.
re-encode and unread() to layer below
*/
+ PUSHSTACKi(PERLSI_MAGIC);
+ SPAGAIN;
ENTER;
SAVETMPS;
str = sv_newmortal();
PUTBACK;
s = SvPV(str, len);
count = PerlIO_unread(PerlIONext(f),s,len);
- if (count != len) {
+ if ((STRLEN)count != len) {
code = -1;
}
FREETMPS;
LEAVE;
+ POPSTACK;
}
}
e->base.ptr = e->base.end = e->base.buf;
PerlIOEncode_close(pTHX_ PerlIO * f)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
- IV code = PerlIOBase_close(aTHX_ f);
+ IV code;
+ if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
+ /* Discard partial character */
+ if (e->dataSV) {
+ SvCUR_set(e->dataSV,0);
+ }
+ /* Don't back decode and unread any pending data */
+ e->base.ptr = e->base.end = e->base.buf;
+ }
+ code = PerlIOBase_close(aTHX_ f);
if (e->bufsv) {
+ /* This should only fire for write case */
if (e->base.buf && e->base.ptr > e->base.buf) {
Perl_croak(aTHX_ "Close with partial character");
}
return f;
}
+SSize_t
+PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
+{
+ PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
+ if (e->flags & NEEDS_LINES) {
+ SSize_t done = 0;
+ const char *ptr = (const char *) vbuf;
+ const char *end = ptr+count;
+ while (ptr < end) {
+ const char *nl = ptr;
+ while (nl < end && *nl++ != '\n') /* empty body */;
+ done = PerlIOBuf_write(aTHX_ f, ptr, nl-ptr);
+ if (done != nl-ptr) {
+ if (done > 0) {
+ ptr += done;
+ }
+ break;
+ }
+ ptr += done;
+ if (ptr[-1] == '\n') {
+ if (PerlIOEncode_flush(aTHX_ f) != 0) {
+ break;
+ }
+ }
+ }
+ return (SSize_t) (ptr - (const char *) vbuf);
+ }
+ else {
+ return PerlIOBuf_write(aTHX_ f, vbuf, count);
+ }
+}
+
PerlIO_funcs PerlIO_encode = {
"encoding",
sizeof(PerlIOEncode),
PerlIOEncode_pushed,
PerlIOEncode_popped,
PerlIOBuf_open,
+ NULL, /* binmode - always pop */
PerlIOEncode_getarg,
PerlIOBase_fileno,
PerlIOEncode_dup,
PerlIOBuf_read,
PerlIOBuf_unread,
- PerlIOBuf_write,
+ PerlIOEncode_write,
PerlIOBuf_seek,
PerlIOEncode_tell,
PerlIOEncode_close,
BOOT:
{
+ SV *chk = get_sv("PerlIO::encoding::fallback", GV_ADD|GV_ADDMULTI);
+ /*
+ * we now "use Encode ()" here instead of
+ * PerlIO/encoding.pm. This avoids SEGV when ":encoding()"
+ * is invoked without prior "use Encode". -- dankogai
+ */
+ PUSHSTACKi(PERLSI_MAGIC);
+ SPAGAIN;
+ if (!get_cv(OUR_DEFAULT_FB, 0)) {
+#if 0
+ /* This would just be an irritant now loading works */
+ Perl_warner(aTHX_ packWARN(WARN_IO), ":encoding without 'use Encode'");
+#endif
+ ENTER;
+ /* Encode needs a lot of stack - it is likely to move ... */
+ PUTBACK;
+ /* The SV is magically freed by load_module */
+ load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("Encode", 6), Nullsv, Nullsv);
+ SPAGAIN;
+ LEAVE;
+ }
+ PUSHMARK(sp);
+ PUTBACK;
+ if (call_pv(OUR_DEFAULT_FB, G_SCALAR) != 1) {
+ /* should never happen */
+ Perl_die(aTHX_ "%s did not return a value",OUR_DEFAULT_FB);
+ }
+ SPAGAIN;
+ sv_setsv(chk, POPs);
+ PUTBACK;
#ifdef PERLIO_LAYERS
- PerlIO_define_layer(aTHX_ &PerlIO_encode);
+ PerlIO_define_layer(aTHX_ &PerlIO_encode);
#endif
+ POPSTACK;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff