This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add -Dy debugging of tr///, y///
authorKarl Williamson <khw@cpan.org>
Thu, 7 Nov 2019 17:42:14 +0000 (10:42 -0700)
committerKarl Williamson <khw@cpan.org>
Sun, 17 Nov 2019 20:53:27 +0000 (13:53 -0700)
doop.c
op.c
perl.c
perl.h
pod/perlrun.pod

diff --git a/doop.c b/doop.c
index f2e3806..1d761d5 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -46,6 +46,10 @@ S_do_trans_simple(pTHX_ SV * const sv, const OPtrans_map * const tbl)
     U8 * const send = s+len;
 
     PERL_ARGS_ASSERT_DO_TRANS_SIMPLE;
+    DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: entering do_trans_simple:"
+                                          " input sv:\n",
+                                          __FILE__, __LINE__));
+    DEBUG_y(sv_dump(sv));
 
     /* First, take care of non-UTF-8 input strings, because they're easy */
     if (!SvUTF8(sv)) {
@@ -101,6 +105,9 @@ S_do_trans_simple(pTHX_ SV * const sv, const OPtrans_map * const tbl)
        SvUTF8_on(sv);
        SvSETMAGIC(sv);
     }
+    DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: returning %" IVdf "\n",
+                                          __FILE__, __LINE__, matches));
+    DEBUG_y(sv_dump(sv));
     return matches;
 }
 
@@ -127,6 +134,11 @@ S_do_trans_count(pTHX_ SV * const sv, const OPtrans_map * const tbl)
 
     PERL_ARGS_ASSERT_DO_TRANS_COUNT;
 
+    DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: entering do_trans_count:"
+                                          " input sv:\n",
+                                          __FILE__, __LINE__));
+    DEBUG_y(sv_dump(sv));
+
     if (!SvUTF8(sv)) {
        while (s < send) {
             if (tbl->map[*s++] >= 0)
@@ -147,6 +159,8 @@ S_do_trans_count(pTHX_ SV * const sv, const OPtrans_map * const tbl)
        }
     }
 
+    DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: count returning %" IVdf "\n",
+                                          __FILE__, __LINE__, matches));
     return matches;
 }
 
@@ -170,6 +184,11 @@ S_do_trans_complex(pTHX_ SV * const sv, const OPtrans_map * const tbl)
 
     PERL_ARGS_ASSERT_DO_TRANS_COMPLEX;
 
+    DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: entering do_trans_complex:"
+                                          " input sv:\n",
+                                          __FILE__, __LINE__));
+    DEBUG_y(sv_dump(sv));
+
     if (!SvUTF8(sv)) {
        U8 *d = s;
        U8 * const dstart = d;
@@ -293,6 +312,9 @@ S_do_trans_complex(pTHX_ SV * const sv, const OPtrans_map * const tbl)
        SvUTF8_on(sv);
     }
     SvSETMAGIC(sv);
+    DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: returning %" IVdf "\n",
+                                          __FILE__, __LINE__, matches));
+    DEBUG_y(sv_dump(sv));
     return matches;
 }
 
@@ -323,6 +345,14 @@ S_do_trans_count_invmap(pTHX_ SV * const sv, AV * const invmap)
 
     PERL_ARGS_ASSERT_DO_TRANS_COUNT_INVMAP;
 
+    DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:"
+                                          "entering do_trans_count_invmap:"
+                                          " input sv:\n",
+                                          __FILE__, __LINE__));
+    DEBUG_y(sv_dump(sv));
+    DEBUG_y(PerlIO_printf(Perl_debug_log, "mapping:\n"));
+    DEBUG_y(invmap_dump(from_invlist, (UV *) SvPVX(to_invmap_sv)));
+
     s = (U8*)SvPV_nomg(sv, len);
 
     send = s + len;
@@ -356,10 +386,11 @@ S_do_trans_count_invmap(pTHX_ SV * const sv, AV * const invmap)
         s += s_len;
     }
 
+    DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: returning %" IVdf "\n",
+                                          __FILE__, __LINE__, matches));
     return matches;
 }
 
-
 /* Helper function for do_trans().
  * Handles cases where an inversion map implementation is to be used and the
  * search and replacement charlists are either not identical or flags are
@@ -416,6 +447,13 @@ S_do_trans_invmap(pTHX_ SV * const sv, AV * const invmap)
     }
 
     s = (U8*)SvPV_nomg(sv, len);
+    DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: entering do_trans_invmap:"
+                                          " input sv:\n",
+                                          __FILE__, __LINE__));
+    DEBUG_y(sv_dump(sv));
+    DEBUG_y(PerlIO_printf(Perl_debug_log, "mapping:\n"));
+    DEBUG_y(invmap_dump(from_invlist, map));
+
     send = s + len;
     s0 = s;
 
@@ -535,10 +573,12 @@ S_do_trans_invmap(pTHX_ SV * const sv, AV * const invmap)
     }
     SvSETMAGIC(sv);
 
+    DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: returning %" IVdf "\n",
+                                          __FILE__, __LINE__, matches));
+    DEBUG_y(sv_dump(sv));
     return matches;
 }
 
-
 /* Execute a tr//. sv is the value to be translated, while PL_op
  * should be an OP_TRANS or OP_TRANSR op, whose op_pv field contains a
  * translation table or whose op_sv field contains an inversion map.
diff --git a/op.c b/op.c
index e5fbe6f..bc48a0b 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6928,6 +6928,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
         SV * inverted_tlist = _new_invlist(tlen);
         Size_t temp_len;
 
+        DEBUG_y(PerlIO_printf(Perl_debug_log, "%d: tstr=%s\n",
+                              __LINE__, _byte_dump_string(t, tend - t, 0)));
+        DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
+                                        _byte_dump_string(r, rend - r, 0)));
+
         while (t < tend) {
 
             /* Non-utf8 strings don't have ranges, so each character is listed
@@ -6964,6 +6969,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
 
         /* The inversion list is done; now invert it */
         _invlist_invert(inverted_tlist);
