sfset(sfstdout, SF_SHARE, 0);
}
+/* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
PerlIO *
PerlIO_importFILE(FILE *stdio, const char *mode)
{
int fd = fileno(stdio);
if (!mode || !*mode) {
- mmode = "r+";
+ mode = "r+";
}
return PerlIO_fdopen(fd, mode);
}
return def;
}
+IV
+PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
+{
+ if (PerlIOValid(f)) {
+ PerlIO_flush(f);
+ PerlIO_pop(aTHX_ f);
+ return 0;
+ }
+ return -1;
+}
+
+PerlIO_funcs PerlIO_remove = {
+ sizeof(PerlIO_funcs),
+ "pop",
+ 0,
+ PERLIO_K_DUMMY | PERLIO_K_UTF8,
+ PerlIOPop_pushed,
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL, /* flush */
+ NULL, /* fill */
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL, /* get_base */
+ NULL, /* get_bufsiz */
+ NULL, /* get_ptr */
+ NULL, /* get_cnt */
+ NULL, /* set_ptrcnt */
+};
+
PerlIO_list_t *
PerlIO_default_layers(pTHX)
{
PerlIO_define_layer(aTHX_ & PerlIO_mmap);
#endif
PerlIO_define_layer(aTHX_ & PerlIO_utf8);
+ PerlIO_define_layer(aTHX_ & PerlIO_remove);
PerlIO_define_layer(aTHX_ & PerlIO_byte);
PerlIO_list_push(aTHX_ PL_def_layerlist,
PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
PerlIO *
PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg)
{
- PerlIOl *l = NULL;
- Newc('L',l,tab->size,char,PerlIOl);
- if (l && f) {
- Zero(l, tab->size, char);
- l->next = *f;
- l->tab = tab;
- *f = l;
+ if (tab->fsize != sizeof(PerlIO_funcs)) {
+ mismatch:
+ Perl_croak(aTHX_ "Layer does not match this perl");
+ }
+ if (tab->size) {
+ PerlIOl *l = NULL;
+ if (tab->size < sizeof(PerlIOl)) {
+ goto mismatch;
+ }
+ /* Real layer with a data area */
+ Newc('L',l,tab->size,char,PerlIOl);
+ if (l && f) {
+ Zero(l, tab->size, char);
+ l->next = *f;
+ l->tab = tab;
+ *f = l;
+ PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
+ (mode) ? mode : "(Null)", (void*)arg);
+ if ((*l->tab->Pushed) (aTHX_ f, mode, arg, tab) != 0) {
+ PerlIO_pop(aTHX_ f);
+ return NULL;
+ }
+ }
+ }
+ else if (f) {
+ /* Pseudo-layer where push does its own stack adjust */
PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
(mode) ? mode : "(Null)", (void*)arg);
- if ((*l->tab->Pushed) (aTHX_ f, mode, arg) != 0) {
- PerlIO_pop(aTHX_ f);
+ if ((*tab->Pushed) (aTHX_ f, mode, arg, tab) != 0) {
return NULL;
}
}
}
IV
-PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
-{
- PerlIO_pop(aTHX_ f);
- if (*f) {
- PerlIO_flush(f);
- PerlIO_pop(aTHX_ f);
- return 0;
- }
- return -1;
-}
-
-IV
PerlIOBase_binmode(pTHX_ PerlIO *f)
{
if (PerlIOValid(f)) {
}
IV
-PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
if (PerlIOValid(f)) {
PerlIO *t;
PerlIOl *l;
- PerlIO_pop(aTHX_ f); /* Remove the dummy layer */
PerlIO_flush(f);
/*
* Strip all layers that are not suitable for a raw stream
* For any scalar type load the handler which is bundled with perl
*/
if (SvTYPE(sv) < SVt_PVAV)
- return PerlIO_find_layer(aTHX_ "Scalar", 6, 1);
+ return PerlIO_find_layer(aTHX_ "scalar", 6, 1);
/*
* For other types allow if layer is known but don't try and load it
incdef = 0;
}
/*
- * Don't fail if handler cannot be found :Via(...) etc. may do
+ * Don't fail if handler cannot be found :via(...) etc. may do
* something sensible else we will just stringfy and open
* resulting string.
*/
}
}
+
/*--------------------------------------------------------------------------------------*/
/*
* utf8 and raw dummy layers
*/
IV
-PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
- if (*PerlIONext(f)) {
- PerlIO_funcs *tab = PerlIOBase(f)->tab;
- PerlIO_pop(aTHX_ f);
+ if (PerlIOValid(f)) {
if (tab->kind & PERLIO_K_UTF8)
PerlIOBase(f)->flags |= PERLIO_F_UTF8;
else
}
PerlIO_funcs PerlIO_utf8 = {
+ sizeof(PerlIO_funcs),
"utf8",
- sizeof(PerlIOl),
+ 0,
PERLIO_K_DUMMY | PERLIO_K_UTF8,
PerlIOUtf8_pushed,
NULL,
};
PerlIO_funcs PerlIO_byte = {
+ sizeof(PerlIO_funcs),
"bytes",
- sizeof(PerlIOl),
+ 0,
PERLIO_K_DUMMY,
PerlIOUtf8_pushed,
NULL,
}
PerlIO_funcs PerlIO_raw = {
+ sizeof(PerlIO_funcs),
"raw",
- sizeof(PerlIOl),
+ 0,
PERLIO_K_DUMMY,
PerlIORaw_pushed,
PerlIOBase_popped,
}
char *
-PerlIO_modestr(PerlIO *f, char *buf)
+PerlIO_modestr(PerlIO * f, char *buf)
{
char *s = buf;
- IV flags = PerlIOBase(f)->flags;
- if (flags & PERLIO_F_APPEND) {
- *s++ = 'a';
- if (flags & PERLIO_F_CANREAD) {
- *s++ = '+';
+ if (PerlIOValid(f)) {
+ IV flags = PerlIOBase(f)->flags;
+ if (flags & PERLIO_F_APPEND) {
+ *s++ = 'a';
+ if (flags & PERLIO_F_CANREAD) {
+ *s++ = '+';
+ }
}
- }
- else if (flags & PERLIO_F_CANREAD) {
- *s++ = 'r';
- if (flags & PERLIO_F_CANWRITE)
- *s++ = '+';
- }
- else if (flags & PERLIO_F_CANWRITE) {
- *s++ = 'w';
- if (flags & PERLIO_F_CANREAD) {
- *s++ = '+';
+ else if (flags & PERLIO_F_CANREAD) {
+ *s++ = 'r';
+ if (flags & PERLIO_F_CANWRITE)
+ *s++ = '+';
+ }
+ else if (flags & PERLIO_F_CANWRITE) {
+ *s++ = 'w';
+ if (flags & PERLIO_F_CANREAD) {
+ *s++ = '+';
+ }
}
- }
#ifdef PERLIO_USING_CRLF
- if (!(flags & PERLIO_F_CRLF))
- *s++ = 'b';
+ if (!(flags & PERLIO_F_CRLF))
+ *s++ = 'b';
#endif
+ }
*s = '\0';
return buf;
}
+
IV
-PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
PerlIOl *l = PerlIOBase(f);
#if 0
const char *omode = mode;
char temp[8];
#endif
- PerlIO_funcs *tab = PerlIOBase(f)->tab;
l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
if (tab->Set_ptrcnt != NULL)
}
IV
-PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
- IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
+ IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
if (*PerlIONext(f)) {
/* We never call down so do any pending stuff now */
f = PerlIO_allocate(aTHX);
}
if (!PerlIOValid(f)) {
- s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg),
- PerlIOUnix);
- }
- else {
- s = PerlIOSelf(f, PerlIOUnix);
+ if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
+ return NULL;
+ }
}
+ s = PerlIOSelf(f, PerlIOUnix);
s->fd = fd;
s->oflags = imode;
PerlIOBase(f)->flags |= PERLIO_F_OPEN;
PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
int fd = PerlIOSelf(f, PerlIOUnix)->fd;
- if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
+ if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
+ PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
return 0;
+ }
while (1) {
SSize_t len = PerlLIO_read(fd, vbuf, count);
if (len >= 0 || errno != EINTR) {
}
PerlIO_funcs PerlIO_unix = {
+ sizeof(PerlIO_funcs),
"unix",
sizeof(PerlIOUnix),
PERLIO_K_RAW,
IV
PerlIOStdio_fileno(pTHX_ PerlIO *f)
{
- return PerlSIO_fileno(PerlIOSelf(f, PerlIOStdio)->stdio);
+ FILE *s;
+ if (PerlIOValid(f) && (s = PerlIOSelf(f, PerlIOStdio)->stdio)) {
+ return PerlSIO_fileno(s);
+ }
+ errno = EBADF;
+ return -1;
}
char *
return ret;
}
-/*
- * This isn't used yet ...
- */
IV
-PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
- if (*PerlIONext(f)) {
- PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
- char tmode[8];
- FILE *stdio =
- PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)), mode =
- PerlIOStdio_mode(mode, tmode));
- if (stdio) {
- s->stdio = stdio;
- /* We never call down so do any pending stuff now */
- PerlIO_flush(PerlIONext(f));
- }
- else
- return -1;
+ PerlIO *n;
+ if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
+ PerlIO_funcs *toptab = PerlIOBase(n)->tab;
+ if (toptab == tab) {
+ /* Top is already stdio - pop self (duplicate) and use original */
+ PerlIO_pop(aTHX_ f);
+ return 0;
+ } else {
+ int fd = PerlIO_fileno(n);
+ char tmode[8];
+ FILE *stdio;
+ if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
+ mode = PerlIOStdio_mode(mode, tmode)))) {
+ PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
+ /* We never call down so do any pending stuff now */
+ PerlIO_flush(PerlIONext(f));
+ }
+ else {
+ return -1;
+ }
+ }
}
- return PerlIOBase_pushed(aTHX_ f, mode, arg);
+ return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
}
varies between stdio implementations.
*/
int fd = PerlLIO_dup(fileno(stdio));
- FILE *f2 = fdopen(fd, (mode = "r+"));
+ FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
if (!f2) {
- f2 = fdopen(fd, (mode = "w"));
+ f2 = PerlSIO_fdopen(fd, (mode = "w"));
}
if (!f2) {
- f2 = fdopen(fd, (mode = "r"));
+ f2 = PerlSIO_fdopen(fd, (mode = "r"));
}
if (!f2) {
/* Don't seem to be able to open */
}
fclose(f2);
}
- s = PerlIOSelf(PerlIO_push
- (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
- mode, Nullsv), PerlIOStdio);
- s->stdio = stdio;
+ if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio, mode, Nullsv))) {
+ s = PerlIOSelf(f, PerlIOStdio);
+ s->stdio = stdio;
+ }
}
return f;
}
if (!f) {
f = PerlIO_allocate(aTHX);
}
- s = PerlIOSelf(PerlIO_push(aTHX_ f, self,
+ if ((f = PerlIO_push(aTHX_ f, self,
(mode = PerlIOStdio_mode(mode, tmode)),
- PerlIOArg),
- PerlIOStdio);
- s->stdio = stdio;
- PerlIOUnix_refcnt_inc(fileno(s->stdio));
+ PerlIOArg))) {
+ s = PerlIOSelf(f, PerlIOStdio);
+ s->stdio = stdio;
+ PerlIOUnix_refcnt_inc(fileno(s->stdio));
+ }
+ return f;
+ }
+ else {
+ return NULL;
}
- return f;
}
}
if (fd >= 0) {
if (!f) {
f = PerlIO_allocate(aTHX);
}
- s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg), PerlIOStdio);
- s->stdio = stdio;
- PerlIOUnix_refcnt_inc(fileno(s->stdio));
+ if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
+ s = PerlIOSelf(f, PerlIOStdio);
+ s->stdio = stdio;
+ PerlIOUnix_refcnt_inc(fileno(s->stdio));
+ }
return f;
}
}
int fd = PerlLIO_dup(fileno(stdio));
if (fd >= 0) {
char mode[8];
- stdio = fdopen(fd, PerlIO_modestr(o,mode));
+ stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
}
else {
/* FIXME: To avoid messy error recovery if dup fails
Sock_size_t optlen = sizeof(int);
#endif
FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
+ if (!stdio) {
+ errno = EBADF;
+ return -1;
+ }
if (PerlIOUnix_refcnt_dec(fileno(stdio)) > 0) {
/* Do not close it but do flush any buffers */
return PerlIO_flush(f);
PerlIO_funcs PerlIO_stdio = {
+ sizeof(PerlIO_funcs),
"stdio",
sizeof(PerlIOStdio),
PERLIO_K_BUFFERED|PERLIO_K_RAW,
- PerlIOBase_pushed,
+ PerlIOStdio_pushed,
PerlIOBase_popped,
PerlIOStdio_open,
PerlIOBase_binmode, /* binmode */
#endif /* USE_STDIO_PTR */
};
+/* Note that calls to PerlIO_exportFILE() are reversed using
+ * PerlIO_releaseFILE(), not importFILE. */
FILE *
-PerlIO_exportFILE(PerlIO *f, const char *mode)
+PerlIO_exportFILE(PerlIO * f, const char *mode)
{
dTHX;
- FILE *stdio;
- char buf[8];
- PerlIO_flush(f);
- if (!mode || !*mode) {
- mode = PerlIO_modestr(f,buf);
- }
- stdio = fdopen(PerlIO_fileno(f), mode);
- if (stdio) {
- PerlIOStdio *s =
- PerlIOSelf(PerlIO_push(aTHX_ f, &PerlIO_stdio, buf, Nullsv),
- PerlIOStdio);
- s->stdio = stdio;
+ FILE *stdio = NULL;
+ if (PerlIOValid(f)) {
+ char buf[8];
+ PerlIO_flush(f);
+ if (!mode || !*mode) {
+ mode = PerlIO_modestr(f, buf);
+ }
+ stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
+ if (stdio) {
+ PerlIOl *l = *f;
+ /* De-link any lower layers so new :stdio sticks */
+ *f = NULL;
+ if ((f = PerlIO_push(aTHX_ f, &PerlIO_stdio, buf, Nullsv))) {
+ PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
+ s->stdio = stdio;
+ /* Link previous lower layers under new one */
+ *PerlIONext(f) = l;
+ }
+ else {
+ /* restore layers list */
+ *f = l;
+ }
+ }
}
return stdio;
}
+
FILE *
PerlIO_findFILE(PerlIO *f)
{
return PerlIO_exportFILE(f, Nullch);
}
+/* Use this to reverse PerlIO_exportFILE calls. */
void
PerlIO_releaseFILE(PerlIO *p, FILE *f)
{
*/
IV
-PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
int fd = PerlIO_fileno(f);
b->posn = posn;
}
}
- return PerlIOBase_pushed(aTHX_ f, mode, arg);
+ return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
}
PerlIO *
PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
next = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
next, narg, args);
- if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg) != 0) {
+ if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
return NULL;
}
}
PerlIO_funcs PerlIO_perlio = {
+ sizeof(PerlIO_funcs),
"perlio",
sizeof(PerlIOBuf),
PERLIO_K_BUFFERED|PERLIO_K_RAW,
}
IV
-PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
- IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
+ IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
PerlIOl *l = PerlIOBase(f);
/*
* Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
}
PerlIO_funcs PerlIO_pending = {
+ sizeof(PerlIO_funcs),
"pending",
sizeof(PerlIOBuf),
PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
} PerlIOCrlf;
IV
-PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
IV code;
PerlIOBase(f)->flags |= PERLIO_F_CRLF;
- code = PerlIOBuf_pushed(aTHX_ f, mode, arg);
+ code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
#if 0
PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
}
PerlIO_funcs PerlIO_crlf = {
+ sizeof(PerlIO_funcs),
"crlf",
sizeof(PerlIOCrlf),
PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
PerlIO_funcs PerlIO_mmap = {
+ sizeof(PerlIO_funcs),
"mmap",
sizeof(PerlIOMmap),
PERLIO_K_BUFFERED|PERLIO_K_RAW,
PerlIO *f = NULL;
FILE *stdio = PerlSIO_tmpfile();
if (stdio) {
- PerlIOStdio *s =
- PerlIOSelf(PerlIO_push
- (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
- "w+", Nullsv), PerlIOStdio);
- s->stdio = stdio;
+ if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), &PerlIO_stdio, "w+", Nullsv))) {
+ PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
+ s->stdio = stdio;
+ }
}
return f;
#else
+
+
+