#endif
-#ifdef PERLIO_IS_STDIO
-
-void
-PerlIO_init(pTHX)
-{
- PERL_UNUSED_CONTEXT;
- /*
- * Does nothing (yet) except force this file to be included in perl
- * binary. That allows this file to force inclusion of other functions
- * that may be required by loadable extensions e.g. for
- * FileHandle::tmpfile
- */
-}
-
-#undef PerlIO_tmpfile
-PerlIO *
-PerlIO_tmpfile(void)
-{
- return tmpfile();
-}
-
-#else /* PERLIO_IS_STDIO */
-
/*======================================================================================*/
/*
* Implement all the PerlIO interface ourselves.
XSRETURN(count);
}
-#endif /* USE_ATTIBUTES_FOR_PERLIO */
+#endif /* USE_ATTRIBUTES_FOR_PERLIO */
SV *
PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
else {
STRLEN len;
const char * const name = SvPV_const(ST(1), len);
- const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
+ const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0;
PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
ST(0) =
(layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
tab = &PerlIO_stdio;
#endif
PerlIO_debug("Pushing %s\n", tab->name);
- PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
- &PL_sv_undef);
+ PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
}
SV *
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
- PerlIO_list_push(aTHX_ PL_def_layerlist,
- PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
- &PL_sv_undef);
+ PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer,
+ &PL_sv_undef);
if (s) {
PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
}
if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
SETERRNO(EBADF, SS_IVCHAN);
+ PerlIO_save_errno(f);
return 0;
}
while (count > 0) {
char buf[8];
assert(self);
PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
- self ? self->name : "(Null)",
+ self->name,
(void*)f, (void*)o, (void*)param);
- if (self && self->Getarg)
- arg = (*self->Getarg)(aTHX_ o, param, flags);
+ if (self->Getarg)
+ arg = (*self->Getarg)(aTHX_ o, param, flags);
f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
PerlIOBase(f)->flags |= PERLIO_F_UTF8;
/* Must be called with PL_perlio_mutex locked. */
static void
-S_more_refcounted_fds(pTHX_ const int new_fd) {
+S_more_refcounted_fds(pTHX_ const int new_fd)
+ PERL_TSA_REQUIRES(PL_perlio_mutex)
+{
dVAR;
const int old_max = PL_perlio_fd_refcnt_size;
const int new_max = 16 + (new_fd & ~15);
if (len < 0) {
if (errno != EAGAIN) {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ PerlIO_save_errno(f);
}
}
else if (len == 0 && count != 0) {
if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
return -1;
}
- /*NOTREACHED*/
+ NOT_REACHED; /*NOTREACHED*/
}
SSize_t
if (len < 0) {
if (errno != EAGAIN) {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ PerlIO_save_errno(f);
}
}
return len;
if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
return -1;
}
- /*NOTREACHED*/
+ NOT_REACHED; /*NOTREACHED*/
}
Off_t
/* XXX this could use PerlIO_canset_fileno() and
* PerlIO_set_fileno() support from Configure
*/
-# if defined(__UCLIBC__)
+# if defined(HAS_FDCLOSE)
+ return fdclose(f, NULL) == 0 ? 1 : 0;
+# elif defined(__UCLIBC__)
/* uClibc must come before glibc because it defines __GLIBC__ as well. */
f->__filedes = -1;
return 1;
return 0;
if (stdio == stdout || stdio == stderr)
return PerlIO_flush(f);
+ }
+#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
+ if (invalidate) {
/* Tricky - must fclose(stdio) to free memory but not close(fd)
Use Sarathy's trick from maint-5.6 to invalidate the
fileno slot of the FILE *
SAVE_ERRNO;
invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
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. */
if (dupfd >= 0) {
PerlLIO_dup2(dupfd,fd);
PerlLIO_close(dupfd);
+ }
#ifdef USE_ITHREADS
- MUTEX_UNLOCK(&PL_perlio_mutex);
+ MUTEX_UNLOCK(&PL_perlio_mutex);
#endif
- }
return result;
}
}
return -1;
SETERRNO(0,0); /* just in case */
}
+#ifdef __sgi
+ /* Under some circumstances IRIX stdio fgetc() and fread()
+ * set the errno to ENOENT, which makes no sense according
+ * to either IRIX or POSIX. [rt.perl.org #123977] */
+ if (errno == ENOENT) SETERRNO(0,0);
+#endif
return got;
}
}
else if (count < 0 || PerlIO_error(n)) {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ PerlIO_save_errno(f);
code = -1;
break;
}
if (avail == 0)
PerlIOBase(f)->flags |= PERLIO_F_EOF;
else
+ {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ PerlIO_save_errno(f);
+ }
return -1;
}
b->end = b->buf + avail;
char tempname[] = "/tmp/PerlIO_XXXXXX";
const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
SV * sv = NULL;
- int old_umask = umask(0600);
+ int old_umask = umask(0177);
/*
* I have no idea how portable mkstemp() is ... NI-S
*/
return f;
}
+void
+Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
+{
+ if (!PerlIOValid(f))
+ return;
+ PerlIOBase(f)->err = errno;
+#ifdef VMS
+ PerlIOBase(f)->os_err = vaxc$errno;
+#elif defined(OS2)
+ PerlIOBase(f)->os_err = Perl_rc;
+#elif defined(WIN32)
+ PerlIOBase(f)->os_err = GetLastError();
+#endif
+}
+
+void
+Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
+{
+ if (!PerlIOValid(f))
+ return;
+ SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
+#ifdef OS2
+ Perl_rc = PerlIOBase(f)->os_err);
+#elif defined(WIN32)
+ SetLastError(PerlIOBase(f)->os_err);
+#endif
+}
+
#undef HAS_FSETPOS
#undef HAS_FGETPOS
-#endif /* PERLIO_IS_STDIO */
/*======================================================================================*/
/*
PerlIO_setpos(PerlIO *f, SV *pos)
{
if (SvOK(pos)) {
- STRLEN len;
- dTHX;
- const Off_t * const posn = (Off_t *) SvPV(pos, len);
- if (f && len == sizeof(Off_t))
- return PerlIO_seek(f, *posn, SEEK_SET);
+ if (f) {
+ dTHX;
+ STRLEN len;
+ const Off_t * const posn = (Off_t *) SvPV(pos, len);
+ if(len == sizeof(Off_t))
+ return PerlIO_seek(f, *posn, SEEK_SET);
+ }
}
SETERRNO(EINVAL, SS_IVCHAN);
return -1;
int
PerlIO_setpos(PerlIO *f, SV *pos)
{
- dTHX;
if (SvOK(pos)) {
- STRLEN len;
- Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
- if (f && len == sizeof(Fpos_t)) {
+ if (f) {
+ dTHX;
+ STRLEN len;
+ Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
+ if(len == sizeof(Fpos_t))
#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
- return fsetpos64(f, fpos);
+ return fsetpos64(f, fpos);
#else
- return fsetpos(f, fpos);
+ return fsetpos(f, fpos);
#endif
}
}
#endif
+/* print a failure format string message to stderr and fail exit the process
+ using only libc without depending on any perl data structures being
+ initialized.
+*/
+
+void
+Perl_noperl_die(const char* pat, ...)
+{
+ va_list(arglist);
+ PERL_ARGS_ASSERT_NOPERL_DIE;
+ va_start(arglist, pat);
+ vfprintf(stderr, pat, arglist);
+ va_end(arglist);
+ exit(1);
+}
+
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/