#define PERL_IN_PERLIO_C
#include "perl.h"
+#ifdef PERL_IMPLICIT_CONTEXT
+#undef dSYS
+#define dSYS dTHX
+#endif
+
#include "XSUB.h"
int
}
PerlIO *
-PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param)
+PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
{
#ifndef PERL_MICRO
if (f) {
#undef PerlIO_fdupopen
PerlIO *
-PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param)
+PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
{
if (f && *f) {
PerlIO_funcs *tab = PerlIOBase(f)->tab;
PerlIO *new;
PerlIO_debug("fdupopen f=%p param=%p\n",f,param);
- new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param);
+ new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param, flags);
return new;
}
else {
*/
char q = ((*s == '\'') ? '"' : '\'');
Perl_warn(aTHX_
- "perlio: invalid separator character %c%c%c in layer specification list",
- q, *s, q);
+ "perlio: invalid separator character %c%c%c in layer specification list %s",
+ q, *s, q, s);
return -1;
}
do {
PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
f, PerlIOBase(f)->tab->name, iotype, mode,
(names) ? names : "(Null)");
- PerlIO_flush(f);
- if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY))) {
- PerlIO *top = f;
- while (*top) {
- if (PerlIOBase(top)->tab == &PerlIO_crlf) {
- PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
- break;
+ /* Can't flush if switching encodings. */
+ if (!(names && memEQ(names, ":encoding(", 10))) {
+ PerlIO_flush(f);
+ if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY))) {
+ PerlIO *top = f;
+ while (*top) {
+ if (PerlIOBase(top)->tab == &PerlIO_crlf) {
+ PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
+ break;
+ }
+ top = PerlIONext(top);
+ PerlIO_flush(top);
}
- top = PerlIONext(top);
- PerlIO_flush(top);
}
}
return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
while (l) {
SV *arg =
(l->tab->Getarg) ? (*l->tab->
- Getarg) (&l) : &PL_sv_undef;
+ Getarg) (aTHX_ &l, NULL, 0) : &PL_sv_undef;
PerlIO_list_push(aTHX_ layera, l->tab, arg);
l = *PerlIONext(&l);
}
}
PerlIO *
-PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
{
PerlIO *nexto = PerlIONext(o);
if (*nexto) {
PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
- f = (*tab->Dup)(aTHX_ f, nexto, param);
+ f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
}
if (f) {
PerlIO_funcs *self = PerlIOBase(o)->tab;
char buf[8];
PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",self->name,f,o,param);
if (self->Getarg) {
- arg = (*self->Getarg)(o);
- if (arg) {
- arg = PerlIO_sv_dup(aTHX_ arg, param);
- }
+ arg = (*self->Getarg)(aTHX_ o,param,flags);
}
f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
- if (!f && arg) {
+ if (arg) {
SvREFCNT_dec(arg);
}
}
}
PerlIO *
-PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
{
PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
int fd = os->fd;
+ if (flags & PERLIO_DUP_FD) {
+ fd = PerlLIO_dup(fd);
+ }
if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
- f = PerlIOBase_dup(aTHX_ f, o, param);
+ f = PerlIOBase_dup(aTHX_ f, o, param, flags);
if (f) {
/* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
}
PerlIO *
-PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
{
/* This assumes no layers underneath - which is what
happens, but is not how I remember it. NI-S 2001/10/16
*/
- if ((f = PerlIOBase_dup(aTHX_ f, o, param))) {
+ if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
+ if (flags & PERLIO_DUP_FD) {
+ int fd = PerlLIO_dup(fileno(stdio));
+ if (fd >= 0) {
+ char mode[8];
+ stdio = fdopen(fd, PerlIO_modestr(o,mode));
+ }
+ else {
+ /* FIXME: To avoid messy error recovery if dup fails
+ re-use the existing stdio as though flag was not set
+ */
+ }
+ }
PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
PerlIOUnix_refcnt_inc(fileno(stdio));
}
f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
NULL, narg, args);
if (f) {
- PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
- fd = PerlIO_fileno(f);
+ if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
+ /*
+ * if push fails during open, open fails. close will pop us.
+ */
+ PerlIO_close (f);
+ return NULL;
+ } else {
+ fd = PerlIO_fileno(f);
#if (O_BINARY != O_TEXT) && !defined(__BEOS__)
- /*
- * do something about failing setmode()? --jhi
- */
- PerlLIO_setmode(fd, O_BINARY);
-#endif
- if (init && fd == 2) {
/*
- * Initial stderr is unbuffered
+ * do something about failing setmode()? --jhi
*/
- PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
+ PerlLIO_setmode(fd, O_BINARY);
+#endif
+ if (init && fd == 2) {
+ /*
+ * Initial stderr is unbuffered
+ */
+ PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
+ }
}
}
}
}
PerlIO *
-PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
{
- return PerlIOBase_dup(aTHX_ f, o, param);
+ return PerlIOBase_dup(aTHX_ f, o, param, flags);
}
int code;
b->ptr++; /* say we have read it as far as
* flush() is concerned */
- b->buf++; /* Leave space an front of buffer */
+ b->buf++; /* Leave space in front of buffer */
b->bufsiz--; /* Buffer is thus smaller */
code = PerlIO_fill(f); /* Fetch some more */
b->bufsiz++; /* Restore size for next time */
}
PerlIO *
-PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
{
- return PerlIOBase_dup(aTHX_ f, o, param);
+ return PerlIOBase_dup(aTHX_ f, o, param, flags);
}