#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)
{
+#ifndef PERL_MICRO
if (f) {
int fd = PerlLIO_dup(PerlIO_fileno(f));
if (fd >= 0) {
else {
SETERRNO(EBADF, SS$_IVCHAN);
}
+#endif
return NULL;
}
PerlIO_list_t *
PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
{
- int i;
- PerlIO_list_t *list = PerlIO_list_alloc(aTHX);
- for (i=0; i < proto->cur; i++) {
- SV *arg = Nullsv;
- if (proto->array[i].arg)
- arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
- PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
+ PerlIO_list_t *list = (PerlIO_list_t *) NULL;
+ if (proto) {
+ int i;
+ list = PerlIO_list_alloc(aTHX);
+ for (i=0; i < proto->cur; i++) {
+ SV *arg = Nullsv;
+ if (proto->array[i].arg)
+ arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
+ PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
+ }
}
return list;
}
PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
PerlIO_allocate(aTHX); /* root slot is never used */
+ PerlIO_debug("Clone %p from %p\n",aTHX,proto);
while ((f = *table)) {
int i;
table = (PerlIO **) (f++);
{
PerlIO **table = &PL_perlio;
PerlIO *f;
+#ifdef USE_ITHREADS
+ PerlIO_debug("Destruct %p\n",aTHX);
+#endif
while ((f = *table)) {
int i;
table = (PerlIO **) (f++);
*/
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 {
}
}
-void
-PerlIO_cleanup(pTHX)
-{
- PerlIOUnix_refcnt_inc(0);
- PerlIOUnix_refcnt_inc(1);
- PerlIOUnix_refcnt_inc(2);
- PerlIO_cleantable(aTHX_ &PL_perlio);
-}
-
int
PerlIOUnix_refcnt_dec(int fd)
{
return cnt;
}
+void
+PerlIO_cleanup(pTHX)
+{
+ int i;
+#ifdef USE_ITHREADS
+ PerlIO_debug("Cleanup %p\n",aTHX);
+#endif
+ /* Raise STDIN..STDERR refcount so we don't close them */
+ for (i=0; i < 3; i++)
+ PerlIOUnix_refcnt_inc(i);
+ PerlIO_cleantable(aTHX_ &PL_perlio);
+ /* Restore STDIN..STDERR refcount */
+ for (i=0; i < 3; i++)
+ PerlIOUnix_refcnt_dec(i);
+}
+
+
+
/*--------------------------------------------------------------------------------------*/
/*
* Bottom-most level for UNIX-like case
if (f) {
char *path = SvPV_nolen(*args);
PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
- FILE *stdio =
- PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
+ FILE *stdio;
+ PerlIOUnix_refcnt_dec(fileno(s->stdio));
+ stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
s->stdio);
if (!s->stdio)
return NULL;
s->stdio = stdio;
+ PerlIOUnix_refcnt_inc(fileno(s->stdio));
return f;
}
else {
PerlIOArg),
PerlIOStdio);
s->stdio = stdio;
+ PerlIOUnix_refcnt_inc(fileno(s->stdio));
}
return f;
}
(aTHX_(f = PerlIO_allocate(aTHX)), self,
mode, PerlIOArg), PerlIOStdio);
s->stdio = stdio;
+ PerlIOUnix_refcnt_inc(fileno(s->stdio));
return f;
}
}
return NULL;
}
+PerlIO *
+PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+{
+ /* 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))) {
+ FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
+ PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
+ PerlIOUnix_refcnt_inc(fileno(stdio));
+ }
+ return f;
+}
+
+IV
+PerlIOStdio_close(PerlIO *f)
+{
+ dSYS;
+#ifdef SOCKS5_VERSION_NAME
+ int optval;
+ Sock_size_t optlen = sizeof(int);
+#endif
+ FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
+ if (PerlIOUnix_refcnt_dec(fileno(stdio)) > 0) {
+ /* Do not close it but do flush any buffers */
+ PerlIO_flush(f);
+ return 0;
+ }
+ return (
+#ifdef SOCKS5_VERSION_NAME
+ (getsockopt
+ (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
+ &optlen) <
+ 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
+#else
+ PerlSIO_fclose(stdio)
+#endif
+ );
+
+}
+
+
+
SSize_t
PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
{
}
IV
-PerlIOStdio_close(PerlIO *f)
-{
- dSYS;
-#ifdef SOCKS5_VERSION_NAME
- int optval;
- Sock_size_t optlen = sizeof(int);
-#endif
- FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
- return (
-#ifdef SOCKS5_VERSION_NAME
- (getsockopt
- (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
- &optlen) <
- 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
-#else
- PerlSIO_fclose(stdio)
-#endif
- );
-
-}
-
-IV
PerlIOStdio_flush(PerlIO *f)
{
dSYS;
#endif
-PerlIO *
-PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
-{
- /* This assumes no layers underneath - which is what
- happens, but is not how I remember it. NI-S 2001/10/16
- */
- int fd = PerlLIO_dup(PerlIO_fileno(o));
- if (fd >= 0) {
- char buf[8];
- FILE *stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o, buf));
- if (stdio) {
- if ((f = PerlIOBase_dup(aTHX_ f, o, param))) {
- PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
- }
- else {
- PerlSIO_fclose(stdio);
- }
- }
- else {
- PerlLIO_close(fd);
- f = NULL;
- }
- }
- return f;
-}
-
PerlIO_funcs PerlIO_stdio = {
"stdio",
sizeof(PerlIOStdio),
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 O_BINARY != O_TEXT
- /*
- * do something about failing setmode()? --jhi
- */
- PerlLIO_setmode(fd, O_BINARY);
-#endif
- if (init && fd == 2) {
+ 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__)
/*
- * 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;
+ }
}
}
}
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 */