+        DEBUG_y(sv_dump(inverted_tlist));
 
         /* Now go through the inverted list and create a new tstr for the rest
          * of the routine to use.  Since the UTF-8 version can have ranges, and
@@ -7053,6 +7059,14 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
         r_count = 0;
         t_range_count = r_range_count = 0;
 
+        DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
+                    __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
+        DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
+                                        _byte_dump_string(r, rend - r, 0)));
+        DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
+                                                  complement, squash, del));
+        DEBUG_y(invmap_dump(t_invlist, r_map));
+
         /* Now go through the search list constructing an inversion map.  The
          * input is not necessarily in any particular order.  Making it an
          * inversion map orders it, potentially simplifying, and makes it easy
@@ -7207,6 +7221,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
                      * range the same size as the lhs one. */
                     r_cp = TR_SPECIAL_HANDLING;
                     r_range_count = t_range_count;
+
+                    if (! del) {
+                        DEBUG_yv(PerlIO_printf(Perl_debug_log,
+                                        "final_map =%" UVXf "\n", final_map));
+                    }
                 }
                 else {
                     if (! rstr_utf8) {
@@ -7308,6 +7327,9 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
              * has been set up so that all members in it will be of the same
              * ilk) */
             if (r_map[i] == TR_UNLISTED) {
+                DEBUG_yv(PerlIO_printf(Perl_debug_log,
+                    "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
+                    t_cp, t_cp_end, r_cp, r_cp_end));
 
                 /* This is the first definition for this chunk, hence is valid
                  * and needs to be processed.  Here and in the comments below,
@@ -7357,6 +7379,9 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
                      * largest ratio */
                     if (ratio > max_expansion) {
                         max_expansion = ratio;
+                        DEBUG_y(PerlIO_printf(Perl_debug_log,
+                                        "New expansion factor: %" NVgf "\n",
+                                        max_expansion));
                     }
                 }
 
@@ -7590,6 +7615,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
                      */
 
+                    DEBUG_yv(PerlIO_printf(Perl_debug_log,
+                                        "Before fixing up: len=%d, i=%d\n",
+                                        (int) len, (int) i));
+                    DEBUG_yv(invmap_dump(t_invlist, r_map));
+
                     invlist_extend(t_invlist, len + 2);
                     t_array = invlist_array(t_invlist);
                     Renew(r_map, len + 2, UV);
@@ -7609,6 +7639,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
                     t_array[i+2] = t_cp_end + 1;
                     r_map[i+2] = TR_UNLISTED;
                 }
+                DEBUG_yv(PerlIO_printf(Perl_debug_log,
+                            "After iteration: span=%" IVdf ", t_range_count=%"
+                            IVdf ", r_range_count=%" IVdf "\n",
+                            span, t_range_count, r_range_count));
+                DEBUG_yv(invmap_dump(t_invlist, r_map));
             } /* End of this chunk needs to be processed */
 
             /* Done with this chunk. */
@@ -7637,6 +7672,9 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
 
     SvREFCNT_dec(inverted_tstr);
 
+    DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
+    DEBUG_y(invmap_dump(t_invlist, r_map));
+
     /* We now have normalized the input into an inversion map.
      *
      * See if the lhs and rhs are equivalent.  If so, this tr/// is a no-op
@@ -7770,6 +7808,22 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
                               : (short) rlen
                                 ? (short) final_map
                                 : (short) TR_R_EMPTY;
+        DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
+        for (i = 0; i < tbl->size; i++) {
+            if (tbl->map[i] < 0) {
+                DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
+                                                (unsigned) i, tbl->map[i]));
+            }
+            else {
+                DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
+                                                (unsigned) i, tbl->map[i]));
+            }
+            if ((i+1) % 8 == 0 || i + 1 == tbl->size) {
+                DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
+            }
+        }
+        DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
+                                (unsigned) tbl->size, tbl->map[tbl->size]));
 
         SvREFCNT_dec(t_invlist);
 
diff --git a/perl.c b/perl.c
index d14da14..43f6f9b 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -3360,6 +3360,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
       "  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",
+      "  y  trace y///, tr/// compilation and execution\n",
       NULL
     };
     UV uv = 0;
@@ -3368,7 +3369,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[] = "psltocPmfrxuUHXDSTRJvCAqMBLi";
+       static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLiy";
 
        for (; isWORDCHAR(**s); (*s)++) {
            const char * const d = strchr(debopts,**s);
diff --git a/perl.h b/perl.h
index bd2b623..e2fe628 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -4094,7 +4094,8 @@ Gid_t getegid (void);
 #define DEBUG_B_FLAG           0x02000000 /*33554432*/
 #define DEBUG_L_FLAG           0x04000000 /*67108864*/
 #define DEBUG_i_FLAG           0x08000000 /*134217728*/
