#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;
+}
+
+int
+PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
+{
+/* This used to be contents of do_binmode in doio.c */
+#ifdef DOSISH
+# if defined(atarist) || defined(__MINT__)
+ if (!PerlIO_flush(fp)) {
+ if (mode & O_BINARY)
+ ((FILE*)fp)->_flag |= _IOBIN;
+ else
+ ((FILE*)fp)->_flag &= ~ _IOBIN;
+ return 1;
+ }
+ return 0;
+# else
+ if (PerlLIO_setmode(PerlIO_fileno(fp), mode) != -1) {
+# if defined(WIN32) && defined(__BORLANDC__)
+ /* The translation mode of the stream is maintained independent
+ * of the translation mode of the fd in the Borland RTL (heavy
+ * digging through their runtime sources reveal). User has to
+ * set the mode explicitly for the stream (though they don't
+ * document this anywhere). GSAR 97-5-24
+ */
+ PerlIO_seek(fp,0L,0);
+ if (mode & O_BINARY)
+ ((FILE*)fp)->flags |= _F_BIN;
+ else
+ ((FILE*)fp)->flags &= ~ _F_BIN;
+# endif
+ return 1;
+ }
+ else
+ return 0;
+# endif
+#else
+# if defined(USEMYBINMODE)
+ if (my_binmode(fp, iotype, mode) != FALSE)
+ return 1;
+ else
+ return 0;
+# else
+ return 1;
+# endif
+#endif
}
+
+
+
+
#endif
#if !defined(PERL_IMPLICIT_SYS)
#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);
}
/*--------------------------------------------------------------------------------------*/
{
PerlIO *f = table+i;
if (*f)
- PerlIO_close(f);
+ {
+ PerlIO_close(f);
+ }
}
Safefree(table);
*tablep = NULL;
return tab;
}
+#define PerlIO_default_top() PerlIO_default_layer(-1)
+#define PerlIO_default_btm() PerlIO_default_layer(0)
+
+void
+PerlIO_stdstreams()
+{
+ if (!_perlio)
+ {
+ PerlIO_allocate();
+ PerlIO_fdopen(0,"Ir");
+ PerlIO_fdopen(1,"Iw");
+ PerlIO_fdopen(2,"Iw");
+ }
+}
+
+PerlIO *
+PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
+{
+ PerlIOl *l = NULL;
+ Newc('L',l,tab->size,char,PerlIOl);
+ if (l)
+ {
+ Zero(l,tab->size,char);
+ l->next = *f;
+ l->tab = tab;
+ *f = l;
+ if ((*l->tab->Pushed)(f,mode) != 0)
+ {
+ PerlIO_pop(f);
+ return NULL;
+ }
+ }
+ return f;
+}
+
int
PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
{
e++;
if (e > s)
{
- SV *layer = PerlIO_find_layer(s,e-s);
- if (layer)
+ if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
{
- PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
- if (tab)
+ /* Pop back to bottom layer */
+ if (PerlIONext(f))
{
- PerlIO *new = PerlIO_push(f,tab,mode);
- if (!new)
- return -1;
+ PerlIO_flush(f);
+ while (PerlIONext(f))
+ {
+ PerlIO_pop(f);
+ }
}
}
else
- Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
+ {
+ SV *layer = PerlIO_find_layer(s,e-s);
+ if (layer)
+ {
+ PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
+ if (tab)
+ {
+ PerlIO *new = PerlIO_push(f,tab,mode);
+ if (!new)
+ return -1;
+ }
+ }
+ else
+ Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
+ }
}
s = e;
}
return 0;
}
-#define PerlIO_default_top() PerlIO_default_layer(-1)
-#define PerlIO_default_btm() PerlIO_default_layer(0)
-void
-PerlIO_stdstreams()
-{
- if (!_perlio)
- {
- PerlIO_allocate();
- PerlIO_fdopen(0,"Ir");
- PerlIO_fdopen(1,"Iw");
- PerlIO_fdopen(2,"Iw");
- }
-}
-PerlIO *
-PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
+/*--------------------------------------------------------------------------------------*/
+/* Given the abstraction above the public API functions */
+
+int
+PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
{
- PerlIOl *l = NULL;
- Newc('L',l,tab->size,char,PerlIOl);
- if (l)
+ if (!names || (O_TEXT != O_BINARY && mode & O_BINARY))
{
- Zero(l,tab->size,char);
- l->next = *f;
- l->tab = tab;
- *f = l;
- if ((*l->tab->Pushed)(f,mode) != 0)
+ PerlIO *top = fp;
+ PerlIOl *l;
+ while (l = *top)
{
- PerlIO_pop(f);
- return NULL;
+ if (PerlIOBase(top)->tab == &PerlIO_crlf)
+ {
+ PerlIO_flush(top);
+ PerlIO_pop(top);
+ break;
+ }
+ top = PerlIONext(top);
}
}
- return f;
+ return PerlIO_apply_layers(aTHX_ fp, NULL, names) == 0 ? TRUE : FALSE;
}
-/*--------------------------------------------------------------------------------------*/
-/* Given the abstraction above the public API functions */
-
#undef PerlIO_close
int
PerlIO_close(PerlIO *f)
oflags |= O_WRONLY;
break;
}
+ if (*mode == 'b')
+ {
+ oflags |= O_BINARY;
+ mode++;
+ }
+ /* Always open in binary mode */
+ oflags |= O_BINARY;
if (*mode || oflags == -1)
{
errno = EINVAL;
IV
PerlIOStdio_close(PerlIO *f)
{
- return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
+ int optval, optlen = sizeof(int);
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ return(
+ (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
+ fclose(stdio) :
+ close(PerlIO_fileno(f)));
}
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)
SSize_t
PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
{
- PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
- STDCHAR *buf = (STDCHAR *) vbuf;
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ STDCHAR *buf = (STDCHAR *) vbuf;
if (f)
{
- Size_t got = 0;
if (!b->ptr)
PerlIO_get_base(f);
if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
return 0;
while (count > 0)
{
- SSize_t avail = (b->end - b->ptr);
- if ((SSize_t) count < avail)
- avail = count;
- if (avail > 0)
+ SSize_t avail = PerlIO_get_cnt(f);
+ SSize_t take = (count < avail) ? count : avail;
+ if (take > 0)
{
- Copy(b->ptr,buf,avail,char);
- got += avail;
- b->ptr += avail;
- count -= avail;
- buf += avail;
+ STDCHAR *ptr = PerlIO_get_ptr(f);
+ Copy(ptr,buf,take,STDCHAR);
+ PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
+ count -= take;
+ buf += take;
}
- if (count && (b->ptr >= b->end))
+ if (count > 0 && avail <= 0)
{
if (PerlIO_fill(f) != 0)
break;
}
}
- return got;
+ return (buf - (STDCHAR *) vbuf);
}
return 0;
}
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;
};
/*--------------------------------------------------------------------------------------*/
-/* crlf - translation currently just a copy of perlio to prove
- that extra buffering which real one will do is not an issue.
+/* crlf - translation
+ On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
+ to hand back a line at a time and keeping a record of which nl we "lied" about.
+ On write translate "\n" to CR,LF
*/
+typedef struct
+{
+ PerlIOBuf base; /* PerlIOBuf stuff */
+ STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
+} PerlIOCrlf;
+
+SSize_t
+PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
+{
+ const STDCHAR *buf = (const STDCHAR *) vbuf+count;
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
+ SSize_t unread = 0;
+ if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
+ PerlIO_flush(f);
+ if (c->nl)
+ {
+ *(c->nl) = 0xd;
+ c->nl = NULL;
+ }
+ if (!b->buf)
+ PerlIO_get_base(f);
+ if (b->buf)
+ {
+ if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
+ {
+ b->end = b->ptr = b->buf + b->bufsiz;
+ PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
+ }
+ while (count > 0 && b->ptr > b->buf)
+ {
+ int ch = *--buf;
+ if (ch == '\n')
+ {
+ if (b->ptr - 2 >= b->buf)
+ {
+ *--(b->ptr) = 0xa;
+ *--(b->ptr) = 0xd;
+ unread++;
+ count--;
+ }
+ else
+ {
+ buf++;
+ break;
+ }
+ }
+ else
+ {
+ *--(b->ptr) = ch;
+ unread++;
+ count--;
+ }
+ }
+ }
+ return unread;
+}
+
+SSize_t
+PerlIOCrlf_get_cnt(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (!b->buf)
+ PerlIO_get_base(f);
+ if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
+ {
+ PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
+ if (!c->nl)
+ {
+ STDCHAR *nl = b->ptr;
+ scan:
+ while (nl < b->end && *nl != 0xd)
+ nl++;
+ if (nl < b->end && *nl == 0xd)
+ {
+ test:
+ if (nl+1 < b->end)
+ {
+ if (nl[1] == 0xa)
+ {
+ *nl = '\n';
+ c->nl = nl;
+ }
+ else
+ {
+ /* Not CR,LF but just CR */
+ nl++;
+ goto scan;
+ }
+ }
+ else
+ {
+ /* Blast - found CR as last char in buffer */
+ if (b->ptr < nl)
+ {
+ /* They may not care, defer work as long as possible */
+ return (nl - b->ptr);
+ }
+ else
+ {
+ int code;
+ dTHX;
+ b->ptr++; /* say we have read it as far as flush() is concerned */
+ b->buf++; /* Leave space an front of buffer */
+ b->bufsiz--; /* Buffer is thus smaller */
+ code = PerlIO_fill(f); /* Fetch some more */
+ b->bufsiz++; /* Restore size for next time */
+ b->buf--; /* Point at space */
+ b->ptr = nl = b->buf; /* Which is what we hand off */
+ b->posn--; /* Buffer starts here */
+ *nl = 0xd; /* Fill in the CR */
+ if (code == 0)
+ goto test; /* fill() call worked */
+ /* CR at EOF - just fall through */
+ }
+ }
+ }
+ }
+ return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
+ }
+ return 0;
+}
+
+void
+PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
+ if (!b->buf)
+ PerlIO_get_base(f);
+ if (!ptr)
+ {
+ if (c->nl)
+ ptr = c->nl+1;
+ else
+ {
+ ptr = b->end;
+ if (ptr > b->buf && ptr[-1] == 0xd)
+ ptr--;
+ }
+ ptr -= cnt;
+ }
+ else
+ {
+ /* Test code - delete when it works ... */
+ STDCHAR *chk;
+ if (c->nl)
+ chk = c->nl+1;
+ else
+ {
+ chk = b->end;
+ if (chk > b->buf && chk[-1] == 0xd)
+ chk--;
+ }
+ chk -= cnt;
+
+ if (ptr != chk)
+ {
+ dTHX;
+ Perl_croak(aTHX_ "ptr wrong %p != %p nl=%p e=%p for %d",
+ ptr, chk, c->nl, b->end, cnt);
+ }
+ }
+ if (c->nl)
+ {
+ if (ptr > c->nl)
+ {
+ /* They have taken what we lied about */
+ *(c->nl) = 0xd;
+ c->nl = NULL;
+ ptr++;
+ }
+ }
+ b->ptr = ptr;
+ PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
+}
+
+SSize_t
+PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ const STDCHAR *buf = (const STDCHAR *) vbuf;
+ const STDCHAR *ebuf = buf+count;
+ if (!b->buf)
+ PerlIO_get_base(f);
+ if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
+ return 0;
+ while (buf < ebuf)
+ {
+ STDCHAR *eptr = b->buf+b->bufsiz;
+ PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
+ while (buf < ebuf && b->ptr < eptr)
+ {
+ if (*buf == '\n')
+ {
+ if ((b->ptr + 2) > eptr)
+ {
+ /* Not room for both */
+ PerlIO_flush(f);
+ break;
+ }
+ else
+ {
+ *(b->ptr)++ = 0xd; /* CR */
+ *(b->ptr)++ = 0xa; /* LF */
+ buf++;
+ if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
+ {
+ PerlIO_flush(f);
+ break;
+ }
+ }
+ }
+ else
+ {
+ int ch = *buf++;
+ *(b->ptr)++ = ch;
+ }
+ if (b->ptr >= eptr)
+ {
+ PerlIO_flush(f);
+ break;
+ }
+ }
+ }
+ return (buf - (STDCHAR *) vbuf);
+}
+
+IV
+PerlIOCrlf_flush(PerlIO *f)
+{
+ PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
+ if (c->nl)
+ {
+ *(c->nl) = 0xd;
+ c->nl = NULL;
+ }
+ return PerlIOBuf_flush(f);
+}
+
PerlIO_funcs PerlIO_crlf = {
"crlf",
- sizeof(PerlIOBuf),
+ sizeof(PerlIOCrlf),
0,
PerlIOBase_fileno,
PerlIOBuf_fdopen,
PerlIOBuf_open,
PerlIOBuf_reopen,
PerlIOBase_pushed,
- PerlIOBase_noop_ok,
- PerlIOBuf_read,
- PerlIOBuf_unread,
- PerlIOBuf_write,
+ PerlIOBase_noop_ok, /* popped */
+ PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
+ PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
+ PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
PerlIOBuf_seek,
PerlIOBuf_tell,
PerlIOBuf_close,
- PerlIOBuf_flush,
+ PerlIOCrlf_flush,
PerlIOBuf_fill,
PerlIOBase_eof,
PerlIOBase_error,
PerlIOBuf_get_base,
PerlIOBuf_bufsiz,
PerlIOBuf_get_ptr,
- PerlIOBuf_get_cnt,
- PerlIOBuf_set_ptrcnt,
+ PerlIOCrlf_get_cnt,
+ PerlIOCrlf_set_ptrcnt,
};
#ifdef HAS_MMAP
Mmap_t mptr; /* Mapped address */
Size_t len; /* mapped length */
STDCHAR *bbuf; /* malloced buffer if map fails */
-
} PerlIOMmap;
static size_t page_size = 0;
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