/* NOTREACHED */
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)
for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
{
PerlIO *f = table+i;
- if (*f)
+ if (*f)
{
PerlIO_close(f);
}
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)
if (*mode == 'b')
{
oflags |= O_BINARY;
- mode++;
- }
+ mode++;
+ }
+ /* Always open in binary mode */
+ oflags |= O_BINARY;
if (*mode || oflags == -1)
{
errno = EINVAL;
IV
PerlIOStdio_close(PerlIO *f)
{
+ int optval, optlen = sizeof(int);
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
- return fclose(stdio);
+ return(
+ (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
+ fclose(stdio) :
+ close(PerlIO_fileno(f)));
}
IV
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,STDCHAR);
- 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;
}
};
/*--------------------------------------------------------------------------------------*/
-/* 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;
projects / p5sagit/p5-mst-13.2.git / blobdiff