table = (PerlIO **) (f++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
if (*f) {
- PerlIO_fdupopen(aTHX_ f, param);
+ (void) fp_dup(f, 0, param);
}
f++;
}
}
void
-PerlIO_cleanup(pTHX)
-{
- PerlIO_cleantable(aTHX_ &PL_perlio);
-}
-
-void
PerlIO_destruct(pTHX)
{
PerlIO **table = &PL_perlio;
}
}
+SV *
+PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
+{
+ if (!arg)
+ return Nullsv;
+#ifdef sv_dup
+ if (param) {
+ return sv_dup(arg, param);
+ }
+ else {
+ return newSVsv(arg);
+ }
+#else
+ return newSVsv(arg);
+#endif
+}
+
+PerlIO *
+PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+{
+ PerlIO *nexto = PerlIONext(o);
+ if (*nexto) {
+ PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
+ f = (*tab->Dup)(aTHX_ f, nexto, param);
+ }
+ if (f) {
+ PerlIO_funcs *self = PerlIOBase(o)->tab;
+ SV *arg = Nullsv;
+ 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);
+ }
+ }
+ f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
+ if (!f && arg) {
+ SvREFCNT_dec(arg);
+ }
+ }
+ return f;
+}
+
+#define PERLIO_MAX_REFCOUNTABLE_FD 2048
+#ifdef USE_THREADS
+perl_mutex PerlIO_mutex;
+#endif
+int PerlIO_fd_refcnt[PERLIO_MAX_REFCOUNTABLE_FD];
+
+void
+PerlIO_init(pTHX)
+{
+ /* Place holder for stdstreams call ??? */
+#ifdef USE_THREADS
+ MUTEX_INIT(&PerlIO_mutex);
+#endif
+}
+
+void
+PerlIOUnix_refcnt_inc(int fd)
+{
+ if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
+#ifdef USE_THREADS
+ MUTEX_LOCK(&PerlIO_mutex);
+#endif
+ PerlIO_fd_refcnt[fd]++;
+ PerlIO_debug("fd %d refcnt=%d\n",fd,PerlIO_fd_refcnt[fd]);
+#ifdef USE_THREADS
+ MUTEX_UNLOCK(&PerlIO_mutex);
+#endif
+ }
+}
+
+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)
+{
+ int cnt = 0;
+ if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
+#ifdef USE_THREADS
+ MUTEX_LOCK(&PerlIO_mutex);
+#endif
+ cnt = --PerlIO_fd_refcnt[fd];
+ PerlIO_debug("fd %d refcnt=%d\n",fd,cnt);
+#ifdef USE_THREADS
+ MUTEX_UNLOCK(&PerlIO_mutex);
+#endif
+ }
+ return cnt;
+}
+
/*--------------------------------------------------------------------------------------*/
/*
* Bottom-most level for UNIX-like case
PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
{
IV code = PerlIOBase_pushed(f, mode, arg);
+ PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
if (*PerlIONext(f)) {
- PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
s->fd = PerlIO_fileno(PerlIONext(f));
/*
* XXX could (or should) we retrieve the oflags from the open file
s->fd = fd;
s->oflags = imode;
PerlIOBase(f)->flags |= PERLIO_F_OPEN;
+ PerlIOUnix_refcnt_inc(fd);
return f;
}
else {
}
}
-SV *
-PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
-{
- if (!arg)
- return Nullsv;
-#ifdef sv_dup
- if (param) {
- return sv_dup(arg, param);
- }
- else {
- return newSVsv(arg);
- }
-#else
- return newSVsv(arg);
-#endif
-}
-
-PerlIO *
-PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
-{
- PerlIO *nexto = PerlIONext(o);
- if (*nexto) {
- PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
- f = (*tab->Dup)(aTHX_ f, nexto, param);
- }
- if (f) {
- PerlIO_funcs *self = PerlIOBase(o)->tab;
- SV *arg = Nullsv;
- 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);
- }
- }
- f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
- if (!f && arg) {
- SvREFCNT_dec(arg);
- }
- }
- return f;
-}
-
PerlIO *
PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
{
PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
- int fd = PerlLIO_dup(os->fd);
- if (fd >= 0) {
+ int fd = os->fd;
+ if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
f = PerlIOBase_dup(aTHX_ f, o, param);
if (f) {
/* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
s->fd = fd;
+ PerlIOUnix_refcnt_inc(fd);
return f;
}
- else {
- PerlLIO_close(fd);
- }
}
return NULL;
}
dTHX;
int fd = PerlIOSelf(f, PerlIOUnix)->fd;
int code = 0;
+ if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
+ if (PerlIOUnix_refcnt_dec(fd) > 0) {
+ PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
+ return 0;
+ }
+ }
+ else {
+ SETERRNO(EBADF,SS$_IVCHAN);
+ return -1;
+ }
while (PerlLIO_close(fd) != 0) {
if (errno != EINTR) {
code = -1;
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
+ */
+ int fd = 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;
+ PerlIOUnix_refcnt_inc(fd);
+ }
+ else {
+ PerlSIO_fclose(stdio);
+ }
+ }
+ else {
+ PerlLIO_close(fd);
+ f = NULL;
+ }
+ }
+ 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) {
+ 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),
if (f) {
PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
fd = PerlIO_fileno(f);
-#if O_BINARY != O_TEXT
+#if (O_BINARY != O_TEXT) && !defined(__BEOS__)
/*
* do something about failing setmode()? --jhi
*/
if (flags & PERLIO_F_CANREAD) {
PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
int fd = PerlIO_fileno(f);
- struct stat st;
- code = fstat(fd, &st);
+ Stat_t st;
+ code = Fstat(fd, &st);
if (code == 0 && S_ISREG(st.st_mode)) {
SSize_t len = st.st_size - b->posn;
if (len > 0) {
#endif /* HAS_MMAP */
-void
-PerlIO_init(pTHX)
-{
- /* Place holder for stdstreams call ??? */
-}
-
#undef PerlIO_stdin
PerlIO *
PerlIO_stdin(void)
}
#endif
+
+
+
+