#endif
/*
* This file provides those parts of PerlIO abstraction
- * which are not #defined in iperlsys.h.
+ * which are not #defined in perlio.h.
* Which these are depends on various Configure #ifdef's
*/
if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
{
return 0;
- }
+ }
Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
/* NOTREACHED */
- return -1;
+ return -1;
}
#endif
#include "XSUB.h"
-void PerlIO_debug(char *fmt,...) __attribute__((format(__printf__,1,2)));
+void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
void
-PerlIO_debug(char *fmt,...)
+PerlIO_debug(const char *fmt,...)
{
static int dbg = 0;
+ va_list ap;
+ va_start(ap,fmt);
if (!dbg)
{
char *s = PerlEnv_getenv("PERLIO_DEBUG");
if (dbg > 0)
{
dTHX;
- va_list ap;
SV *sv = newSVpvn("",0);
char *s;
STRLEN len;
- va_start(ap,fmt);
s = CopFILE(PL_curcop);
if (!s)
s = "(none)";
s = SvPV(sv,len);
PerlLIO_write(dbg,s,len);
- va_end(ap);
SvREFCNT_dec(sv);
}
+ va_end(ap);
}
/*--------------------------------------------------------------------------------------*/
for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
{
PerlIO *f = table+i;
- if (*f)
- PerlIO_close(f);
+ if (*f)
+ {
+ PerlIO_close(f);
+ }
}
Safefree(table);
*tablep = NULL;
PerlIO_define_layer(&PerlIO_unix);
PerlIO_define_layer(&PerlIO_perlio);
PerlIO_define_layer(&PerlIO_stdio);
+ PerlIO_define_layer(&PerlIO_crlf);
#ifdef HAS_MMAP
PerlIO_define_layer(&PerlIO_mmap);
#endif
SV *layer = PerlIO_find_layer(s,e-s);
if (layer)
{
- PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
+ PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
if (tab)
{
PerlIO *new = PerlIO_push(f,tab,mode);
oflags |= O_WRONLY;
break;
}
+ if (*mode == 'b')
+ {
+ oflags |= O_BINARY;
+ mode++;
+ }
if (*mode || oflags == -1)
{
errno = EINVAL;
IV
PerlIOStdio_close(PerlIO *f)
{
- return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ return fclose(stdio);
}
IV
PerlIOStdio_flush(PerlIO *f)
{
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
- return fflush(stdio);
+ if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
+ {
+ return fflush(stdio);
+ }
+ else
+ {
+#if 0
+ /* FIXME: This discards ungetc() and pre-read stuff which is
+ not right if this is just a "sync" from a layer above
+ Suspect right design is to do _this_ but not have layer above
+ flush this layer read-to-read
+ */
+ /* Not writeable - sync by attempting a seek */
+ int err = errno;
+ if (fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
+ errno = err;
+#endif
+ }
+ return 0;
}
IV
{
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
int c;
- if (fflush(stdio) != 0)
- return EOF;
+ /* fflush()ing read-only streams can cause trouble on some stdio-s */
+ if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
+ {
+ if (fflush(stdio) != 0)
+ return EOF;
+ }
c = fgetc(stdio);
if (c == EOF || ungetc(c,stdio) != c)
return EOF;
/* write() the buffer */
STDCHAR *p = b->buf;
int count;
+ PerlIO *n = PerlIONext(f);
while (p < b->ptr)
{
- count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
+ count = PerlIO_write(n,p,b->ptr - p);
if (count > 0)
{
p += count;
}
- else if (count < 0)
+ else if (count < 0 || PerlIO_error(n))
{
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
code = -1;
}
b->ptr = b->end = b->buf;
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
+ /* FIXME: Is this right for read case ? */
if (PerlIO_flush(PerlIONext(f)) != 0)
code = -1;
return code;
PerlIOBuf_fill(PerlIO *f)
{
PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ PerlIO *n = PerlIONext(f);
SSize_t avail;
+ /* FIXME: doing the down-stream flush is a bad idea if it causes
+ pre-read data in stdio buffer to be discarded
+ but this is too simplistic - as it skips _our_ hosekeeping
+ and breaks tell tests.
+ if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
+ {
+ }
+ */
if (PerlIO_flush(f) != 0)
return -1;
+
b->ptr = b->end = b->buf;
- avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
+ if (PerlIO_fast_gets(n))
+ {
+ /* Layer below is also buffered
+ * We do _NOT_ want to call its ->Read() because that will loop
+ * till it gets what we asked for which may hang on a pipe etc.
+ * Instead take anything it has to hand, or ask it to fill _once_.
+ */
+ 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)
+ {
+ STDCHAR *ptr = PerlIO_get_ptr(n);
+ SSize_t cnt = avail;
+ if (avail > b->bufsiz)
+ avail = b->bufsiz;
+ Copy(ptr,b->buf,avail,STDCHAR);
+ PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
+ }
+ }
+ else
+ {
+ avail = PerlIO_read(n,b->ptr,b->bufsiz);
+ }
if (avail <= 0)
{
if (avail == 0)
avail = count;
if (avail > 0)
{
- Copy(b->ptr,buf,avail,char);
+ Copy(b->ptr,buf,avail,STDCHAR);
got += avail;
b->ptr += avail;
count -= avail;
buf -= avail;
if (buf != b->ptr)
{
- Copy(buf,b->ptr,avail,char);
+ Copy(buf,b->ptr,avail,STDCHAR);
}
count -= avail;
unread += avail;
{
if (avail)
{
- Copy(buf,b->ptr,avail,char);
+ Copy(buf,b->ptr,avail,STDCHAR);
count -= avail;
buf += avail;
written += avail;
PerlIOBuf_set_ptrcnt,
};
+/*--------------------------------------------------------------------------------------*/
+/* crlf - translation currently just a copy of perlio to prove
+ that extra buffering which real one will do is not an issue.
+ */
+
+PerlIO_funcs PerlIO_crlf = {
+ "crlf",
+ sizeof(PerlIOBuf),
+ 0,
+ PerlIOBase_fileno,
+ PerlIOBuf_fdopen,
+ PerlIOBuf_open,
+ PerlIOBuf_reopen,
+ PerlIOBase_pushed,
+ PerlIOBase_noop_ok,
+ PerlIOBuf_read,
+ PerlIOBuf_unread,
+ PerlIOBuf_write,
+ PerlIOBuf_seek,
+ PerlIOBuf_tell,
+ PerlIOBuf_close,
+ PerlIOBuf_flush,
+ PerlIOBuf_fill,
+ PerlIOBase_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBuf_setlinebuf,
+ PerlIOBuf_get_base,
+ PerlIOBuf_bufsiz,
+ PerlIOBuf_get_ptr,
+ PerlIOBuf_get_cnt,
+ PerlIOBuf_set_ptrcnt,
+};
+
#ifdef HAS_MMAP
/*--------------------------------------------------------------------------------------*/
/* mmap as "buffer" layer */
SV *sv = newSVpvn("",0);
char *s;
STRLEN len;
+#ifdef NEED_VA_COPY
+ va_list apc;
+ Perl_va_copy(ap, apc);
+ sv_vcatpvf(sv, fmt, &apc);
+#else
sv_vcatpvf(sv, fmt, &ap);
+#endif
s = SvPV(sv,len);
return PerlIO_write(f,s,len);
}
PerlIO *
PerlIO_tmpfile(void)
{
- dTHX;
/* I have no idea how portable mkstemp() is ... */
+#if defined(WIN32) || !defined(HAVE_MKSTEMP)
+ PerlIO *f = NULL;
+ FILE *stdio = tmpfile();
+ if (stdio)
+ {
+ PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
+ s->stdio = stdio;
+ }
+ return f;
+#else
+ dTHX;
SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
int fd = mkstemp(SvPVX(sv));
PerlIO *f = NULL;
SvREFCNT_dec(sv);
}
return f;
+#endif
}
#undef HAS_FSETPOS
projects / p5sagit/p5-mst-13.2.git / blobdiff