Skip to content
This repository has been archived by the owner on Jun 1, 2023. It is now read-only.

Commit

Permalink
Browse files Browse the repository at this point in the history
DEBUG_I: add a seperate -DI instead of PERLIO_DEBUG
We do not want to pollute our special PERLIO_DEBUG filehandle
with PerlIO debug messages, and we want to be able to write all
debug messages into a seperate filehandle, not just stderr.

Second, we want a fast PerlIO. Now PERLIO_DEBUG is only checked with
DEBUGGING.
  • Loading branch information
Reini Urban committed Jul 28, 2015
1 parent 653e4d2 commit 8beb3ee
Show file tree
Hide file tree
Showing 3 changed files with 70 additions and 46 deletions.
3 changes: 2 additions & 1 deletion perl.c
Expand Up @@ -3042,6 +3042,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
" x Syntax tree dump\n",
" u Tainting checks\n"
" H Hash dump -- usurps values()\n"
" I PerlIO, as previously with env PERLIO_DEBUG\n"
" X Scratchpad allocation\n"
" D Cleaning up\n"
" S Op slab allocation\n"
Expand All @@ -3063,7 +3064,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)

if (isALPHA(**s)) {
/* if adding extra options, remember to update DEBUG_MASK */
static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBL";
static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLI";

for (; isWORDCHAR(**s); (*s)++) {
const char * const d = strchr(debopts,**s);
Expand Down
8 changes: 7 additions & 1 deletion perl.h
Expand Up @@ -4006,7 +4006,8 @@ Gid_t getegid (void);
#define DEBUG_M_FLAG 0x01000000 /*16777216*/
#define DEBUG_B_FLAG 0x02000000 /*33554432*/
#define DEBUG_L_FLAG 0x04000000 /*67108864*/
#define DEBUG_MASK 0x07FFEFFF /* mask of all the standard flags */
#define DEBUG_I_FLAG 0x08000000 /**/
#define DEBUG_MASK 0x0FFFEFFF /* mask of all the standard flags */

#define DEBUG_DB_RECURSE_FLAG 0x40000000
#define DEBUG_TOP_FLAG 0x80000000 /* -D was given --> PL_debug |= FLAG */
Expand Down Expand Up @@ -4038,6 +4039,7 @@ Gid_t getegid (void);
# define DEBUG_M_TEST_ (PL_debug & DEBUG_M_FLAG)
# define DEBUG_B_TEST_ (PL_debug & DEBUG_B_FLAG)
# define DEBUG_L_TEST_ (PL_debug & DEBUG_L_FLAG)
# define DEBUG_I_TEST_ (PL_debug & DEBUG_I_FLAG)
# define DEBUG_Xv_TEST_ (DEBUG_X_TEST_ && DEBUG_v_TEST_)
# define DEBUG_Uv_TEST_ (DEBUG_U_TEST_ && DEBUG_v_TEST_)
# define DEBUG_Pv_TEST_ (DEBUG_P_TEST_ && DEBUG_v_TEST_)
Expand Down Expand Up @@ -4071,6 +4073,7 @@ Gid_t getegid (void);
# define DEBUG_M_TEST DEBUG_M_TEST_
# define DEBUG_B_TEST DEBUG_B_TEST_
# define DEBUG_L_TEST DEBUG_L_TEST_
# define DEBUG_I_TEST DEBUG_I_TEST_
# define DEBUG_Xv_TEST DEBUG_Xv_TEST_
# define DEBUG_Uv_TEST DEBUG_Uv_TEST_
# define DEBUG_Pv_TEST DEBUG_Pv_TEST_
Expand Down Expand Up @@ -4124,6 +4127,7 @@ Gid_t getegid (void);
# define DEBUG_M(a) DEBUG__(DEBUG_M_TEST, a)
# define DEBUG_B(a) DEBUG__(DEBUG_B_TEST, a)
# define DEBUG_L(a) DEBUG__(DEBUG_L_TEST, a)
# define DEBUG_I(a) DEBUG__(DEBUG_I_TEST, a)

#else /* DEBUGGING */

Expand Down Expand Up @@ -4154,6 +4158,7 @@ Gid_t getegid (void);
# define DEBUG_M_TEST (0)
# define DEBUG_B_TEST (0)
# define DEBUG_L_TEST (0)
# define DEBUG_I_TEST (0)
# define DEBUG_Xv_TEST (0)
# define DEBUG_Uv_TEST (0)
# define DEBUG_Pv_TEST (0)
Expand Down Expand Up @@ -4187,6 +4192,7 @@ Gid_t getegid (void);
# define DEBUG_M(a)
# define DEBUG_B(a)
# define DEBUG_L(a)
# define DEBUG_I(a)
# define DEBUG_Xv(a)
# define DEBUG_Uv(a)
# define DEBUG_Pv(a)
Expand Down
105 changes: 61 additions & 44 deletions perlio.c
Expand Up @@ -375,6 +375,9 @@ PerlIO_debug(const char *fmt, ...)
dSYS;
va_start(ap, fmt);
if (!PL_perlio_debug_fd) {
/* with DEBUGGING it would have been initialized already
in PerlIO_stdstreams() */
#ifndef DEBUGGING
if (!TAINTING_get &&
PerlProc_getuid() == PerlProc_geteuid() &&
PerlProc_getgid() == PerlProc_getegid()) {
Expand All @@ -389,6 +392,7 @@ PerlIO_debug(const char *fmt, ...)
skip these tests next time through. */
PL_perlio_debug_fd = -1;
}
#endif
}
if (PL_perlio_debug_fd > 0) {
#ifdef USE_ITHREADS
Expand Down Expand Up @@ -500,7 +504,7 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
{
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 {
Expand Down Expand Up @@ -609,7 +613,7 @@ PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
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++);
Expand All @@ -633,7 +637,7 @@ PerlIO_destruct(pTHX)
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;
Expand All @@ -643,7 +647,7 @@ PerlIO_destruct(pTHX)
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);
}
Expand All @@ -662,8 +666,8 @@ PerlIO_pop(pTHX_ PerlIO *f)
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
Expand Down Expand Up @@ -736,7 +740,7 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
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;
}
}
Expand Down Expand Up @@ -764,7 +768,7 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
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;
}

Expand Down Expand Up @@ -897,7 +901,7 @@ PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
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
Expand Down Expand Up @@ -1002,7 +1006,7 @@ PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
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);
}

Expand All @@ -1016,8 +1020,8 @@ PerlIO_funcs *
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)
Expand Down Expand Up @@ -1137,6 +1141,19 @@ PerlIO_stdstreams(pTHX)
PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
#ifdef DEBUGGING
if (!TAINTING_get &&
PerlEnv_getenv("PERLIO_DEBUG") &&
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);
PerlIO_fdopen(PL_perlio_debug_fd, "a" PERLIO_STDTEXT);
}
}
#endif
}
}

Expand Down Expand Up @@ -1168,9 +1185,9 @@ PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
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) {
Expand All @@ -1184,8 +1201,8 @@ PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
}
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;
Expand Down Expand Up @@ -1264,8 +1281,8 @@ PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
}
}
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;
}
}
Expand Down Expand Up @@ -1317,10 +1334,10 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
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)");
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.
Expand Down Expand Up @@ -1553,9 +1570,9 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
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);
Expand Down Expand Up @@ -1632,7 +1649,7 @@ Perl_PerlIO_flush(pTHX_ PerlIO *f)
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;
}
Expand Down Expand Up @@ -2024,9 +2041,9 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
}
}
#if 0
PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
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));
l->flags, PerlIO_modestr(f, temp)));
#endif
return 0;
}
Expand Down Expand Up @@ -2210,9 +2227,9 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
SV *arg = NULL;
char buf[8];
assert(self);
PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
DEBUG_I(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
self ? self->name : "(Null)",
(void*)f, (void*)o, (void*)param);
(void*)f, (void*)o, (void*)param));
if (self && self->Getarg)
arg = (*self->Getarg)(aTHX_ o, param, flags);
f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
Expand All @@ -2237,8 +2254,8 @@ S_more_refcounted_fds(pTHX_ const int new_fd) {
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;
Expand All @@ -2260,9 +2277,9 @@ S_more_refcounted_fds(pTHX_ const int new_fd) {
PL_perlio_fd_refcnt_size = new_max;
PL_perlio_fd_refcnt = new_array;

PerlIO_debug("Zeroing %p, %d\n",
DEBUG_I(PerlIO_debug("Zeroing %p, %d\n",
(void*)(new_array + old_max),
new_max - old_max);
new_max - old_max));

Zero(new_array + old_max, new_max - old_max, int);
}
Expand Down Expand Up @@ -2294,8 +2311,8 @@ PerlIOUnix_refcnt_inc(int 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);
Expand Down Expand Up @@ -2326,7 +2343,7 @@ PerlIOUnix_refcnt_dec(int fd)
fd, PL_perlio_fd_refcnt[fd]);
}
cnt = --PL_perlio_fd_refcnt[fd];
PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
DEBUG_I(PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt));
#ifdef USE_ITHREADS
MUTEX_UNLOCK(&PL_perlio_mutex);
#endif
Expand Down Expand Up @@ -2373,9 +2390,9 @@ PerlIO_cleanup(pTHX)
{
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 */
Expand Down Expand Up @@ -2578,11 +2595,11 @@ PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
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
Expand Down Expand Up @@ -4511,9 +4528,9 @@ PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
PerlIOBase(f)->flags |= PERLIO_F_CRLF;
code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
#if 0
PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
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);
PerlIOBase(f)->flags));
#endif
{
/* If the old top layer is a CRLF layer, reactivate it (if
Expand Down

0 comments on commit 8beb3ee

Please sign in to comment.