diff --git a/dump.c b/dump.c index efddad3f1652..f056184e7322 100644 --- a/dump.c +++ b/dump.c @@ -95,7 +95,7 @@ S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start, | ((utf8) ? PERL_PV_ESCAPE_UNI : 0) ) #define _pv_display_for_dump(dsv, pv, cur, len, pvlim) \ - _pv_display_flags(aTHX_ dsv, pv, cur, len, pvlim, PERL_PV_ESCAPE_DWIM_ALL_HEX) + pv_display_flags(dsv, pv, cur, len, pvlim, PERL_PV_ESCAPE_DWIM_ALL_HEX) /* =for apidoc pv_escape @@ -417,9 +417,9 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, } STATIC char * -_pv_display_flags(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim, I32 pretty_flags) +S_pv_display_flags(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim, I32 pretty_flags) { - PERL_ARGS_ASSERT_PV_DISPLAY; + PERL_ARGS_ASSERT_PV_DISPLAY_FLAGS; pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP | pretty_flags ); if (len > cur && pv[cur] == '\0') @@ -445,7 +445,9 @@ Note that the final string may be up to 7 chars longer than pvlim. char * Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) { - return _pv_display_flags(aTHX_ dsv, pv, cur, len, pvlim, 0); + PERL_ARGS_ASSERT_PV_DISPLAY; + + return pv_display_flags(dsv, pv, cur, len, pvlim, 0); } /* diff --git a/embed.fnc b/embed.fnc index 2acd231dfd2c..0e98416a5b0e 100644 --- a/embed.fnc +++ b/embed.fnc @@ -4460,6 +4460,13 @@ ERXp |const char *|form_cp_too_large_msg \ S |CV * |deb_curcv |I32 ix Sd |void |debprof |NN const OP *o S |SV * |pm_description |NN const PMOP *pm +S |char * |pv_display_flags \ + |NN SV *dsv \ + |NN const char *pv \ + |STRLEN cur \ + |STRLEN len \ + |STRLEN pvlim \ + |I32 pretty_flags S |UV |sequence_num |NULLOK const OP *o #endif #if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || \ @@ -4962,6 +4969,12 @@ S |OP * |too_many_arguments_pv \ |NN const char *name \ |U32 flags S |OP * |voidnonfinal |NULLOK OP *o +# if defined(DEBUGGING) +S |const char *|get_displayable_tr_operand \ + |NN const U8 *s \ + |STRLEN len \ + |bool is_utf8 +# endif #endif /* defined(PERL_IN_OP_C) */ #if defined(PERL_IN_OP_C) || defined(PERL_IN_PAD_C) Ti |bool |PadnameIN_SCOPE|NN const PADNAME * const pn \ diff --git a/embed.h b/embed.h index fa647eadca0a..833a16a955c8 100644 --- a/embed.h +++ b/embed.h @@ -1340,6 +1340,7 @@ # define deb_curcv(a) S_deb_curcv(aTHX_ a) # define debprof(a) S_debprof(aTHX_ a) # define pm_description(a) S_pm_description(aTHX_ a) +# define pv_display_flags(a,b,c,d,e,f) S_pv_display_flags(aTHX_ a,b,c,d,e,f) # define sequence_num(a) S_sequence_num(aTHX_ a) # endif # if defined(PERL_IN_GV_C) @@ -1518,6 +1519,9 @@ # define too_few_arguments_pv(a,b,c) S_too_few_arguments_pv(aTHX_ a,b,c) # define too_many_arguments_pv(a,b,c) S_too_many_arguments_pv(aTHX_ a,b,c) # define voidnonfinal(a) S_voidnonfinal(aTHX_ a) +# if defined(DEBUGGING) +# define get_displayable_tr_operand(a,b,c) S_get_displayable_tr_operand(aTHX_ a,b,c) +# endif # endif /* defined(PERL_IN_OP_C) */ # if defined(PERL_IN_OP_C) || defined(PERL_IN_PAD_C) # define PadnameIN_SCOPE S_PadnameIN_SCOPE diff --git a/op.c b/op.c index 3a7a1431c0c3..6c9ff7352f7c 100644 --- a/op.c +++ b/op.c @@ -6179,6 +6179,25 @@ Perl_invmap_dump(pTHX_ SV* invlist, UV *map) } } +#ifdef DEBUGGING + +static const char * +S_get_displayable_tr_operand(pTHX_ const U8 * s, STRLEN len, bool is_utf8) +{ + SV * output = sv_2mortal(newSVpvs("")); + if (is_utf8) { + return pv_uni_display(output, s, len, 1000, UNI_DISPLAY_TR_); + } + else { + return pv_pretty(output, (const char *) s, len, 256, NULL, NULL, + ( PERL_PV_ESCAPE_NONASCII + |PERL_PV_PRETTY_LTGT + |PERL_PV_PRETTY_ELLIPSES)); + } +} + +#endif + /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl * containing the search and replacement strings, assemble into * a translation table attached as o->op_pv. @@ -6528,6 +6547,13 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) PL_hints |= HINT_BLOCK_SCOPE; + DEBUG_y(PerlIO_printf(Perl_debug_log, + "%s: %d: Compiling tr/*t/*r/; /c=%d; /d=%d; /s=%d\n" + "*t is '%s'\n*r is '%s'\n", + __FILE__, __LINE__, complement, del, squash, + get_displayable_tr_operand(t0, tlen, tstr_utf8), + get_displayable_tr_operand(r0, rlen, rstr_utf8))); + /* If /c, the search list is sorted and complemented. This is now done by * creating an inversion list from it, and then trivially inverting that. * The previous implementation used qsort, but creating the list @@ -6609,6 +6635,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) tend = t0 + temp_len; tstr_utf8 = TRUE; + DEBUG_y(PerlIO_printf(Perl_debug_log, + "%s: %d: *t after complementing=\n%s\n", + __FILE__, __LINE__, + get_displayable_tr_operand(t0, temp_len, tstr_utf8))); + SvREFCNT_dec_NN(inverted_tlist); } @@ -6653,8 +6684,8 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) for (pass2 = 0; pass2 < 2; pass2++) { if (pass2) { - DEBUG_yv(PerlIO_printf(Perl_debug_log, "After pass1: \n")); - DEBUG_yv(invmap_dump(t_invlist, r_map)); + DEBUG_y(PerlIO_printf(Perl_debug_log, "After pass1: \n"); + invmap_dump(t_invlist, r_map)); /* In the second pass, we start with a single range */ t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX); @@ -6786,9 +6817,9 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) r_range_count = t_range_count; #ifdef DEBUGGING - if (DEBUG_y_TEST && ! del) { + if (DEBUG_yv_TEST && ! del) { PerlIO_printf(Perl_debug_log, - "final_map =%" UVXf "\n", final_map); + "final_map = %" UVXf "\n", final_map); } #endif } @@ -6904,9 +6935,25 @@ 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)); + +#ifdef DEBUGGING + if (DEBUG_yv_TEST) { + PerlIO_printf(Perl_debug_log, + "Processing %" UVxf "-%" UVxf " => ", + t_cp, t_cp_end); + if (r_cp == r_cp_end && r_cp == TR_UNLISTED) { + PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n"); + } + else if (r_cp == r_cp_end && r_cp == TR_SPECIAL_HANDLING) { + PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n"); + } + else { + PerlIO_printf(Perl_debug_log, + "%" UVxf "-%" UVxf "\n", + r_cp, r_cp_end); + } + } +#endif /* This is the first definition for this chunk, hence is valid * and needs to be processed. Here and in the comments below, @@ -7211,8 +7258,8 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) 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)); + (int) len, (int) i); + invmap_dump(t_invlist, r_map)); invlist_extend(t_invlist, len + 2); t_array = invlist_array(t_invlist); @@ -7234,10 +7281,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) r_map[i+2] = TR_UNLISTED; } DEBUG_yv(PerlIO_printf(Perl_debug_log, - "After iteration: span=%" UVuf ", t_range_count=%" - UVuf " r_range_count=%" UVuf "\n", - span, t_range_count, r_range_count)); - DEBUG_yv(invmap_dump(t_invlist, r_map)); + "After iteration: span=%" UVuf + ", t_range_count=%" UVuf + " r_range_count=%" UVuf "\n", + span, t_range_count, r_range_count); + invmap_dump(t_invlist, r_map)); } /* End of this chunk needs to be processed */ /* Done with this chunk. */ @@ -7266,8 +7314,8 @@ 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)); + DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"); + invmap_dump(t_invlist, r_map)); /* We now have normalized the input into an inversion map. * @@ -7417,7 +7465,16 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) : (short) TR_R_EMPTY; #ifdef DEBUGGING if (DEBUG_y_TEST) { - PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__); + PerlIO_printf(Perl_debug_log, + "\n%s: %d: Final generated translation table:\n %" + IVdf " means this char not involved in this transliteration\n", + __FILE__, __LINE__, TR_UNLISTED); + if (del) { + PerlIO_printf(Perl_debug_log, + " %" IVdf " means delete this char\n", + TR_SPECIAL_HANDLING); + } + for (i = 0; i < tbl->size; i++) { if (tbl->map[i] < 0) { PerlIO_printf(Perl_debug_log," %02x=>%d", @@ -7431,8 +7488,32 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) PerlIO_printf(Perl_debug_log,"\n"); } } - PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n", - (unsigned) tbl->size, tbl->map[tbl->size]); + + PerlIO_printf(Perl_debug_log, + "The next (and final) byte "); + if ((UV) tbl->map[tbl->size] == TR_UNLISTED) { + PerlIO_printf(Perl_debug_log, + " indicates no other characters are involved in" + " the transliteration\n"); + } + else if ((UV) tbl->map[tbl->size] == TR_SPECIAL_HANDLING) { + if (! del) { + const int size = tbl->size; + croak("panic: Unexpected value %x in [%d]", + tbl->map[size], size); + } + else { + PerlIO_printf(Perl_debug_log, + "indicates that all code points above" + " 0xFF are to be deleted\n"); + } + } + else if ((UV) tbl->map[tbl->size] == TR_R_EMPTY) { + PerlIO_printf(Perl_debug_log, "is unused\n"); + } + else { + PerlIO_printf(Perl_debug_log, "%x UNUSED\n", tbl->map[256]); + } }; #endif diff --git a/proto.h b/proto.h index 8f2afc3ab5a0..19782f9bfbd2 100644 --- a/proto.h +++ b/proto.h @@ -6861,6 +6861,11 @@ S_pm_description(pTHX_ const PMOP *pm); # define PERL_ARGS_ASSERT_PM_DESCRIPTION \ assert(pm) +STATIC char * +S_pv_display_flags(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim, I32 pretty_flags); +# define PERL_ARGS_ASSERT_PV_DISPLAY_FLAGS \ + assert(dsv); assert(pv) + STATIC UV S_sequence_num(pTHX_ const OP *o); # define PERL_ARGS_ASSERT_SEQUENCE_NUM @@ -7551,6 +7556,13 @@ STATIC OP * S_voidnonfinal(pTHX_ OP *o); # define PERL_ARGS_ASSERT_VOIDNONFINAL +# if defined(DEBUGGING) +STATIC const char * +S_get_displayable_tr_operand(pTHX_ const U8 *s, STRLEN len, bool is_utf8); +# define PERL_ARGS_ASSERT_GET_DISPLAYABLE_TR_OPERAND \ + assert(s) + +# endif # if !defined(PERL_NO_INLINE_FUNCTIONS) PERL_STATIC_INLINE bool S_is_standard_filehandle_name(const char *fhname);