-#define DEBUG_MASK             0x0FFFEFFF /* mask of all the standard flags */
+#define DEBUG_y_FLAG           0x10000000 /*268435456*/
+#define DEBUG_MASK             0x1FFFEFFF /* mask of all the standard flags */
 
 #define DEBUG_DB_RECURSE_FLAG  0x40000000
 #define DEBUG_TOP_FLAG         0x80000000 /* -D was given --> PL_debug |= FLAG */
@@ -4126,10 +4127,12 @@ Gid_t getegid (void);
 #  define DEBUG_B_TEST_ UNLIKELY(PL_debug & DEBUG_B_FLAG)
 #  define DEBUG_L_TEST_ UNLIKELY(PL_debug & DEBUG_L_FLAG)
 #  define DEBUG_i_TEST_ UNLIKELY(PL_debug & DEBUG_i_FLAG)
+#  define DEBUG_y_TEST_ UNLIKELY(PL_debug & DEBUG_y_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_)
 #  define DEBUG_Lv_TEST_ (DEBUG_L_TEST_ && DEBUG_v_TEST_)
+#  define DEBUG_yv_TEST_ (DEBUG_y_TEST_ && DEBUG_v_TEST_)
 
 #ifdef DEBUGGING
 
@@ -4160,10 +4163,12 @@ Gid_t getegid (void);
 #  define DEBUG_B_TEST DEBUG_B_TEST_
 #  define DEBUG_L_TEST DEBUG_L_TEST_
 #  define DEBUG_i_TEST DEBUG_i_TEST_
+#  define DEBUG_y_TEST DEBUG_y_TEST_
 #  define DEBUG_Xv_TEST DEBUG_Xv_TEST_
 #  define DEBUG_Uv_TEST DEBUG_Uv_TEST_
 #  define DEBUG_Pv_TEST DEBUG_Pv_TEST_
 #  define DEBUG_Lv_TEST DEBUG_Lv_TEST_
+#  define DEBUG_yv_TEST DEBUG_yv_TEST_
 
 #  define PERL_DEB(a)                  a
 #  define PERL_DEB2(a,b)               a
@@ -4212,6 +4217,7 @@ Gid_t getegid (void);
 #  define DEBUG_Uv(a) DEBUG__(DEBUG_Uv_TEST, a)
 #  define DEBUG_Pv(a) DEBUG__(DEBUG_Pv_TEST, a)
 #  define DEBUG_Lv(a) DEBUG__(DEBUG_Lv_TEST, a)
+#  define DEBUG_yv(a) DEBUG__(DEBUG_yv_TEST, a)
 
 #  define DEBUG_S(a) DEBUG__(DEBUG_S_TEST, a)
 #  define DEBUG_T(a) DEBUG__(DEBUG_T_TEST, a)
@@ -4224,6 +4230,7 @@ Gid_t getegid (void);
 #  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)
+#  define DEBUG_y(a) DEBUG__(DEBUG_y_TEST, a)
 
 #else /* ! DEBUGGING below */
 
@@ -4254,10 +4261,12 @@ Gid_t getegid (void);
 #  define DEBUG_B_TEST (0)
 #  define DEBUG_L_TEST (0)
 #  define DEBUG_i_TEST (0)
+#  define DEBUG_y_TEST (0)
 #  define DEBUG_Xv_TEST (0)
 #  define DEBUG_Uv_TEST (0)
 #  define DEBUG_Pv_TEST (0)
 #  define DEBUG_Lv_TEST (0)
+#  define DEBUG_yv_TEST (0)
 
 #  define PERL_DEB(a)
 #  define PERL_DEB2(a,b)               b
@@ -4288,10 +4297,12 @@ Gid_t getegid (void);
 #  define DEBUG_B(a)
 #  define DEBUG_L(a)
 #  define DEBUG_i(a)
+#  define DEBUG_y(a)
 #  define DEBUG_Xv(a)
 #  define DEBUG_Uv(a)
 #  define DEBUG_Pv(a)
 #  define DEBUG_Lv(a)
+#  define DEBUG_yv(a)
 #endif /* DEBUGGING */
 
 
index b325984..fb06893 100644 (file)
@@ -428,6 +428,7 @@ B<-D14> is equivalent to B<-Dtls>):
                subject to change
  134217728  i  trace PerlIO layer processing.  Set PERLIO_DEBUG to
                the filename to trace to.
+ 268435456  y  trace y///, tr/// compilation and execution
 
 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>