IV
PerlIOEncode_close(pTHX_ PerlIO * f)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
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");
}
SvREFCNT_dec(e->bufsv);
e->bufsv = Nullsv;
}
e->base.buf = NULL;
e->base.ptr = NULL;
e->base.end = NULL;
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
return code;
}
IV
PerlIOMmap_map(pTHX_ PerlIO *f)
{
dVAR;
PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
const IV flags = PerlIOBase(f)->flags;
IV code = 0;
if (m->len)
abort();
if (flags & PERLIO_F_CANREAD) {
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
const int fd = PerlIO_fileno(f);
Stat_t st;
code = Fstat(fd, &st);
if (code == 0 && S_ISREG(st.st_mode)) {
SSize_t len = st.st_size - b->posn;
if (len > 0) {
Off_t posn;
if (PL_mmap_page_size <= 0)
Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
PL_mmap_page_size);
if (b->posn < 0) {
/*
* This is a hack - should never happen - open should
* have set it !
*/
b->posn = PerlIO_tell(PerlIONext(f));
}
posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
len = st.st_size - posn;
m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
if (m->mptr && m->mptr != (Mmap_t) - 1) {
#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
madvise(m->mptr, len, MADV_SEQUENTIAL);
#endif
#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
madvise(m->mptr, len, MADV_WILLNEED);
#endif
PerlIOBase(f)->flags =
(flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
b->end = ((STDCHAR *) m->mptr) + len;
b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
b->ptr = b->buf;
m->len = len;
}
else {
b->buf = NULL;
}
}
else {
PerlIOBase(f)->flags =
flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
b->buf = NULL;
b->ptr = b->end = b->ptr;
code = -1;
}
}
}
return code;
}
SSize_t PerlIOmIRC_read( pTHX_ PerlIO *f, void *vbuf, Size_t count ) {
STDCHAR *buf = ( STDCHAR * ) vbuf;
if ( f ) {
if ( !( PerlIOBase( f )->flags & PERLIO_F_CANREAD ) ) {
PerlIOBase( f )->flags |= PERLIO_F_ERROR;
SETERRNO( EBADF, SS_IVCHAN );
return 0;
}
while ( count > 0 ) {
get_cnt: {
SSize_t avail = PerlIO_get_cnt( f );
SSize_t take = 0;
if ( avail > 0 )
take = ( ( SSize_t )count < avail ) ? ( SSize_t )count : avail;
if ( take > 0 ) {
STDCHAR *ptr = PerlIO_get_ptr( f );
Copy( ptr, buf, take, STDCHAR );
PerlIO_set_ptrcnt( f, ptr + take, ( avail -= take ) );
count -= take;
buf += take;
if ( avail == 0 ) /* set_ptrcnt could have reset avail */
goto get_cnt;
}
if ( count > 0 && avail <= 0 ) {
if ( PerlIO_fill( f ) != 0 )
break;
}
}
}
return ( buf - ( STDCHAR * ) vbuf );
}
return 0;
}
SSize_t
PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
{
if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
Off_t offset;
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
SV *sv = s->var;
char *dst;
if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
dst = SvGROW(sv, SvCUR(sv) + count);
offset = SvCUR(sv);
s->posn = offset + count;
}
else {
if ((s->posn + count) > SvCUR(sv))
dst = SvGROW(sv, (STRLEN)s->posn + count);
else
dst = SvPV_nolen(sv);
offset = s->posn;
s->posn += count;
}
Move(vbuf, dst + offset, count, char);
if ((STRLEN) s->posn > SvCUR(sv))
SvCUR_set(sv, (STRLEN)s->posn);
SvPOK_on(s->var);
return count;
}
IV
PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
PerlIO_funcs * tab)
{
IV code;
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
/* If called (normally) via open() then arg is ref to scalar we are
* using, otherwise arg (from binmode presumably) is either NULL
* or the _name_ of the scalar
*/
if (arg) {
if (SvROK(arg)) {
s->var = SvREFCNT_inc(SvRV(arg));
if (!SvPOK(s->var) && SvTYPE(SvRV(arg)) > SVt_NULL)
(void)SvPV_nolen(s->var);
}
else {
s->var =
SvREFCNT_inc(perl_get_sv
(SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
}
}
else {
s->var = newSVpvn("", 0);
}
SvUPGRADE(s->var, SVt_PV);
code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
SvCUR(s->var) = 0;
if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
s->posn = SvCUR(s->var);
else
s->posn = 0;
return code;
}
SSize_t
PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
PerlIOBuf * const b = &m->base;
if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
PerlIO_flush(f);
if (b->ptr && (b->ptr - count) >= b->buf
&& memEQ(b->ptr - count, vbuf, count)) {
b->ptr -= count;
PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
return count;
}
if (m->len) {
/*
* Loose the unwritable mapped buffer
*/
PerlIO_flush(f);
/*
* If flush took the "buffer" see if we have one from before
*/
if (!b->buf && m->bbuf)
b->buf = m->bbuf;
if (!b->buf) {
PerlIOBuf_get_base(aTHX_ f);
m->bbuf = b->buf;
}
}
return PerlIOBuf_unread(aTHX_ f, vbuf, count);
}
SSize_t
PerlIOWin32_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
DWORD len;
if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
return 0;
if (ReadFile(s->h,vbuf,count,&len,NULL))
{
return len;
}
else
{
if (GetLastError() != NO_ERROR)
{
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
PerlIO_save_errno(f);
return -1;
}
else
{
if (count != 0)
PerlIOBase(f)->flags |= PERLIO_F_EOF;
return 0;
}
}
}
STDCHAR *
PerlIOMmap_get_base(pTHX_ PerlIO *f)
{
PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
PerlIOBuf * const b = &m->base;
if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
/*
* Already have a readbuffer in progress
*/
return b->buf;
}
if (b->buf) {
/*
* We have a write buffer or flushed PerlIOBuf read buffer
*/
m->bbuf = b->buf; /* save it in case we need it again */
b->buf = NULL; /* Clear to trigger below */
}
if (!b->buf) {
PerlIOMmap_map(aTHX_ f); /* Try and map it */
if (!b->buf) {
/*
* Map did not work - recover PerlIOBuf buffer if we have one
*/
b->buf = m->bbuf;
}
}
b->ptr = b->end = b->buf;
if (b->buf)
return b->buf;
return PerlIOBuf_get_base(aTHX_ f);
}
IV
PerlIOMmap_unmap(pTHX_ PerlIO *f)
{
PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
IV code = 0;
if (m->len) {
PerlIOBuf * const b = &m->base;
if (b->buf) {
/* The munmap address argument is tricky: depending on the
* standard it is either "void *" or "caddr_t" (which is
* usually "char *" (signed or unsigned). If we cast it
* to "void *", those that have it caddr_t and an uptight
* C++ compiler, will freak out. But casting it as char*
* should work. Maybe. (Using Mmap_t figured out by
* Configure doesn't always work, apparently.) */
code = munmap((char*)m->mptr, m->len);
b->buf = NULL;
m->len = 0;
m->mptr = NULL;
if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
code = -1;
}
b->ptr = b->end = b->buf;
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
}
return code;
}
IV
PerlIOScalar_close(pTHX_ PerlIO * f)
{
IV code = PerlIOBase_close(aTHX_ f);
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
return code;
}
SSize_t
PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
PerlIOBuf * const b = &m->base;
if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
/*
* No, or wrong sort of, buffer
*/
if (m->len) {
if (PerlIOMmap_unmap(aTHX_ f) != 0)
return 0;
}
/*
* If unmap took the "buffer" see if we have one from before
*/
if (!b->buf && m->bbuf)
b->buf = m->bbuf;
if (!b->buf) {
PerlIOBuf_get_base(aTHX_ f);
m->bbuf = b->buf;
}
}
return PerlIOBuf_write(aTHX_ f, vbuf, count);
}
IV
PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
PerlIO_funcs * tab)
{
IV code;
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
/* If called (normally) via open() then arg is ref to scalar we are
* using, otherwise arg (from binmode presumably) is either NULL
* or the _name_ of the scalar
*/
if (arg) {
if (SvROK(arg)) {
if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') {
if (ckWARN(WARN_LAYER))
Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
SETERRNO(EINVAL, SS_IVCHAN);
return -1;
}
s->var = SvREFCNT_inc(SvRV(arg));
SvGETMAGIC(s->var);
if (!SvPOK(s->var) && SvOK(s->var))
(void)SvPV_nomg_const_nolen(s->var);
}
else {
s->var =
SvREFCNT_inc(perl_get_sv
(SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
}
}
else {
s->var = newSVpvn("", 0);
}
SvUPGRADE(s->var, SVt_PV);
code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
SvCUR_set(s->var, 0);
if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
s->posn = SvCUR(s->var);
else
s->posn = 0;
return code;
}
IV
PerlIOWin32_popped(pTHX_ PerlIO *f)
{
PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
if (--s->refcnt > 0)
{
*f = PerlIOBase(f)->next;
return 1;
}
fdtable[s->fd] = NULL;
return 0;
}
IV
PerlIOMmap_fill(pTHX_ PerlIO *f)
{
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
IV code = PerlIO_flush(f);
if (code == 0 && !b->buf) {
code = PerlIOMmap_map(aTHX_ f);
}
if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
code = PerlIOBuf_fill(aTHX_ f);
}
return code;
}
SSize_t
PerlIOWin32_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
DWORD len;
if (WriteFile(s->h,vbuf,count,&len,NULL))
{
return len;
}
else
{
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
PerlIO_save_errno(f);
return -1;
}
}
IV
PerlIOWin32_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
IV code = PerlIOBase_pushed(aTHX_ f,mode,arg,tab);
if (*PerlIONext(f))
{
PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
s->fd = PerlIO_fileno(PerlIONext(f));
}
PerlIOBase(f)->flags |= PERLIO_F_OPEN;
Perl_ck_warner_d(aTHX_
packWARN(WARN_EXPERIMENTAL__WIN32_PERLIO),
"PerlIO layer ':win32' is experimental");
return code;
}
IV
PerlIOWin32_close(pTHX_ PerlIO *f)
{
PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
if (s->refcnt == 1)
{
IV code = 0;
#if 0
/* This does not do pipes etc. correctly */
if (!CloseHandle(s->h))
{
s->h = INVALID_HANDLE_VALUE;
return -1;
}
#else
PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
return win32_close(s->fd);
#endif
}
return 0;
}
IV
PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs *tab)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
dSP;
IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv,tab);
SV *result = Nullsv;
PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(arg);
PUTBACK;
if (call_pv("Encode::find_encoding", G_SCALAR) != 1) {
/* should never happen */
Perl_die(aTHX_ "Encode::find_encoding did not return a value");
return -1;
}
SPAGAIN;
result = POPs;
PUTBACK;
if (!SvROK(result) || !SvOBJECT(SvRV(result))) {
e->enc = Nullsv;
if (ckWARN_d(WARN_IO))
Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
arg);
errno = EINVAL;
code = -1;
}
else {
/* $enc->renew */
PUSHMARK(sp);
XPUSHs(result);
PUTBACK;
if (call_method("renew",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
if (ckWARN_d(WARN_IO))
Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support renew method",
arg);
}
else {
SPAGAIN;
result = POPs;
PUTBACK;
}
e->enc = newSVsv(result);
PUSHMARK(sp);
XPUSHs(e->enc);
PUTBACK;
if (call_method("needs_lines",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
if (ckWARN_d(WARN_IO))
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));
e->inEncodeCall = 0;
FREETMPS;
LEAVE;
POPSTACK;
return code;
}
PerlIO *
PerlIOWin32_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
{
const char *tmode = mode;
HANDLE h = INVALID_HANDLE_VALUE;
if (f)
{
/* Close if already open */
if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
(*PerlIOBase(f)->tab->Close)(aTHX_ f);
}
if (narg > 0)
{
char *path = SvPV_nolen(*args);
DWORD access = 0;
/* CRT uses _SH_DENYNO for open(), this the Win32 equivelent */
DWORD share = FILE_SHARE_READ | FILE_SHARE_WRITE;
DWORD create = -1;
DWORD attr = FILE_ATTRIBUTE_NORMAL;
if (stricmp(path, "/dev/null")==0)
path = "NUL";
if (*mode == '#')
{
/* sysopen - imode is UNIX-like O_RDONLY etc.
- do_open has converted that back to string form in mode as well
- perm is UNIX like permissions
*/
mode++;
}
else
{
/* Normal open - decode mode string */
}
switch(*mode)
{
case 'r':
access = GENERIC_READ;
create = OPEN_EXISTING;
if (*++mode == '+')
{
access |= GENERIC_WRITE;
create = OPEN_ALWAYS;
mode++;
}
break;
case 'w':
access = GENERIC_WRITE;
create = TRUNCATE_EXISTING;
if (*++mode == '+')
{
access |= GENERIC_READ;
mode++;
}
break;
case 'a':
access = GENERIC_WRITE;
create = OPEN_ALWAYS;
if (*++mode == '+')
{
access |= GENERIC_READ;
mode++;
}
break;
}
if (*mode == 'b')
{
mode++;
}
else if (*mode == 't')
{
mode++;
}
if (*mode || create == -1)
{
SETERRNO(EINVAL,LIB$_INVARG);
return NULL;
}
h = CreateFile(path,access,share,NULL,create,attr,NULL);
if (h == INVALID_HANDLE_VALUE)
{
if (create == TRUNCATE_EXISTING)
h = CreateFile(path,access,share,NULL,(create = OPEN_ALWAYS),attr,NULL);
}
}
else
{
/* fd open */
h = INVALID_HANDLE_VALUE;
if (fd >= 0 && fd <= max_open_fd)
{
PerlIOWin32 *s = fdtable[fd];
if (s)
{
s->refcnt++;
if (!f)
f = PerlIO_allocate(aTHX);
*f = &s->base;
return f;
}
}
if (*mode == 'I')
{
mode++;
switch(fd)
{
case 0:
h = GetStdHandle(STD_INPUT_HANDLE);
break;
case 1:
h = GetStdHandle(STD_OUTPUT_HANDLE);
break;
case 2:
h = GetStdHandle(STD_ERROR_HANDLE);
break;
}
}
}
if (h != INVALID_HANDLE_VALUE)
fd = win32_open_osfhandle((intptr_t) h, PerlIOUnix_oflags(tmode));
if (fd >= 0)
{
PerlIOWin32 *s;
if (!f)
f = PerlIO_allocate(aTHX);
s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32);
s->h = h;
s->fd = fd;
s->refcnt = 1;
if (fd >= 0)
{
fdtable[fd] = s;
if (fd > max_open_fd)
max_open_fd = fd;
}
return f;
}
if (f)
{
/* FIXME: pop layers ??? */
}
return NULL;
}
IV
PerlIOEncode_flush(pTHX_ PerlIO * f)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
IV code = 0;
if (e->bufsv) {
dSP;
SV *str;
char *s;
STRLEN len;
SSize_t count = 0;
if ((PerlIOBase(f)->flags & PERLIO_F_WRBUF) && (e->base.ptr > e->base.buf)) {
if (e->inEncodeCall) return 0;
/* Write case - encode the buffer and write() to layer below */
PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(e->enc);
SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
SvUTF8_on(e->bufsv);
XPUSHs(e->bufsv);
XPUSHs(e->chk);
PUTBACK;
e->inEncodeCall = 1;
if (call_method("encode", G_SCALAR) != 1) {
e->inEncodeCall = 0;
Perl_die(aTHX_ "panic: encode did not return a value");
}
e->inEncodeCall = 0;
SPAGAIN;
str = POPs;
PUTBACK;
s = SvPV(str, len);
count = PerlIO_write(PerlIONext(f),s,len);
if ((STRLEN)count != len) {
code = -1;
}
FREETMPS;
LEAVE;
POPSTACK;
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 */
/* 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 ((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) {
if (e->inEncodeCall) return 0;
/* Bother - have unread data.
re-encode and unread() to layer below
*/
PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
ENTER;
SAVETMPS;
str = sv_newmortal();
sv_upgrade(str, SVt_PV);
SvPV_set(str, (char*)e->base.ptr);
SvLEN_set(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(e->chk);
PUTBACK;
e->inEncodeCall = 1;
if (call_method("encode", G_SCALAR) != 1) {
e->inEncodeCall = 0;
Perl_die(aTHX_ "panic: encode did not return a value");
}
e->inEncodeCall = 0;
SPAGAIN;
str = POPs;
PUTBACK;
s = SvPV(str, len);
count = PerlIO_unread(PerlIONext(f),s,len);
if ((STRLEN)count != len) {
code = -1;
}
FREETMPS;
LEAVE;
POPSTACK;
}
}
e->base.ptr = e->base.end = e->base.buf;
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
}
return code;
}
IV
PerlIOEncode_fill(pTHX_ PerlIO * f)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
dSP;
IV code = 0;
PerlIO *n;
SSize_t avail;
if (PerlIO_flush(f) != 0)
return -1;
n = PerlIONext(f);
if (!PerlIO_fast_gets(n)) {
/* Things get too messy if we don't have a buffer layer
push a :perlio to do the job */
char mode[8];
n = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
if (!n) {
Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
}
}
PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
ENTER;
SAVETMPS;
retry:
avail = PerlIO_get_cnt(n);
if (avail <= 0) {
avail = PerlIO_fill(n);
if (avail == 0) {
avail = PerlIO_get_cnt(n);
}
else {
if (!PerlIO_error(n) && PerlIO_eof(n))
avail = 0;
}
}
if (avail > 0 || (e->flags & NEEDS_LINES)) {
STDCHAR *ptr = PerlIO_get_ptr(n);
SSize_t use = (avail >= 0) ? avail : 0;
SV *uni;
char *s = NULL;
STRLEN len = 0;
e->base.ptr = e->base.end = (STDCHAR *) NULL;
(void) PerlIOEncode_get_base(aTHX_ f);
if (!e->dataSV)
e->dataSV = newSV(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 {
/* Create a "dummy" SV to represent the available data from layer below */
if (SvLEN(e->dataSV) && SvPVX_const(e->dataSV)) {
Safefree(SvPVX_mutable(e->dataSV));
}
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;
}
}
SvPV_set(e->dataSV, (char *) ptr);
SvLEN_set(e->dataSV, 0); /* Hands off sv.c - it isn't yours */
SvCUR_set(e->dataSV,use);
SvPOK_only(e->dataSV);
}
SvUTF8_off(e->dataSV);
PUSHMARK(sp);
XPUSHs(e->enc);
XPUSHs(e->dataSV);
XPUSHs(e->chk);
PUTBACK;
if (call_method("decode", G_SCALAR) != 1) {
Perl_die(aTHX_ "panic: decode did not return a value");
}
SPAGAIN;
uni = POPs;
PUTBACK;
/* Now get translated string (forced to UTF-8) and use as buffer */
if (SvPOK(uni)) {
s = SvPVutf8(uni, len);
#ifdef PARANOID_ENCODE_CHECKS
if (len && !is_utf8_string((U8*)s,len)) {
Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s);
}
#endif
}
if (len > 0) {
/* Got _something */
/* if decode gave us back dataSV then data may vanish when
we do ptrcnt adjust - so take our copy now.
(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 = (STDCHAR*)SvPVX(e->bufsv);
e->base.end = e->base.ptr + SvCUR(e->bufsv);
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
SvUTF8_on(e->bufsv);
/* Adjust ptr/cnt not taking anything which
did not translate - not clear this is a win */
/* compute amount we took */
use -= SvCUR(e->dataSV);
PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
/* and as we did not take it it isn't pending */
SvCUR_set(e->dataSV,0);
} else {
/* Got nothing - assume partial character so we need some more */
/* Make sure e->dataSV is a normal SV before re-filling as
buffer alias will change under us
*/
s = SvPV(e->dataSV,len);
sv_setpvn(e->dataSV,s,len);
PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
goto retry;
}
}
else {
end_of_file:
code = -1;
if (avail == 0)
PerlIOBase(f)->flags |= PERLIO_F_EOF;
else
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
}
FREETMPS;
LEAVE;
POPSTACK;
return code;
}