*/
#ifdef DOSISH
# if defined(atarist) || defined(__MINT__)
+ PERL_UNUSED_ARG(iotype);
if (!fflush(fp)) {
if (mode & O_BINARY)
((FILE *) fp)->_flag |= _IOBIN;
return 0;
# else
dTHX;
+ PERL_UNUSED_ARG(iotype);
#ifdef NETWARE
if (PerlLIO_setmode(fp, mode) != -1) {
#else
#else
# if defined(USEMYBINMODE)
dTHX;
+# if defined(__CYGWIN__)
+ PERL_UNUSED_ARG(iotype);
+# endif
if (my_binmode(fp, iotype, mode) != FALSE)
return 1;
else
#else
const char *s = CopFILE(PL_curcop);
STRLEN len;
- SV * const sv = newSVpvs("");
- Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s ? s : "(none)",
- (IV) CopLINE(PL_curcop));
+ SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
+ (IV) CopLINE(PL_curcop));
Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
s = SvPV_const(sv, len);
PerlIOl *l = PerlIOBase(f);
while (l) {
+ /* There is some collusion in the implementation of
+ XS_PerlIO_get_layers - it knows that name and flags are
+ generated as fresh SVs here, and takes advantage of that to
+ "copy" them by taking a reference. If it changes here, it needs
+ to change there too. */
SV * const name = l->tab && l->tab->name ?
newSVpv(l->tab->name, 0) : &PL_sv_undef;
SV * const arg = l->tab && l->tab->Getarg ?
*/
dVAR;
dXSARGS;
+ PERL_UNUSED_ARG(cv);
if (items)
PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
XSRETURN(0);
{
dVAR;
dXSARGS;
+ PERL_UNUSED_ARG(cv);
if (items < 2)
Perl_croak(aTHX_ "Usage class->find(name[,load])");
else {
while (t && (l = *t)) {
if (l->tab->Binmode) {
/* Has a handler - normal case */
- if ((*l->tab->Binmode)(aTHX_ f) == 0) {
+ if ((*l->tab->Binmode)(aTHX_ t) == 0) {
if (*t == l) {
/* Layer still there - move down a layer */
t = PerlIONext(t);
SSize_t
Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
+ PERL_ARGS_ASSERT_PERLIO_READ;
+
Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
}
SSize_t
Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
+ PERL_ARGS_ASSERT_PERLIO_UNREAD;
+
Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
}
SSize_t
Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
+ PERL_ARGS_ASSERT_PERLIO_WRITE;
+
Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
}
if (self->Getarg)
arg = (*self->Getarg)(aTHX_ o, param, flags);
f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
+ if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
+ PerlIOBase(f)->flags |= PERLIO_F_UTF8;
if (arg)
SvREFCNT_dec(arg);
}
}
}
-void PerlIO_teardown(pTHX) /* Call only from PERL_SYS_TERM(). */
+void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
{
dVAR;
+#if 0
+/* XXX we can't rely on an interpreter being present at this late stage,
+ XXX so we can't use a function like PerlLIO_write that relies on one
+ being present (at least in win32) :-(.
+ Disable for now.
+*/
#ifdef DEBUGGING
{
/* By now all filehandles should have been closed, so any
* stray (non-STD-)filehandles indicate *possible* (PerlIO)
* errors. */
+#define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
+#define PERLIO_TEARDOWN_MESSAGE_FD 2
+ char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
int i;
for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
- if (PL_perlio_fd_refcnt[i])
- PerlIO_debug("PerlIO_cleanup: fd %d refcnt=%d\n",
- i, PL_perlio_fd_refcnt[i]);
+ if (PL_perlio_fd_refcnt[i]) {
+ const STRLEN len =
+ my_snprintf(buf, sizeof(buf),
+ "PerlIO_teardown: fd %d refcnt=%d\n",
+ i, PL_perlio_fd_refcnt[i]);
+ PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
+ }
}
}
#endif
+#endif
/* Not bothering with PL_perlio_mutex since by now
* all the interpreters are gone. */
if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
s = PerlIOSelf(f, PerlIOStdio);
s->stdio = stdio;
+ PerlIOUnix_refcnt_inc(fileno(stdio));
}
}
return f;
int invalidate = 0;
IV result = 0;
int saveerr = 0;
- int dupfd = 0;
+ int dupfd = -1;
+#ifdef USE_ITHREADS
+ dVAR;
+#endif
#ifdef SOCKS5_VERSION_NAME
/* Socks lib overrides close() but stdio isn't linked to
that library (though we are) - so we must call close()
result = PerlIO_flush(f);
saveerr = errno;
invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
- if (!invalidate)
+ if (!invalidate) {
+#ifdef USE_ITHREADS
+ MUTEX_LOCK(&PL_perlio_mutex);
+ /* Right. We need a mutex here because for a brief while we
+ will have the situation that fd is actually closed. Hence if
+ a second thread were to get into this block, its dup() would
+ likely return our fd as its dupfd. (after all, it is closed)
+ Then if we get to the dup2() first, we blat the fd back
+ (messing up its temporary as a side effect) only for it to
+ then close its dupfd (== our fd) in its close(dupfd) */
+
+ /* There is, of course, a race condition, that any other thread
+ trying to input/output/whatever on this fd will be stuffed
+ for the duration of this little manoeuvrer. Perhaps we
+ should hold an IO mutex for the duration of every IO
+ operation if we know that invalidate doesn't work on this
+ platform, but that would suck, and could kill performance.
+
+ Except that correctness trumps speed.
+ Advice from klortho #11912. */
+#endif
dupfd = PerlLIO_dup(fd);
+#ifdef USE_ITHREADS
+ if (dupfd < 0) {
+ MUTEX_UNLOCK(&PL_perlio_mutex);
+ /* Oh cXap. This isn't going to go well. Not sure if we can
+ recover from here, or if closing this particular FILE *
+ is a good idea now. */
+ }
+#endif
+ }
}
result = PerlSIO_fclose(stdio);
/* We treat error from stdio as success if we invalidated
/* in SOCKS' case, let close() determine return value */
result = close(fd);
#endif
- if (dupfd) {
+ if (dupfd >= 0) {
PerlLIO_dup2(dupfd,fd);
PerlLIO_close(dupfd);
+#ifdef USE_ITHREADS
+ MUTEX_UNLOCK(&PL_perlio_mutex);
+#endif
}
return result;
}
#ifdef STDIO_PTR_LVALUE
PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
#ifdef STDIO_PTR_LVAL_SETS_CNT
- if (PerlSIO_get_cnt(stdio) != (cnt)) {
- assert(PerlSIO_get_cnt(stdio) == (cnt));
- }
+ assert(PerlSIO_get_cnt(stdio) == (cnt));
#endif
#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
/*
if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
s->stdio = stdio;
+ PerlIOUnix_refcnt_inc(fileno(stdio));
/* Link previous lower layers under new one */
*PerlIONext(f) = l;
}
PerlIO_findFILE(PerlIO *f)
{
PerlIOl *l = *f;
+ FILE *stdio;
while (l) {
if (l->tab == &PerlIO_stdio) {
PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
l = *PerlIONext(&l);
}
/* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
- return PerlIO_exportFILE(f, NULL);
+ /* However, we're not really exporting a FILE * to someone else (who
+ becomes responsible for closing it, or calling PerlIO_releaseFILE())
+ So we need to undo its refernce count increase on the underlying file
+ descriptor. We have to do this, because if the loop above returns you
+ the FILE *, then *it* didn't increase any reference count. So there's
+ only one way to be consistent. */
+ stdio = PerlIO_exportFILE(f, NULL);
+ if (stdio) {
+ const int fd = fileno(stdio);
+ if (fd >= 0)
+ PerlIOUnix_refcnt_dec(fd);
+ }
+ return stdio;
}
/* Use this to reverse PerlIO_exportFILE calls. */
PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
if (s->stdio == f) {
dTHX;
+ const int fd = fileno(f);
+ if (fd >= 0)
+ PerlIOUnix_refcnt_dec(fd);
PerlIO_pop(aTHX_ p);
return;
}
PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
{
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
+#ifndef DEBUGGING
+ PERL_UNUSED_ARG(cnt);
+#endif
if (!b->buf)
PerlIO_get_base(f);
b->ptr = ptr;
- if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
- assert(PerlIO_get_cnt(f) == cnt);
- assert(b->ptr >= b->buf);
- }
+ assert(PerlIO_get_cnt(f) == cnt);
+ assert(b->ptr >= b->buf);
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
}
PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
{
dTHX;
- SV * const sv = newSVpvs("");
+ SV * sv;
const char *s;
STRLEN len;
SSize_t wrote;
#ifdef NEED_VA_COPY
va_list apc;
Perl_va_copy(ap, apc);
- sv_vcatpvf(sv, fmt, &apc);
+ sv = vnewSVpvf(fmt, &apc);
#else
- sv_vcatpvf(sv, fmt, &ap);
+ sv = vnewSVpvf(fmt, &ap);
#endif
s = SvPV_const(sv, len);
wrote = PerlIO_write(f, s, len);
https://perl5.git.perl.org / perl5.git / blobdiff