Add environment variable for -Dr: PERL_DUMP_RE_MAX_LEN

The regex engine when displaying debugging info, say under -Dr, will elide
data in order to keep the output from getting too long.  For example,
the number of code points in all of Unicode matched by \w is quite
large, and so when displaying a pattern that matches this, only the
first some number of them are printed, and the rest are truncated,
represented by "...".

Sometimes, one wants to see more than what the
compiled-into-the-engine-max shows.  This commit creates code to read
this environment variable to override the default max lengths.  This
changes the lengths for everything to the input number, even if they
have different compiled maximums in the absence of this variable.

I'm not  currently documenting this variable, as I don't think it works
properly under threads, and we may want to alter the behavior in various
ways as a result of gaining experience with using it.

4 files changed, 31 insertions, 10 deletions

diff --git a/embedvar.h b/embedvar.h
index 524ceb4edc..c366d474ec 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -134,6 +134,7 @@
 #define PL_diehook		(vTHX->Idiehook)
 #define PL_doswitches		(vTHX->Idoswitches)
 #define PL_dowarn		(vTHX->Idowarn)
+#define PL_dump_re_max_len	(vTHX->Idump_re_max_len)
 #define PL_dumper_fd		(vTHX->Idumper_fd)
 #define PL_dumpindent		(vTHX->Idumpindent)
 #define PL_e_script		(vTHX->Ie_script)
diff --git a/intrpvar.h b/intrpvar.h
index 4f558a83bc..50a9ee0a9e 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -807,6 +807,8 @@ PERLVARA(I, op_exec_cnt, OP_max+2, UV)	/* Counts of executed OPs of the given ty
 
 PERLVAR(I, random_state, PL_RANDOM_STATE_TYPE)
 
+PERLVARI(I, dump_re_max_len, STRLEN, 0)
+
 /* If you are adding a U8 or U16, check to see if there are 'Space' comments
  * above on where there are gaps which currently will be structure padding.  */
 
diff --git a/regcomp.c b/regcomp.c
index a8200473c0..a2fe130721 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -6700,6 +6700,10 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
     /* Initialize these here instead of as-needed, as is quick and avoids
      * having to test them each time otherwise */
     if (! PL_AboveLatin1) {
+#ifdef DEBUGGING
+        char * dump_len_string;
+#endif
+
 	PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
 	PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
 	PL_UpperLatin1 = _new_invlist_C_array(UpperLatin1_invlist);
@@ -6713,6 +6717,14 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
 	PL_InBitmap = _new_invlist(2);
 	PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0,
                                                     NUM_ANYOF_CODE_POINTS - 1);
+#ifdef DEBUGGING
+        dump_len_string = PerlEnv_getenv("PERL_DUMP_RE_MAX_LEN");
+        if (   ! dump_len_string
+            || ! grok_atoUV(dump_len_string, &PL_dump_re_max_len, NULL))
+        {
+            PL_dump_re_max_len = 0;
+        }
+#endif
     }
 
     pRExC_state->code_blocks = NULL;
@@ -18463,6 +18475,9 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_
                     char *s = savesvpv(lv);
                     const char * const orig_s = s;  /* Save the beginning of
                                                        's', so can be freed */
+                    const STRLEN dump_len = (PL_dump_re_max_len)
+                                            ? PL_dump_re_max_len
+                                            : 256;
 
                     /* Ignore anything before the first \n */
                     while (*s && *s != '\n')
@@ -18491,7 +18506,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_
                             if (*s == '\n') {
 
                                 /* Truncate very long output */
-                                if ((UV) (s - t) > 256) {
+                                if ((UV) (s - t) > dump_len) {
                                     Perl_sv_catpvf(aTHX_ sv,
                                                 "%.*s...",
                                                 (int) (s - t),
diff --git a/regcomp.h b/regcomp.h
index 07e098a880..c08888e8f8 100644
--- a/regcomp.h
+++ b/regcomp.h
@@ -1069,22 +1069,25 @@ re.pm, especially to the documentation.
         PERL_UNUSED_VAR(re_debug_flags); GET_RE_DEBUG_FLAGS;
 
 #define RE_PV_COLOR_DECL(rpv,rlen,isuni,dsv,pv,l,m,c1,c2) \
-    const char * const rpv =                          \
-        pv_pretty((dsv), (pv), (l), (m), \
-            PL_colors[(c1)],PL_colors[(c2)], \
+    const char * const rpv =                                 \
+        pv_pretty((dsv), (pv), (l),                          \
+            (PL_dump_re_max_len) ? PL_dump_re_max_len : (m), \
+            PL_colors[(c1)],PL_colors[(c2)],                 \
             PERL_PV_ESCAPE_RE|PERL_PV_ESCAPE_NONASCII |((isuni) ? PERL_PV_ESCAPE_UNI : 0) );         \
     const int rlen = SvCUR(dsv)
 
-#define RE_SV_ESCAPE(rpv,isuni,dsv,sv,m) \
-    const char * const rpv =                          \
-        pv_pretty((dsv), (SvPV_nolen_const(sv)), (SvCUR(sv)), (m), \
-            PL_colors[(c1)],PL_colors[(c2)], \
+#define RE_SV_ESCAPE(rpv,isuni,dsv,sv,m)                        \
+    const char * const rpv =                                    \
+        pv_pretty((dsv), (SvPV_nolen_const(sv)), (SvCUR(sv)),   \
+            (PL_dump_re_max_len) ? PL_dump_re_max_len : (m),    \
+            PL_colors[(c1)],PL_colors[(c2)],                    \
             PERL_PV_ESCAPE_RE|PERL_PV_ESCAPE_NONASCII |((isuni) ? PERL_PV_ESCAPE_UNI : 0) )
 
 #define RE_PV_QUOTED_DECL(rpv,isuni,dsv,pv,l,m)                    \
     const char * const rpv =                                       \
-        pv_pretty((dsv), (pv), (l), (m), \
-            PL_colors[0], PL_colors[1], \
+        pv_pretty((dsv), (pv), (l),                                \
+            (PL_dump_re_max_len) ? PL_dump_re_max_len : (m),       \
+            PL_colors[0], PL_colors[1],                            \
             ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_ESCAPE_NONASCII | PERL_PV_PRETTY_ELLIPSES | \
               ((isuni) ? PERL_PV_ESCAPE_UNI : 0))                  \
         )