* Invent a dSYS macro to abstract this out
*/
#ifdef PERL_IMPLICIT_SYS
-#define dSYS dTHX
+# define dSYS dTHX
#else
-#define dSYS dNOOP
+# define dSYS dNOOP
#endif
#define PERLIO_NOT_STDIO 0
#include "perl.h"
#ifdef PERL_IMPLICIT_CONTEXT
-#undef dSYS
-#define dSYS dTHX
+# undef dSYS
+# define dSYS dTHX
#endif
#include "XSUB.h"
-#ifdef __Lynx__
-/* Missing proto on LynxOS */
-int mkstemp(char*);
-#endif
-
#ifdef VMS
-#include <rms.h>
+# include <rms.h>
#endif
#define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
#ifdef DOSISH
dTHX;
PERL_UNUSED_ARG(iotype);
-#ifdef NETWARE
+# ifdef NETWARE
if (PerlLIO_setmode(fp, mode) != -1) {
-#else
+# else
if (PerlLIO_setmode(fileno(fp), mode) != -1) {
-#endif
+# endif
return 1;
}
else
}
#ifndef O_ACCMODE
-#define O_ACCMODE 3 /* Assume traditional implementation */
+# define O_ACCMODE 3 /* Assume traditional implementation */
#endif
int
* with it won't do much good. */
if (rawmode & O_BINARY)
mode[ix++] = 'b';
-# endif
+#endif
mode[ix] = '\0';
return ptype;
}
PerlIO *
PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
{
-#if defined(PERL_MICRO) || defined(__SYMBIAN32__)
+# if defined(PERL_MICRO)
return NULL;
-#else
-#ifdef PERL_IMPLICIT_SYS
+# elif defined(PERL_IMPLICIT_SYS)
return PerlSIO_fdupopen(f);
-#else
-#ifdef WIN32
+# else
+# ifdef WIN32
return win32_fdupopen(f);
-#else
+# else
if (f) {
- const int fd = PerlLIO_dup(PerlIO_fileno(f));
+ const int fd = PerlLIO_dup_cloexec(PerlIO_fileno(f));
if (fd >= 0) {
char mode[8];
-#ifdef DJGPP
+# ifdef DJGPP
const int omode = djgpp_get_stream_mode(f);
-#else
+# else
const int omode = fcntl(fd, F_GETFL);
-#endif
+# endif
PerlIO_intmode2str(omode,mode,NULL);
/* the r+ is a hack */
return PerlIO_fdopen(fd, mode);
else {
SETERRNO(EBADF, SS_IVCHAN);
}
-#endif
+# endif
return NULL;
-#endif
-#endif
+# endif
}
return NULL;
if (*mode == IoTYPE_NUMERIC) {
- fd = PerlLIO_open3(name, imode, perm);
+ fd = PerlLIO_open3_cloexec(name, imode, perm);
if (fd >= 0)
return PerlIO_fdopen(fd, mode + 1);
}
#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.
{
va_list ap;
dSYS;
+
+ if (!DEBUG_i_TEST)
+ return;
+
va_start(ap, fmt);
+
if (!PL_perlio_debug_fd) {
if (!TAINTING_get &&
PerlProc_getuid() == PerlProc_geteuid() &&
PerlProc_getgid() == PerlProc_getegid()) {
const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
if (s && *s)
- PL_perlio_debug_fd
- = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
+ PL_perlio_debug_fd = PerlLIO_open3_cloexec(s,
+ O_WRONLY | O_CREAT | O_APPEND, 0666);
else
- PL_perlio_debug_fd = -1;
+ PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */
} else {
- /* tainting or set*id, so ignore the environment, and ensure we
- skip these tests next time through. */
- PL_perlio_debug_fd = -1;
+ /* tainting or set*id, so ignore the environment and send the
+ debug output to stderr, like other -D switches. */
+ PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */
}
}
if (PL_perlio_debug_fd > 0) {
/* Use fixed buffer as sv_catpvf etc. needs SVs */
char buffer[1024];
const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
+# ifdef USE_QUADMATH
+# ifdef HAS_VSNPRINTF
+ /* my_vsnprintf() isn't available with quadmath, but the native vsnprintf()
+ should be, otherwise the system isn't likely to support quadmath.
+ Nothing should be calling PerlIO_debug() with floating point anyway.
+ */
+ const STRLEN len2 = vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
+# else
+ STATIC_ASSERT_STMT(0);
+# endif
+# else
const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
+# endif
PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
#else
const char *s = CopFILE(PL_curcop);
{
PerlIOl *head, *p;
int seen = 0;
-#ifndef PERL_IMPLICIT_SYS
+# ifndef PERL_IMPLICIT_SYS
PERL_UNUSED_CONTEXT;
-#endif
+# endif
if (!PerlIOValid(f))
return;
p = head = PerlIOBase(f)->head;
{
if (PerlIOValid(f)) {
const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
- PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
+ DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) );
if (tab && tab->Dup)
return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
else {
PERL_UNUSED_CONTEXT;
if (list->cur >= list->len) {
- list->len += 8;
+ const IV new_len = list->len + 8;
if (list->array)
- Renew(list->array, list->len, PerlIO_pair_t);
+ Renew(list->array, new_len, PerlIO_pair_t);
else
- Newx(list->array, list->len, PerlIO_pair_t);
+ Newx(list->array, new_len, PerlIO_pair_t);
+ list->len = new_len;
}
p = &(list->array[list->cur++]);
p->funcs = funcs;
PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
PerlIO_init_table(aTHX);
- PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
+ DEBUG_i( PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto) );
while ((f = *table)) {
int i;
table = (PerlIOl **) (f++);
PerlIOl **table = &PL_perlio;
PerlIOl *f;
#ifdef USE_ITHREADS
- PerlIO_debug("Destruct %p\n",(void*)aTHX);
+ DEBUG_i( PerlIO_debug("Destruct %p\n",(void*)aTHX) );
#endif
while ((f = *table)) {
int i;
const PerlIOl *l;
while ((l = *x)) {
if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
- PerlIO_debug("Destruct popping %s\n", l->tab->name);
+ DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) );
PerlIO_flush(x);
PerlIO_pop(aTHX_ x);
}
const PerlIOl *l = *f;
VERIFY_HEAD(f);
if (l) {
- PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
- l->tab ? l->tab->name : "(Null)");
+ DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
+ l->tab ? l->tab->name : "(Null)") );
if (l->tab && l->tab->Popped) {
/*
* If popped returns non-zero do not free its layer structure
PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
const STRLEN this_len = strlen(f->name);
if (this_len == len && memEQ(f->name, name, len)) {
- PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
+ DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) );
return f;
}
}
return PerlIO_find_layer(aTHX_ name, len, 0);
}
}
- PerlIO_debug("Cannot find %.*s\n", (int) len, name);
+ DEBUG_i( PerlIO_debug("Cannot find %.*s\n", (int) len, name) );
return NULL;
}
XSRETURN(count);
}
-#endif /* USE_ATTIBUTES_FOR_PERLIO */
+#endif /* USE_ATTRIBUTES_FOR_PERLIO */
SV *
PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
during loading of layers.
*/
dXSARGS;
- PERL_UNUSED_ARG(cv);
- if (items)
- PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
+ PERL_UNUSED_VAR(items);
+ DEBUG_i(
+ if (items)
+ PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))) );
XSRETURN(0);
}
XS(XS_PerlIO__Layer__find)
{
dXSARGS;
- PERL_UNUSED_ARG(cv);
if (items < 2)
Perl_croak(aTHX_ "Usage class->find(name[,load])");
else {
if (!PL_known_layers)
PL_known_layers = PerlIO_list_alloc(aTHX);
PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
- PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
+ DEBUG_i( PerlIO_debug("define %s %p\n", tab->name, (void*)tab) );
}
int
if (*e++) {
break;
}
- /*
- * Drop through
- */
+ /* Fall through */
case '\0':
e--;
Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
if (PerlIO_stdio.Set_ptrcnt)
tab = &PerlIO_stdio;
#endif
- PerlIO_debug("Pushing %s\n", tab->name);
+ DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) );
PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
}
PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
{
if (n >= 0 && n < av->cur) {
- PerlIO_debug("Layer %" IVdf " is %s\n", n,
- av->array[n].funcs->name);
+ DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n,
+ av->array[n].funcs->name) );
return av->array[n].funcs;
}
if (!def)
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
#if defined(WIN32)
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
-#if 0
+# if 0
osLayer = &PerlIO_win32;
-#endif
+# endif
#endif
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
VERIFY_HEAD(f);
if (tab->fsize != sizeof(PerlIO_funcs)) {
Perl_croak( aTHX_
- "%s (%"UVuf") does not match %s (%"UVuf")",
+ "%s (%" UVuf ") does not match %s (%" UVuf ")",
"PerlIO layer function table size", (UV)tab->fsize,
"size expected by this perl", (UV)sizeof(PerlIO_funcs) );
}
PerlIOl *l;
if (tab->size < sizeof(PerlIOl)) {
Perl_croak( aTHX_
- "%s (%"UVuf") smaller than %s (%"UVuf")",
+ "%s (%" UVuf ") smaller than %s (%" UVuf ")",
"PerlIO layer instance size", (UV)tab->size,
"size expected by this perl", (UV)sizeof(PerlIOl) );
}
l->tab = (PerlIO_funcs*) tab;
l->head = ((PerlIOl*)f)->head;
*f = l;
- PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
- (void*)f, tab->name,
- (mode) ? mode : "(Null)", (void*)arg);
+ DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
+ (void*)f, tab->name,
+ (mode) ? mode : "(Null)", (void*)arg) );
if (*l->tab->Pushed &&
(*l->tab->Pushed)
(aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
}
else if (f) {
/* Pseudo-layer where push does its own stack adjust */
- PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
- (mode) ? mode : "(Null)", (void*)arg);
+ DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
+ (mode) ? mode : "(Null)", (void*)arg) );
if (tab->Pushed &&
(*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
return NULL;
}
}
if (PerlIOValid(f)) {
- PerlIO_debug(":raw f=%p :%s\n", (void*)f,
- PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
+ DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f,
+ PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)") );
return 0;
}
}
int
PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
{
- PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
- (PerlIOBase(f) && PerlIOBase(f)->tab) ?
- PerlIOBase(f)->tab->name : "(Null)",
- iotype, mode, (names) ? names : "(Null)");
+ PERL_UNUSED_ARG(iotype);
+ PERL_UNUSED_ARG(mode);
+
+ DEBUG_i(
+ PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
+ (PerlIOBase(f) && PerlIOBase(f)->tab) ?
+ PerlIOBase(f)->tab->name : "(Null)",
+ iotype, mode, (names) ? names : "(Null)") );
if (names) {
/* Do not flush etc. if (e.g.) switching encodings.
(for example :unix which is never going to call them)
it can do the flush when it is pushed.
*/
- return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
+ return cBOOL(PerlIO_apply_layers(aTHX_ f, NULL, names) == 0);
}
else {
/* Fake 5.6 legacy of using this call to turn ON O_TEXT */
/* Legacy binmode is now _defined_ as being equivalent to pushing :raw
So code that used to be here is now in PerlIORaw_pushed().
*/
- return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
+ return cBOOL(PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL));
}
}
int imode, int perm, PerlIO *f, int narg, SV **args)
{
if (!f && narg == 1 && *args == &PL_sv_undef) {
- if ((f = PerlIO_tmpfile())) {
+ imode = PerlIOUnix_oflags(mode);
+
+ if (imode != -1 && (f = PerlIO_tmpfile_flags(imode))) {
if (!layers || !*layers)
layers = Perl_PerlIO_context_layers(aTHX_ mode);
if (layers && *layers)
if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
}
- PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
- tab->name, layers ? layers : "(Null)", mode, fd,
- imode, perm, (void*)f, narg, (void*)args);
+ DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
+ tab->name, layers ? layers : "(Null)", mode, fd,
+ imode, perm, (void*)f, narg, (void*)args) );
if (tab->Open)
f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
f, narg, args);
return 0; /* If no Flush defined, silently succeed. */
}
else {
- PerlIO_debug("Cannot flush f=%p\n", (void*)f);
+ DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) );
SETERRNO(EBADF, SS_IVCHAN);
return -1;
}
SETERRNO(EINVAL, LIB_INVARG);
return -1;
}
+#ifdef EBCDIC
+ {
+ /* The mode variable contains one positional parameter followed by
+ * optional keyword parameters. The positional parameters must be
+ * passed as lowercase characters. The keyword parameters can be
+ * passed in mixed case. They must be separated by commas. Only one
+ * instance of a keyword can be specified. */
+ int comma = 0;
+ while (*mode) {
+ switch (*mode++) {
+ case '+':
+ if(!comma)
+ l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
+ break;
+ case 'b':
+ if(!comma)
+ l->flags &= ~PERLIO_F_CRLF;
+ break;
+ case 't':
+ if(!comma)
+ l->flags |= PERLIO_F_CRLF;
+ break;
+ case ',':
+ comma = 1;
+ break;
+ default:
+ break;
+ }
+ }
+ }
+#else
while (*mode) {
switch (*mode++) {
case '+':
return -1;
}
}
+#endif
}
else {
if (l->next) {
}
}
#if 0
+ DEBUG_i(
PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
(void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
l->flags, PerlIO_modestr(f, temp));
+ );
#endif
return 0;
}
SV *arg = NULL;
char buf[8];
assert(self);
- PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
- self ? self->name : "(Null)",
- (void*)f, (void*)o, (void*)param);
- if (self && self->Getarg)
- arg = (*self->Getarg)(aTHX_ o, param, flags);
+ DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
+ self->name,
+ (void*)f, (void*)o, (void*)param) );
+ 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) {
- dVAR;
+S_more_refcounted_fds(pTHX_ const int new_fd)
+ PERL_TSA_REQUIRES(PL_perlio_mutex)
+{
const int old_max = PL_perlio_fd_refcnt_size;
const int new_max = 16 + (new_fd & ~15);
int *new_array;
PERL_UNUSED_CONTEXT;
#endif
- PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
- old_max, new_fd, new_max);
+ DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
+ old_max, new_fd, new_max) );
if (new_fd < old_max) {
return;
new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
if (!new_array) {
-#ifdef USE_ITHREADS
MUTEX_UNLOCK(&PL_perlio_mutex);
-#endif
croak_no_mem();
}
PL_perlio_fd_refcnt_size = new_max;
PL_perlio_fd_refcnt = new_array;
- PerlIO_debug("Zeroing %p, %d\n",
- (void*)(new_array + old_max),
- new_max - old_max);
+ DEBUG_i( PerlIO_debug("Zeroing %p, %d\n",
+ (void*)(new_array + old_max),
+ new_max - old_max) );
Zero(new_array + old_max, new_max - old_max, int);
}
{
dTHX;
if (fd >= 0) {
- dVAR;
-#ifdef USE_ITHREADS
MUTEX_LOCK(&PL_perlio_mutex);
-#endif
if (fd >= PL_perlio_fd_refcnt_size)
S_more_refcounted_fds(aTHX_ fd);
Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
fd, PL_perlio_fd_refcnt[fd]);
}
- PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
- fd, PL_perlio_fd_refcnt[fd]);
+ DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
+ fd, PL_perlio_fd_refcnt[fd]) );
-#ifdef USE_ITHREADS
MUTEX_UNLOCK(&PL_perlio_mutex);
-#endif
} else {
/* diag_listed_as: refcnt_inc: fd %d%s */
Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
{
int cnt = 0;
if (fd >= 0) {
- dVAR;
-#ifdef USE_ITHREADS
- MUTEX_LOCK(&PL_perlio_mutex);
+#ifdef DEBUGGING
+ dTHX;
#endif
+ MUTEX_LOCK(&PL_perlio_mutex);
if (fd >= PL_perlio_fd_refcnt_size) {
/* diag_listed_as: refcnt_dec: fd %d%s */
Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
fd, PL_perlio_fd_refcnt[fd]);
}
cnt = --PL_perlio_fd_refcnt[fd];
- PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
-#ifdef USE_ITHREADS
+ DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) );
MUTEX_UNLOCK(&PL_perlio_mutex);
-#endif
} else {
/* diag_listed_as: refcnt_dec: fd %d%s */
Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
dTHX;
int cnt = 0;
if (fd >= 0) {
- dVAR;
-#ifdef USE_ITHREADS
MUTEX_LOCK(&PL_perlio_mutex);
-#endif
if (fd >= PL_perlio_fd_refcnt_size) {
/* diag_listed_as: refcnt: fd %d%s */
Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
fd, PL_perlio_fd_refcnt[fd]);
}
cnt = PL_perlio_fd_refcnt[fd];
-#ifdef USE_ITHREADS
MUTEX_UNLOCK(&PL_perlio_mutex);
-#endif
} else {
/* diag_listed_as: refcnt: fd %d%s */
Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
{
int i;
#ifdef USE_ITHREADS
- PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
+ DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) );
#else
- PerlIO_debug("Cleanup layers\n");
+ DEBUG_i( PerlIO_debug("Cleanup layers\n") );
#endif
/* Raise STDIN..STDERR refcount so we don't close them */
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
+# ifdef DEBUGGING
{
/* By now all filehandles should have been closed, so any
* stray (non-STD-)filehandles indicate *possible* (PerlIO)
}
}
}
-#endif
+# endif
#endif
/* Not bothering with PL_perlio_mutex since by now
* all the interpreters are gone. */
mode++;
break;
default:
-# if O_BINARY != 0
+#if O_BINARY != 0
/* bit-or:ing with zero O_BINARY would be useless. */
/*
* If neither "t" nor "b" was specified, open the file
* set the errno and invalidate the flags.
*/
oflags |= O_BINARY;
-# endif
+#endif
break;
}
if (*mode || oflags == -1) {
Stat_t st;
if (PerlLIO_fstat(fd, &st) == 0) {
if (!S_ISREG(st.st_mode)) {
- PerlIO_debug("%d is not regular file\n",fd);
+ DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) );
PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
}
else {
- PerlIO_debug("%d _is_ a regular file\n",fd);
+ DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) );
}
}
#endif
IV n, const char *mode, int fd, int imode,
int perm, PerlIO *f, int narg, SV **args)
{
+ bool known_cloexec = 0;
if (PerlIOValid(f)) {
if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
(*PerlIOBase(f)->tab->Close)(aTHX_ f);
const char *path = SvPV_const(*args, len);
if (!IS_SAFE_PATHNAME(path, len, "open"))
return NULL;
- fd = PerlLIO_open3(path, imode, perm);
+ fd = PerlLIO_open3_cloexec(path, imode, perm);
+ known_cloexec = 1;
}
}
if (fd >= 0) {
+ if (known_cloexec)
+ setfd_inhexec_for_sysfd(fd);
+ else
+ setfd_cloexec_or_inhexec_by_sysfdness(fd);
if (*mode == IoTYPE_IMPLICIT)
mode++;
if (!f) {
const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
int fd = os->fd;
if (flags & PERLIO_DUP_FD) {
- fd = PerlLIO_dup(fd);
+ fd = PerlLIO_dup_cloexec(fd);
+ if (fd >= 0)
+ setfd_inhexec_for_sysfd(fd);
}
if (fd >= 0) {
f = PerlIOBase_dup(aTHX_ f, o, param, flags);
if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
return -1;
fd = PerlIOSelf(f, PerlIOUnix)->fd;
-#ifdef PERLIO_STD_SPECIAL
- if (fd == 0)
- return PERLIO_STD_IN(fd, vbuf, count);
-#endif
if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
return 0;
if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
return -1;
}
- /*NOTREACHED*/
+ NOT_REACHED; /*NOTREACHED*/
}
SSize_t
if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
return -1;
fd = PerlIOSelf(f, PerlIOUnix)->fd;
-#ifdef PERLIO_STD_SPECIAL
- if (fd == 1 || fd == 2)
- return PERLIO_STD_OUT(fd, vbuf, count);
-#endif
while (1) {
const SSize_t len = PerlLIO_write(fd, vbuf, count);
if (len >= 0 || errno != EINTR) {
if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
return -1;
}
- /*NOTREACHED*/
+ NOT_REACHED; /*NOTREACHED*/
}
Off_t
const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
int code = 0;
if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
+ code = PerlIOBase_close(aTHX_ f);
if (PerlIOUnix_refcnt_dec(fd) > 0) {
PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
return 0;
/* perl5.8 - This ensures the last minute VMS ungetc fix is not
broken by the last second glibc 2.3 fix
*/
-#define STDIO_BUFFER_WRITABLE
+# define STDIO_BUFFER_WRITABLE
#endif
Note that the errno value set by a failing fdopen
varies between stdio implementations.
*/
- const int fd = PerlLIO_dup(fd0);
+ const int fd = PerlLIO_dup_cloexec(fd0);
FILE *f2;
if (fd < 0) {
return f;
if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
s = PerlIOSelf(f, PerlIOStdio);
s->stdio = stdio;
+ fd0 = fileno(stdio);
+ if(fd0 != -1){
+ PerlIOUnix_refcnt_inc(fd0);
+ setfd_cloexec_or_inhexec_by_sysfdness(fd0);
+ }
#ifdef EBCDIC
- fd0 = fileno(stdio);
- if(fd0 != -1){
- PerlIOUnix_refcnt_inc(fd0);
- }
else{
rc = fldata(stdio,filename,&fileinfo);
if(rc != 0){
}
/*This MVS dataset , OK!*/
}
-#else
- PerlIOUnix_refcnt_inc(fileno(stdio));
#endif
}
}
if (!s->stdio)
return NULL;
s->stdio = stdio;
- PerlIOUnix_refcnt_inc(fileno(s->stdio));
+ fd = fileno(stdio);
+ PerlIOUnix_refcnt_inc(fd);
+ setfd_cloexec_or_inhexec_by_sysfdness(fd);
return f;
}
else {
return NULL;
if (*mode == IoTYPE_NUMERIC) {
mode++;
- fd = PerlLIO_open3(path, imode, perm);
+ fd = PerlLIO_open3_cloexec(path, imode, perm);
}
else {
FILE *stdio;
f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
if (f) {
PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
- PerlIOUnix_refcnt_inc(fileno(stdio));
+ fd = fileno(stdio);
+ PerlIOUnix_refcnt_inc(fd);
+ setfd_cloexec_or_inhexec_by_sysfdness(fd);
} else {
PerlSIO_fclose(stdio);
}
}
if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
- PerlIOUnix_refcnt_inc(fileno(stdio));
+ fd = fileno(stdio);
+ PerlIOUnix_refcnt_inc(fd);
+ setfd_cloexec_or_inhexec_by_sysfdness(fd);
}
return f;
}
const int fd = fileno(stdio);
char mode[8];
if (flags & PERLIO_DUP_FD) {
- const int dfd = PerlLIO_dup(fileno(stdio));
+ const int dfd = PerlLIO_dup_cloexec(fileno(stdio));
if (dfd >= 0) {
stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
goto set_this;
set_this:
PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
if(stdio) {
- PerlIOUnix_refcnt_inc(fileno(stdio));
+ int fd = fileno(stdio);
+ PerlIOUnix_refcnt_inc(fd);
+ setfd_cloexec_or_inhexec_by_sysfdness(fd);
}
}
return f;
/* 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;
-# elif defined(__GLIBC__)
+#elif defined(__GLIBC__)
/* There may be a better way for GLIBC:
- libio.h defines a flag to not close() on cleanup
*/
f->_fileno = -1;
return 1;
-# elif defined(__sun)
+#elif defined(__sun)
PERL_UNUSED_ARG(f);
return 0;
-# elif defined(__hpux)
+#elif defined(__hpux)
f->__fileH = 0xff;
f->__fileL = 0xff;
return 1;
[For OSF only have confirmation for Tru64 (alpha)
but assume other OSFs will be similar.]
*/
-# elif defined(_AIX) || defined(__osf__) || defined(__irix__)
+#elif defined(_AIX) || defined(__osf__) || defined(__irix__)
f->_file = -1;
return 1;
-# elif defined(__FreeBSD__)
+#elif defined(__FreeBSD__)
/* There may be a better way on FreeBSD:
- we could insert a dummy func in the _close function entry
f->_close = (int (*)(void *)) dummy_close;
*/
f->_file = -1;
return 1;
-# elif defined(__OpenBSD__)
+#elif defined(__OpenBSD__)
/* There may be a better way on OpenBSD:
- we could insert a dummy func in the _close function entry
f->_close = (int (*)(void *)) dummy_close;
*/
f->_file = -1;
return 1;
-# elif defined(__EMX__)
+#elif defined(__EMX__)
/* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
f->_handle = -1;
return 1;
-# elif defined(__CYGWIN__)
+#elif defined(__CYGWIN__)
/* There may be a better way on CYGWIN:
- we could insert a dummy func in the _close function entry
f->_close = (int (*)(void *)) dummy_close;
*/
f->_file = -1;
return 1;
-# elif defined(WIN32)
-# if defined(UNDER_CE)
- /* WIN_CE does not have access to FILE internals, it hardly has FILE
- structure at all
- */
-# else
- f->_file = -1;
-# endif
+#elif defined(WIN32)
+ PERLIO_FILE_file(f) = -1;
return 1;
-# else
-#if 0
+#else
+# if 0
/* Sarathy's code did this - we fall back to a dup/dup2 hack
(which isn't thread safe) instead
*/
# error "Don't know how to set FILE.fileno on your platform"
-#endif
+# endif
PERL_UNUSED_ARG(f);
return 0;
-# endif
+#endif
}
IV
IV result = 0;
int dupfd = -1;
dSAVEDERRNO;
-#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()
return 0;
if (stdio == stdout || stdio == stderr)
return PerlIO_flush(f);
+ }
+ 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. */
+ 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);
+ dupfd = PerlLIO_dup_cloexec(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. */
result = close(fd);
#endif
if (dupfd >= 0) {
- PerlLIO_dup2(dupfd,fd);
+ PerlLIO_dup2_cloexec(dupfd, fd);
+ setfd_inhexec_for_sysfd(fd);
PerlLIO_close(dupfd);
-#ifdef USE_ITHREADS
- MUTEX_UNLOCK(&PL_perlio_mutex);
-#endif
}
+ MUTEX_UNLOCK(&PL_perlio_mutex);
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;
}
PerlIOStdio_get_base(pTHX_ PerlIO *f)
{
FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
+ PERL_UNUSED_CONTEXT;
return (STDCHAR*)PerlSIO_get_base(stdio);
}
PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
{
FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
+ PERL_UNUSED_CONTEXT;
return PerlSIO_get_bufsiz(stdio);
}
#endif
PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
{
FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
+ PERL_UNUSED_CONTEXT;
return (STDCHAR*)PerlSIO_get_ptr(stdio);
}
PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
{
FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
+ PERL_UNUSED_CONTEXT;
return PerlSIO_get_cnt(stdio);
}
PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
{
FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
+ PERL_UNUSED_CONTEXT;
if (ptr != NULL) {
-#ifdef STDIO_PTR_LVALUE
+# ifdef STDIO_PTR_LVALUE
/* This is a long-standing infamous mess. The root of the
* problem is that one cannot know the signedness of char, and
* more precisely the signedness of FILE._ptr. The following
* - casting the LHS to (void*) -- totally unportable
*
* So let's try silencing the warning at least for gcc. */
- GCC_DIAG_IGNORE(-Wpointer-sign);
+ GCC_DIAG_IGNORE_STMT(-Wpointer-sign);
PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
- GCC_DIAG_RESTORE;
-#ifdef STDIO_PTR_LVAL_SETS_CNT
+ GCC_DIAG_RESTORE_STMT;
+# ifdef STDIO_PTR_LVAL_SETS_CNT
assert(PerlSIO_get_cnt(stdio) == (cnt));
-#endif
-#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
+# endif
+# if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
/*
* Setting ptr _does_ change cnt - we are done
*/
return;
-#endif
-#else /* STDIO_PTR_LVALUE */
+# endif
+# else /* STDIO_PTR_LVALUE */
PerlProc_abort();
-#endif /* STDIO_PTR_LVALUE */
+# endif /* STDIO_PTR_LVALUE */
}
/*
* Now (or only) set cnt
*/
-#ifdef STDIO_CNT_LVALUE
+# ifdef STDIO_CNT_LVALUE
PerlSIO_set_cnt(stdio, cnt);
-#else /* STDIO_CNT_LVALUE */
-#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
+# elif (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
PerlSIO_set_ptr(stdio,
PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
cnt));
-#else /* STDIO_PTR_LVAL_SETS_CNT */
+# else /* STDIO_PTR_LVAL_SETS_CNT */
PerlProc_abort();
-#endif /* STDIO_PTR_LVAL_SETS_CNT */
-#endif /* STDIO_CNT_LVALUE */
+# endif /* STDIO_CNT_LVALUE */
}
#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
-#ifdef STDIO_BUFFER_WRITABLE
+# ifdef STDIO_BUFFER_WRITABLE
if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
/* Fake ungetc() to the real buffer in case system's ungetc
goes elsewhere
}
}
else
-#endif
+# endif
if (PerlIO_has_cntptr(f)) {
STDCHAR ch = c;
if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
if (!b->buf) {
if (!b->bufsiz)
b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
- Newxz(b->buf,b->bufsiz, STDCHAR);
+ Newx(b->buf,b->bufsiz, STDCHAR);
if (!b->buf) {
b->buf = (STDCHAR *) & b->oneword;
b->bufsiz = sizeof(b->oneword);
PerlIOBase(f)->flags |= PERLIO_F_CRLF;
code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
#if 0
+ DEBUG_i(
PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
(void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
PerlIOBase(f)->flags);
+ );
#endif
{
/* If the old top layer is a CRLF layer, reactivate it (if
PerlIO_pop(aTHX_ f);
#endif
}
- return 0;
+ return PerlIOBase_binmode(aTHX_ f);
}
PERLIO_FUNCS_DECL(PerlIO_crlf) = {
PerlIO *
PerlIO_tmpfile(void)
{
+ return PerlIO_tmpfile_flags(0);
+}
+
+#define MKOSTEMP_MODES ( O_RDWR | O_CREAT | O_EXCL )
+#define MKOSTEMP_MODE_MASK ( O_ACCMODE | O_CREAT | O_EXCL | O_TRUNC )
+
+PerlIO *
+PerlIO_tmpfile_flags(int imode)
+{
#ifndef WIN32
dTHX;
#endif
PerlIO *f = NULL;
#ifdef WIN32
- const int fd = win32_tmpfd();
+ const int fd = win32_tmpfd_mode(imode);
if (fd >= 0)
f = PerlIO_fdopen(fd, "w+b");
-#else /* WIN32 */
-# if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
+#elif ! defined(OS2)
int fd = -1;
char tempname[] = "/tmp/PerlIO_XXXXXX";
const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
SV * sv = NULL;
- int old_umask = umask(0600);
- /*
- * I have no idea how portable mkstemp() is ... NI-S
- */
+ int old_umask = umask(0177);
+ imode &= ~MKOSTEMP_MODE_MASK;
if (tmpdir && *tmpdir) {
/* if TMPDIR is set and not empty, we try that first */
sv = newSVpv(tmpdir, 0);
sv_catpv(sv, tempname + 4);
- fd = mkstemp(SvPVX(sv));
+ fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
}
if (fd < 0) {
SvREFCNT_dec(sv);
sv = NULL;
/* else we try /tmp */
- fd = mkstemp(tempname);
+ fd = Perl_my_mkostemp_cloexec(tempname, imode | O_VMS_DELETEONCLOSE);
}
if (fd < 0) {
/* Try cwd */
sv = newSVpvs(".");
sv_catpv(sv, tempname + 4);
- fd = mkstemp(SvPVX(sv));
+ fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
}
umask(old_umask);
if (fd >= 0) {
- f = PerlIO_fdopen(fd, "w+");
+ /* fdopen() with a numeric mode */
+ char mode[8];
+ int writing = 1;
+ (void)PerlIO_intmode2str(imode | MKOSTEMP_MODES, mode, &writing);
+ f = PerlIO_fdopen(fd, mode);
if (f)
PerlIOBase(f)->flags |= PERLIO_F_TEMP;
+# ifndef VMS
PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
+# endif
}
SvREFCNT_dec(sv);
-# else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
+#else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
FILE * const stdio = PerlSIO_tmpfile();
if (stdio)
f = PerlIO_fdopen(fileno(stdio), "w+");
-# endif /* else HAS_MKSTEMP */
#endif /* else WIN32 */
return f;
}
void
Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
{
+ PERL_UNUSED_CONTEXT;
if (!PerlIOValid(f))
return;
PerlIOBase(f)->err = errno;
void
Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
{
+ PERL_UNUSED_CONTEXT;
if (!PerlIOValid(f))
return;
SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
#undef HAS_FSETPOS
#undef HAS_FGETPOS
-#endif /* PERLIO_IS_STDIO */
/*======================================================================================*/
/*
#ifndef HAS_FSETPOS
-#undef PerlIO_setpos
+# undef PerlIO_setpos
int
PerlIO_setpos(PerlIO *f, SV *pos)
{
return -1;
}
#else
-#undef PerlIO_setpos
+# undef PerlIO_setpos
int
PerlIO_setpos(PerlIO *f, SV *pos)
{
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)
+# if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
return fsetpos64(f, fpos);
-#else
+# else
return fsetpos(f, fpos);
-#endif
+# endif
}
}
SETERRNO(EINVAL, SS_IVCHAN);
#endif
#ifndef HAS_FGETPOS
-#undef PerlIO_getpos
+# undef PerlIO_getpos
int
PerlIO_getpos(PerlIO *f, SV *pos)
{
return (posn == (Off_t) - 1) ? -1 : 0;
}
#else
-#undef PerlIO_getpos
+# undef PerlIO_getpos
int
PerlIO_getpos(PerlIO *f, SV *pos)
{
dTHX;
Fpos_t fpos;
int code;
-#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
+# if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
code = fgetpos64(f, &fpos);
-#else
+# else
code = fgetpos(f, &fpos);
-#endif
+# endif
sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
return code;
}
#endif
-#if !defined(HAS_VPRINTF)
-
-int
-vprintf(char *pat, char *args)
-{
- _doprnt(pat, args, stdout);
- return 0; /* wrong, but perl doesn't use the return
- * value */
-}
-
-int
-vfprintf(FILE *fd, char *pat, char *args)
-{
- _doprnt(pat, args, fd);
- return 0; /* wrong, but perl doesn't use the return
- * value */
-}
-
-#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);
+ va_list arglist;
PERL_ARGS_ASSERT_NOPERL_DIE;
va_start(arglist, pat);
vfprintf(stderr, pat, arglist);
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff