(perl #127380) only trace to $PERLIO_DEBUG if -Di is supplied

diff --git a/perl.c b/perl.c
index 671e355..e023d40 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -3150,6 +3150,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
       "  M  trace smart match resolution\n"
       "  B  dump suBroutine definitions, including special Blocks like BEGIN\n",
       "  L  trace some locale setting information--for Perl core development\n",
+      "  i  trace PerlIO layer processing\n",
       NULL
     };
     UV uv = 0;
@@ -3158,7 +3159,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);

diff --git a/perl.h b/perl.h
index a5c3eb8..0d9887f 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -4176,7 +4176,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 /*134217728*/
+#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 */
@@ -4208,6 +4209,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_)
@@ -4242,6 +4244,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_
@@ -4297,6 +4300,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 */
 
@@ -4327,6 +4331,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)
@@ -4361,6 +4366,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)

diff --git a/perlio.c b/perlio.c
index 11a66d0..20c2fa3 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -351,6 +351,10 @@ PerlIO_debug(const char *fmt, ...)
     va_list ap;
     dSYS;
     va_start(ap, fmt);
+
+    if (!DEBUG_i_TEST)
+        return;
+
     if (!PL_perlio_debug_fd) {
        if (!TAINTING_get &&
            PerlProc_getuid() == PerlProc_geteuid() &&
@@ -477,7 +481,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 {
@@ -586,7 +590,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++);
@@ -610,7 +614,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;
@@ -620,7 +624,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);
                }
@@ -639,8 +643,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
@@ -713,7 +717,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;
        }
     }
@@ -741,7 +745,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;
 }
 
@@ -844,8 +848,9 @@ XS(XS_PerlIO__Layer__NoWarnings)
      */
     dXSARGS;
     PERL_UNUSED_ARG(cv);
-    if (items)
-       PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
+    DEBUG_i(
+        if (items)
+            PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))) );
     XSRETURN(0);
 }
 
@@ -874,7 +879,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
@@ -979,7 +984,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);
 }
 
@@ -993,8 +998,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)
@@ -1145,9 +1150,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) {
@@ -1161,8 +1166,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;
@@ -1241,8 +1246,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;
        }
     }
@@ -1294,10 +1299,11 @@ 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.
@@ -1530,9 +1536,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);
@@ -1609,7 +1615,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;
        }
@@ -2001,9 +2007,11 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
        }
     }
 #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;
 }
@@ -2187,9 +2195,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",
-                    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);
@@ -2216,8 +2224,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;
@@ -2239,9 +2247,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",
-                (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);
 }
@@ -2273,8 +2281,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);
@@ -2290,7 +2298,11 @@ PerlIOUnix_refcnt_dec(int fd)
 {
     int cnt = 0;
     if (fd >= 0) {
+#ifdef DEBUGGING
+        dTHX;
+#else
        dVAR;
+#endif
 #ifdef USE_ITHREADS
        MUTEX_LOCK(&PL_perlio_mutex);
 #endif
@@ -2305,7 +2317,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
@@ -2352,9 +2364,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 */
@@ -2557,11 +2569,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
@@ -4493,9 +4505,11 @@ 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
+    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

diff --git a/pod/perlrun.pod b/pod/perlrun.pod
index e454bf8..ecd2adf 100644 (file)
--- a/pod/perlrun.pod
+++ b/pod/perlrun.pod
@@ -388,39 +388,42 @@ the format of the output is explained in L<perldebguts>.
 As an alternative, specify a number instead of list of letters (e.g.,
 B<-D14> is equivalent to B<-Dtls>):
 
-        1  p  Tokenizing and parsing (with v, displays parse stack)
-        2  s  Stack snapshots (with v, displays all stacks)
-        4  l  Context (loop) stack processing
-        8  t  Trace execution
-       16  o  Method and overloading resolution
-       32  c  String/numeric conversions
-       64  P  Print profiling info, source file input state
-      128  m  Memory and SV allocation
-      256  f  Format processing
-      512  r  Regular expression parsing and execution
-     1024  x  Syntax tree dump
-     2048  u  Tainting checks
-     4096  U  Unofficial, User hacking (reserved for private,
-              unreleased use)
-     8192  H  Hash dump -- usurps values()
-    16384  X  Scratchpad allocation
-    32768  D  Cleaning up
-    65536  S  Op slab allocation
-   131072  T  Tokenizing
-   262144  R  Include reference counts of dumped variables (eg when
-              using -Ds)
-   524288  J  show s,t,P-debug (don't Jump over) on opcodes within
-              package DB
-  1048576  v  Verbose: use in conjunction with other flags
-  2097152  C  Copy On Write
-  4194304  A  Consistency checks on internal structures
-  8388608  q  quiet - currently only suppresses the "EXECUTING"
-              message
- 16777216  M  trace smart match resolution
- 33554432  B  dump suBroutine definitions, including special Blocks
-              like BEGIN
- 67108864  L  trace Locale-related info; what gets output is very
-              subject to change
+         1  p  Tokenizing and parsing (with v, displays parse
+               stack)
+         2  s  Stack snapshots (with v, displays all stacks)
+         4  l  Context (loop) stack processing
+         8  t  Trace execution
+        16  o  Method and overloading resolution
+        32  c  String/numeric conversions
+        64  P  Print profiling info, source file input state
+       128  m  Memory and SV allocation
+       256  f  Format processing
+       512  r  Regular expression parsing and execution
+      1024  x  Syntax tree dump
+      2048  u  Tainting checks
+      4096  U  Unofficial, User hacking (reserved for private,
+               unreleased use)
+      8192  H  Hash dump -- usurps values()
+     16384  X  Scratchpad allocation
+     32768  D  Cleaning up
+     65536  S  Op slab allocation
+    131072  T  Tokenizing
+    262144  R  Include reference counts of dumped variables
+               (eg when using -Ds)
+    524288  J  show s,t,P-debug (don't Jump over) on opcodes within
+               package DB
+   1048576  v  Verbose: use in conjunction with other flags
+   2097152  C  Copy On Write
+   4194304  A  Consistency checks on internal structures
+   8388608  q  quiet - currently only suppresses the "EXECUTING"
+               message
+  16777216  M  trace smart match resolution
+  33554432  B  dump suBroutine definitions, including special
+               Blocks like BEGIN
+  67108864  L  trace Locale-related info; what gets output is very
+               subject to change
+ 134217728  i  trace PerlIO layer processing.  Set PERLIO_DEBUG to
+               the filename to trace to.
 
 All these flags require B<-DDEBUGGING> when you compile the Perl
 executable (but see C<:opd> in L<Devel::Peek> or L<re/'debug' mode>