{
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() &&
PL_perlio_debug_fd
= PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
else
- PL_perlio_debug_fd = -1;
+ PL_perlio_debug_fd = PerlLIO_dup(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(2); /* stderr */
}
}
if (PL_perlio_debug_fd > 0) {
{
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;
}
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 (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)
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));
}
}
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->name,
- (void*)f, (void*)o, (void*)param);
+ 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);
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);
}
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) {
+#ifdef DEBUGGING
+ dTHX;
+#else
dVAR;
-#ifdef USE_ITHREADS
- MUTEX_LOCK(&PL_perlio_mutex);
#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);
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 */
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
/* 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;
structure at all
*/
# else
- f->_file = -1;
+ PERLIO_FILE_file(f) = -1;
# endif
return 1;
# else
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
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
PerlLIO_dup2(dupfd,fd);
PerlLIO_close(dupfd);
}
-#ifdef USE_ITHREADS
MUTEX_UNLOCK(&PL_perlio_mutex);
-#endif
return result;
}
}
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
/* This is a long-standing infamous mess. The root of the
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
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
*/
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);
https://perl5.git.perl.org / perl5.git / blobdiff