regcomp_debug.c

   1 #ifdef PERL_EXT_RE_BUILD
   2 #include "re_top.h"
   3 #endif
   4
   5 #include "EXTERN.h"
   6 #define PERL_IN_REGEX_ENGINE
   7 #define PERL_IN_REGCOMP_ANY
   8 #define PERL_IN_REGCOMP_DEBUG_C
   9 #include "perl.h"
  10
  11 #ifdef PERL_IN_XSUB_RE
  12 #  include "re_comp.h"
  13 #else
  14 #  include "regcomp.h"
  15 #endif
  16
  17 #include "invlist_inline.h"
  18 #include "unicode_constants.h"
  19 #include "regcomp_internal.h"
  20
  21 #ifdef DEBUGGING
  22
  23 int
  24 Perl_re_printf(pTHX_ const char *fmt, ...)
  25 {
  26     va_list ap;
  27     int result;
  28     PerlIO *f= Perl_debug_log;
  29     PERL_ARGS_ASSERT_RE_PRINTF;
  30     va_start(ap, fmt);
  31     result = PerlIO_vprintf(f, fmt, ap);
  32     va_end(ap);
  33     return result;
  34 }
  35
  36 int
  37 Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...)
  38 {
  39     va_list ap;
  40     int result;
  41     PerlIO *f= Perl_debug_log;
  42     PERL_ARGS_ASSERT_RE_INDENTF;
  43     va_start(ap, depth);
  44     PerlIO_printf(f, "%*s", ( (int)depth % 20 ) * 2, "");
  45     result = PerlIO_vprintf(f, fmt, ap);
  46     va_end(ap);
  47     return result;
  48 }
  49
  50 void
  51 Perl_debug_show_study_flags(pTHX_ U32 flags, const char *open_str,
  52                                     const char *close_str)
  53 {
  54     PERL_ARGS_ASSERT_DEBUG_SHOW_STUDY_FLAGS;
  55     if (!flags)
  56         return;
  57
  58     Perl_re_printf( aTHX_  "%s", open_str);
  59     DEBUG_SHOW_STUDY_FLAG(flags, SF_BEFORE_SEOL);
  60     DEBUG_SHOW_STUDY_FLAG(flags, SF_BEFORE_MEOL);
  61     DEBUG_SHOW_STUDY_FLAG(flags, SF_IS_INF);
  62     DEBUG_SHOW_STUDY_FLAG(flags, SF_HAS_PAR);
  63     DEBUG_SHOW_STUDY_FLAG(flags, SF_IN_PAR);
  64     DEBUG_SHOW_STUDY_FLAG(flags, SF_HAS_EVAL);
  65     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_SUBSTR);
  66     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS_AND);
  67     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS_OR);
  68     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS);
  69     DEBUG_SHOW_STUDY_FLAG(flags, SCF_WHILEM_VISITED_POS);
  70     DEBUG_SHOW_STUDY_FLAG(flags, SCF_TRIE_RESTUDY);
  71     DEBUG_SHOW_STUDY_FLAG(flags, SCF_SEEN_ACCEPT);
  72     DEBUG_SHOW_STUDY_FLAG(flags, SCF_TRIE_DOING_RESTUDY);
  73     DEBUG_SHOW_STUDY_FLAG(flags, SCF_IN_DEFINE);
  74     Perl_re_printf( aTHX_  "%s", close_str);
  75 }
  76
  77 void
  78 Perl_debug_studydata(pTHX_ const char *where, scan_data_t *data,
  79                     U32 depth, int is_inf,
  80                     SSize_t min, SSize_t stopmin, SSize_t delta)
  81 {
  82     PERL_ARGS_ASSERT_DEBUG_STUDYDATA;
  83     DECLARE_AND_GET_RE_DEBUG_FLAGS;
  84
  85     DEBUG_OPTIMISE_MORE_r({
  86         if (!data) {
  87             Perl_re_indentf(aTHX_  "%s: NO DATA",
  88                 depth,
  89                 where);
  90             return;
  91         }
  92         Perl_re_indentf(aTHX_  "%s: M/S/D: %" IVdf "/%" IVdf "/%" IVdf " Pos:%" IVdf "/%" IVdf " Flags: 0x%" UVXf,
  93             depth,
  94             where,
  95             min, stopmin, delta,
  96             (IV)data->pos_min,
  97             (IV)data->pos_delta,
  98             (UV)data->flags
  99         );
 100
 101         Perl_debug_show_study_flags(aTHX_ data->flags," [","]");
 102
 103         Perl_re_printf( aTHX_
 104             " Whilem_c: %" IVdf " Lcp: %" IVdf " %s",
 105             (IV)data->whilem_c,
 106             (IV)(data->last_closep ? *((data)->last_closep) : -1),
 107             is_inf ? "INF " : ""
 108         );
 109
 110         if (data->last_found) {
 111             int i;
 112             Perl_re_printf(aTHX_
 113                 "Last:'%s' %" IVdf ":%" IVdf "/%" IVdf,
 114                     SvPVX_const(data->last_found),
 115                     (IV)data->last_end,
 116                     (IV)data->last_start_min,
 117                     (IV)data->last_start_max
 118             );
 119
 120             for (i = 0; i < 2; i++) {
 121                 Perl_re_printf(aTHX_
 122                     " %s%s: '%s' @ %" IVdf "/%" IVdf,
 123                     data->cur_is_floating == i ? "*" : "",
 124                     i ? "Float" : "Fixed",
 125                     SvPVX_const(data->substrs[i].str),
 126                     (IV)data->substrs[i].min_offset,
 127                     (IV)data->substrs[i].max_offset
 128                 );
 129                 Perl_debug_show_study_flags(aTHX_ data->substrs[i].flags," [","]");
 130             }
 131         }
 132
 133         Perl_re_printf( aTHX_ "\n");
 134     });
 135 }
 136
 137
 138 void
 139 Perl_debug_peep(pTHX_ const char *str, const RExC_state_t *pRExC_state,
 140                 regnode *scan, U32 depth, U32 flags)
 141 {
 142     PERL_ARGS_ASSERT_DEBUG_PEEP;
 143     DECLARE_AND_GET_RE_DEBUG_FLAGS;
 144
 145     DEBUG_OPTIMISE_r({
 146         regnode *Next;
 147
 148         if (!scan)
 149             return;
 150         Next = regnext(scan);
 151         regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
 152         Perl_re_indentf( aTHX_   "%s>%3d: %s (%d)",
 153             depth,
 154             str,
 155             REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),
 156             Next ? (REG_NODE_NUM(Next)) : 0 );
 157         Perl_debug_show_study_flags(aTHX_ flags," [ ","]");
 158         Perl_re_printf( aTHX_  "\n");
 159    });
 160 }
 161
 162 #endif /* DEBUGGING */
 163
 164 /*
 165  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
 166  */
 167 #ifdef DEBUGGING
 168
 169 static void
 170 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
 171 {
 172     int bit;
 173     int set=0;
 174
 175     ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
 176
 177     for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
 178         if (flags & (1<<bit)) {
 179             if (!set++ && lead)
 180                 Perl_re_printf( aTHX_  "%s", lead);
 181             Perl_re_printf( aTHX_  "%s ", PL_reg_intflags_name[bit]);
 182         }
 183     }
 184     if (lead)  {
 185         if (set)
 186             Perl_re_printf( aTHX_  "\n");
 187         else
 188             Perl_re_printf( aTHX_  "%s[none-set]\n", lead);
 189     }
 190 }
 191
 192 static void
 193 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
 194 {
 195     int bit;
 196     int set=0;
 197     regex_charset cs;
 198
 199     ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
 200
 201     for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
 202         if (flags & (1U<<bit)) {
 203             if ((1U<<bit) & RXf_PMf_CHARSET) {  /* Output separately, below */
 204                 continue;
 205             }
 206             if (!set++ && lead)
 207                 Perl_re_printf( aTHX_  "%s", lead);
 208             Perl_re_printf( aTHX_  "%s ", PL_reg_extflags_name[bit]);
 209         }
 210     }
 211     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
 212             if (!set++ && lead) {
 213                 Perl_re_printf( aTHX_  "%s", lead);
 214             }
 215             switch (cs) {
 216                 case REGEX_UNICODE_CHARSET:
 217                     Perl_re_printf( aTHX_  "UNICODE");
 218                     break;
 219                 case REGEX_LOCALE_CHARSET:
 220                     Perl_re_printf( aTHX_  "LOCALE");
 221                     break;
 222                 case REGEX_ASCII_RESTRICTED_CHARSET:
 223                     Perl_re_printf( aTHX_  "ASCII-RESTRICTED");
 224                     break;
 225                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
 226                     Perl_re_printf( aTHX_  "ASCII-MORE_RESTRICTED");
 227                     break;
 228                 default:
 229                     Perl_re_printf( aTHX_  "UNKNOWN CHARACTER SET");
 230                     break;
 231             }
 232     }
 233     if (lead)  {
 234         if (set)
 235             Perl_re_printf( aTHX_  "\n");
 236         else
 237             Perl_re_printf( aTHX_  "%s[none-set]\n", lead);
 238     }
 239 }
 240 #endif
 241
 242 void
 243 Perl_regdump(pTHX_ const regexp *r)
 244 {
 245 #ifdef DEBUGGING
 246     int i;
 247     SV * const sv = sv_newmortal();
 248     SV *dsv= sv_newmortal();
 249     RXi_GET_DECL(r, ri);
 250     DECLARE_AND_GET_RE_DEBUG_FLAGS;
 251
 252     PERL_ARGS_ASSERT_REGDUMP;
 253
 254     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
 255
 256     /* Header fields of interest. */
 257     for (i = 0; i < 2; i++) {
 258         if (r->substrs->data[i].substr) {
 259             RE_PV_QUOTED_DECL(s, 0, dsv,
 260                             SvPVX_const(r->substrs->data[i].substr),
 261                             RE_SV_DUMPLEN(r->substrs->data[i].substr),
 262                             PL_dump_re_max_len);
 263             Perl_re_printf( aTHX_
 264                           "%s %s%s at %" IVdf "..%" UVuf " ",
 265                           i ? "floating" : "anchored",
 266                           s,
 267                           RE_SV_TAIL(r->substrs->data[i].substr),
 268                           (IV)r->substrs->data[i].min_offset,
 269                           (UV)r->substrs->data[i].max_offset);
 270         }
 271         else if (r->substrs->data[i].utf8_substr) {
 272             RE_PV_QUOTED_DECL(s, 1, dsv,
 273                             SvPVX_const(r->substrs->data[i].utf8_substr),
 274                             RE_SV_DUMPLEN(r->substrs->data[i].utf8_substr),
 275                             30);
 276             Perl_re_printf( aTHX_
 277                           "%s utf8 %s%s at %" IVdf "..%" UVuf " ",
 278                           i ? "floating" : "anchored",
 279                           s,
 280                           RE_SV_TAIL(r->substrs->data[i].utf8_substr),
 281                           (IV)r->substrs->data[i].min_offset,
 282                           (UV)r->substrs->data[i].max_offset);
 283         }
 284     }
 285
 286     if (r->check_substr || r->check_utf8)
 287         Perl_re_printf( aTHX_
 288                       (const char *)
 289                       (   r->check_substr == r->substrs->data[1].substr
 290                        && r->check_utf8   == r->substrs->data[1].utf8_substr
 291                        ? "(checking floating" : "(checking anchored"));
 292     if (r->intflags & PREGf_NOSCAN)
 293         Perl_re_printf( aTHX_  " noscan");
 294     if (r->extflags & RXf_CHECK_ALL)
 295         Perl_re_printf( aTHX_  " isall");
 296     if (r->check_substr || r->check_utf8)
 297         Perl_re_printf( aTHX_  ") ");
 298
 299     if (ri->regstclass) {
 300         regprop(r, sv, ri->regstclass, NULL, NULL);
 301         Perl_re_printf( aTHX_  "stclass %s ", SvPVX_const(sv));
 302     }
 303     if (r->intflags & PREGf_ANCH) {
 304         Perl_re_printf( aTHX_  "anchored");
 305         if (r->intflags & PREGf_ANCH_MBOL)
 306             Perl_re_printf( aTHX_  "(MBOL)");
 307         if (r->intflags & PREGf_ANCH_SBOL)
 308             Perl_re_printf( aTHX_  "(SBOL)");
 309         if (r->intflags & PREGf_ANCH_GPOS)
 310             Perl_re_printf( aTHX_  "(GPOS)");
 311         Perl_re_printf( aTHX_ " ");
 312     }
 313     if (r->intflags & PREGf_GPOS_SEEN)
 314         Perl_re_printf( aTHX_  "GPOS:%" UVuf " ", (UV)r->gofs);
 315     if (r->intflags & PREGf_SKIP)
 316         Perl_re_printf( aTHX_  "plus ");
 317     if (r->intflags & PREGf_IMPLICIT)
 318         Perl_re_printf( aTHX_  "implicit ");
 319     Perl_re_printf( aTHX_  "minlen %" IVdf " ", (IV)r->minlen);
 320     if (r->extflags & RXf_EVAL_SEEN)
 321         Perl_re_printf( aTHX_  "with eval ");
 322     Perl_re_printf( aTHX_  "\n");
 323     DEBUG_FLAGS_r({
 324         regdump_extflags("r->extflags: ", r->extflags);
 325         regdump_intflags("r->intflags: ", r->intflags);
 326     });
 327 #else
 328     PERL_ARGS_ASSERT_REGDUMP;
 329     PERL_UNUSED_CONTEXT;
 330     PERL_UNUSED_ARG(r);
 331 #endif  /* DEBUGGING */
 332 }
 333
 334 /* Should be synchronized with ANYOF_ #defines in regcomp.h */
 335 #ifdef DEBUGGING
 336
 337 #  if   CC_WORDCHAR_ != 0 || CC_DIGIT_ != 1        || CC_ALPHA_ != 2    \
 338      || CC_LOWER_ != 3    || CC_UPPER_ != 4        || CC_PUNCT_ != 5    \
 339      || CC_PRINT_ != 6    || CC_ALPHANUMERIC_ != 7 || CC_GRAPH_ != 8    \
 340      || CC_CASED_ != 9    || CC_SPACE_ != 10       || CC_BLANK_ != 11   \
 341      || CC_XDIGIT_ != 12  || CC_CNTRL_ != 13       || CC_ASCII_ != 14   \
 342      || CC_VERTSPACE_ != 15
 343 #   error Need to adjust order of anyofs[]
 344 #  endif
 345 static const char * const anyofs[] = {
 346     "\\w",
 347     "\\W",
 348     "\\d",
 349     "\\D",
 350     "[:alpha:]",
 351     "[:^alpha:]",
 352     "[:lower:]",
 353     "[:^lower:]",
 354     "[:upper:]",
 355     "[:^upper:]",
 356     "[:punct:]",
 357     "[:^punct:]",
 358     "[:print:]",
 359     "[:^print:]",
 360     "[:alnum:]",
 361     "[:^alnum:]",
 362     "[:graph:]",
 363     "[:^graph:]",
 364     "[:cased:]",
 365     "[:^cased:]",
 366     "\\s",
 367     "\\S",
 368     "[:blank:]",
 369     "[:^blank:]",
 370     "[:xdigit:]",
 371     "[:^xdigit:]",
 372     "[:cntrl:]",
 373     "[:^cntrl:]",
 374     "[:ascii:]",
 375     "[:^ascii:]",
 376     "\\v",
 377     "\\V"
 378 };
 379 #endif
 380
 381 /*
 382 - regprop - printable representation of opcode, with run time support
 383 */
 384
 385 void
 386 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state)
 387 {
 388 #ifdef DEBUGGING
 389     U8 k;
 390     const U8 op = OP(o);
 391     RXi_GET_DECL(prog, progi);
 392     DECLARE_AND_GET_RE_DEBUG_FLAGS;
 393
 394     PERL_ARGS_ASSERT_REGPROP;
 395
 396     SvPVCLEAR(sv);
 397
 398     if (op > REGNODE_MAX) {          /* regnode.type is unsigned */
 399         if (pRExC_state) {  /* This gives more info, if we have it */
 400             FAIL3("panic: corrupted regexp opcode %d > %d",
 401                   (int)op, (int)REGNODE_MAX);
 402         }
 403         else {
 404             Perl_croak(aTHX_ "panic: corrupted regexp opcode %d > %d",
 405                              (int)op, (int)REGNODE_MAX);
 406         }
 407     }
 408     sv_catpv(sv, REGNODE_NAME(op)); /* Take off const! */
 409
 410     k = REGNODE_TYPE(op);
 411
 412     if (k == EXACT) {
 413         sv_catpvs(sv, " ");
 414         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
 415          * is a crude hack but it may be the best for now since
 416          * we have no flag "this EXACTish node was UTF-8"
 417          * --jhi */
 418         pv_pretty(sv, STRING(o), STR_LEN(o), PL_dump_re_max_len,
 419                   PL_colors[0], PL_colors[1],
 420                   PERL_PV_ESCAPE_UNI_DETECT |
 421                   PERL_PV_ESCAPE_NONASCII   |
 422                   PERL_PV_PRETTY_ELLIPSES   |
 423                   PERL_PV_PRETTY_LTGT       |
 424                   PERL_PV_PRETTY_NOCLEAR
 425                   );
 426     } else if (k == TRIE) {
 427         /* print the details of the trie in dumpuntil instead, as
 428          * progi->data isn't available here */
 429         const U32 n = ARG(o);
 430         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
 431                (reg_ac_data *)progi->data->data[n] :
 432                NULL;
 433         const reg_trie_data * const trie
 434             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
 435
 436         Perl_sv_catpvf(aTHX_ sv, "-%s", REGNODE_NAME(o->flags));
 437         DEBUG_TRIE_COMPILE_r({
 438           if (trie->jump)
 439             sv_catpvs(sv, "(JUMP)");
 440           Perl_sv_catpvf(aTHX_ sv,
 441             "<S:%" UVuf "/%" IVdf " W:%" UVuf " L:%" UVuf "/%" UVuf " C:%" UVuf "/%" UVuf ">",
 442             (UV)trie->startstate,
 443             (IV)trie->statecount-1, /* -1 because of the unused 0 element */
 444             (UV)trie->wordcount,
 445             (UV)trie->minlen,
 446             (UV)trie->maxlen,
 447             (UV)TRIE_CHARCOUNT(trie),
 448             (UV)trie->uniquecharcount
 449           );
 450         });
 451         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
 452             sv_catpvs(sv, "[");
 453             (void) put_charclass_bitmap_innards(sv,
 454                                                 ((IS_ANYOF_TRIE(op))
 455                                                  ? ANYOF_BITMAP(o)
 456                                                  : TRIE_BITMAP(trie)),
 457                                                 NULL,
 458                                                 NULL,
 459                                                 NULL,
 460                                                 0,
 461                                                 FALSE
 462                                                );
 463             sv_catpvs(sv, "]");
 464         }
 465     } else if (k == CURLY) {
 466         U32 lo = ARG1(o), hi = ARG2(o);
 467         if (op == CURLYM || op == CURLYN || op == CURLYX)
 468             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
 469         Perl_sv_catpvf(aTHX_ sv, "{%u,", (unsigned) lo);
 470         if (hi == REG_INFTY)
 471             sv_catpvs(sv, "INFTY");
 472         else
 473             Perl_sv_catpvf(aTHX_ sv, "%u", (unsigned) hi);
 474         sv_catpvs(sv, "}");
 475     }
 476     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
 477         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
 478     else if (k == REF || k == OPEN || k == CLOSE
 479              || k == GROUPP || op == ACCEPT)
 480     {
 481         AV *name_list= NULL;
 482         U32 parno= (op == ACCEPT)              ? (U32)ARG2L(o) :
 483                    (op == OPEN || op == CLOSE) ? (U32)PARNO(o) :
 484                                                  (U32)ARG(o);
 485         if ( RXp_PAREN_NAMES(prog) ) {
 486             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
 487         } else if ( pRExC_state ) {
 488             name_list= RExC_paren_name_list;
 489         }
 490         if ( name_list ) {
 491             if ( k != REF || (op < REFN)) {
 492                 UV logical_parno = parno;
 493                 if (prog->parno_to_logical)
 494                     logical_parno = prog->parno_to_logical[parno];
 495
 496                 Perl_sv_catpvf(aTHX_ sv, "%" UVuf, (UV)logical_parno);     /* Parenth number */
 497                 if (parno != logical_parno)
 498                     Perl_sv_catpvf(aTHX_ sv, "/%" UVuf, (UV)parno);        /* Parenth number */
 499
 500                 SV **name= av_fetch_simple(name_list, parno, 0 );
 501                 if (name)
 502                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
 503             }
 504             else
 505             if (parno > 0) {
 506                 /* parno must always be larger than 0 for this block
 507                  * as it represents a slot into the data array, which
 508                  * has the 0 slot reserved for a placeholder so any valid
 509                  * index into it is always true, eg non-zero
 510                  * see the '%' "what" type and the implementation of
 511                  * S_reg_add_data()
 512                  */
 513                 SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]);
 514                 I32 *nums=(I32*)SvPVX(sv_dat);
 515                 SV **name= av_fetch_simple(name_list, nums[0], 0 );
 516                 I32 n;
 517                 if (name) {
 518                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
 519                         Perl_sv_catpvf(aTHX_ sv, "%s%" IVdf,
 520                                     (n ? "," : ""), (IV)nums[n]);
 521                     }
 522                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
 523                 }
 524             }
 525         } else if (parno>0) {
 526             UV logical_parno = parno;
 527             if (prog->parno_to_logical)
 528                 logical_parno = prog->parno_to_logical[parno];
 529
 530             Perl_sv_catpvf(aTHX_ sv, "%" UVuf, (UV)logical_parno);     /* Parenth number */
 531             if (logical_parno != parno)
 532                 Perl_sv_catpvf(aTHX_ sv, "/%" UVuf, (UV)parno);     /* Parenth number */
 533
 534         }
 535         if ( k == REF && reginfo) {
 536             U32 n = ARG(o);  /* which paren pair */
 537             I32 ln = RXp_OFFS_START(prog,n);
 538             if (prog->lastparen < n || ln == -1 || RXp_OFFS_END(prog,n) == -1)
 539                 Perl_sv_catpvf(aTHX_ sv, ": FAIL");
 540             else if (ln == RXp_OFFS_END(prog,n))
 541                 Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
 542             else {
 543                 const char *s = reginfo->strbeg + ln;
 544                 Perl_sv_catpvf(aTHX_ sv, ": ");
 545                 Perl_pv_pretty( aTHX_ sv, s, RXp_OFFS_END(prog,n) - RXp_OFFS_START(prog,n), 32, 0, 0,
 546                     PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
 547             }
 548         }
 549     } else if (k == GOSUB) {
 550         AV *name_list= NULL;
 551         IV parno = ARG(o);
 552         IV logical_parno = (parno && prog->parno_to_logical)
 553                          ? prog->parno_to_logical[parno]
 554                          : parno;
 555         if ( RXp_PAREN_NAMES(prog) ) {
 556             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
 557         } else if ( pRExC_state ) {
 558             name_list= RExC_paren_name_list;
 559         }
 560
 561         /* Paren and offset */
 562         Perl_sv_catpvf(aTHX_ sv, "%" IVdf, logical_parno);
 563         if (logical_parno != parno)
 564             Perl_sv_catpvf(aTHX_ sv, "/%" IVdf, parno);
 565
 566         Perl_sv_catpvf(aTHX_ sv, "[%+d:%d]", (int)ARG2L(o),
 567                 (int)((o + (int)ARG2L(o)) - progi->program) );
 568         if (name_list) {
 569             SV **name= av_fetch_simple(name_list, ARG(o), 0 );
 570             if (name)
 571                 Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
 572         }
 573     }
 574     else if (k == LOGICAL)
 575         /* 2: embedded, otherwise 1 */
 576         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
 577     else if (k == ANYOF || k == ANYOFH || k == ANYOFR) {
 578         U8 flags;
 579         char * bitmap;
 580         U8 do_sep = 0;    /* Do we need to separate various components of the
 581                              output? */
 582         /* Set if there is still an unresolved user-defined property */
 583         SV *unresolved                = NULL;
 584
 585         /* Things that are ignored except when the runtime locale is UTF-8 */
 586         SV *only_utf8_locale_invlist = NULL;
 587
 588         /* Code points that don't fit in the bitmap */
 589         SV *nonbitmap_invlist = NULL;
 590
 591         /* And things that aren't in the bitmap, but are small enough to be */
 592         SV* bitmap_range_not_in_bitmap = NULL;
 593
 594         bool inverted;
 595
 596         if (k != ANYOF) {
 597             flags = 0;
 598             bitmap = NULL;
 599         }
 600         else {
 601             flags = ANYOF_FLAGS(o);
 602             bitmap = ANYOF_BITMAP(o);
 603         }
 604
 605         if (op == ANYOFL || op == ANYOFPOSIXL) {
 606             if ((flags & ANYOFL_UTF8_LOCALE_REQD)) {
 607                 sv_catpvs(sv, "{utf8-locale-reqd}");
 608             }
 609             if (flags & ANYOFL_FOLD) {
 610                 sv_catpvs(sv, "{i}");
 611             }
 612         }
 613
 614         inverted = flags & ANYOF_INVERT;
 615
 616         /* If there is stuff outside the bitmap, get it */
 617         if (k == ANYOFR) {
 618
 619             /* For a single range, split into the parts inside vs outside the
 620              * bitmap. */
 621             UV start = ANYOFRbase(o);
 622             UV end   = ANYOFRbase(o) + ANYOFRdelta(o);
 623
 624             if (start < NUM_ANYOF_CODE_POINTS) {
 625                 if (end < NUM_ANYOF_CODE_POINTS) {
 626                     bitmap_range_not_in_bitmap
 627                           = _add_range_to_invlist(bitmap_range_not_in_bitmap,
 628                                                   start, end);
 629                 }
 630                 else {
 631                     bitmap_range_not_in_bitmap
 632                           = _add_range_to_invlist(bitmap_range_not_in_bitmap,
 633                                                   start, NUM_ANYOF_CODE_POINTS);
 634                     start = NUM_ANYOF_CODE_POINTS;
 635                 }
 636             }
 637
 638             if (start >= NUM_ANYOF_CODE_POINTS) {
 639                 nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
 640                                                 ANYOFRbase(o),
 641                                                 ANYOFRbase(o) + ANYOFRdelta(o));
 642             }
 643         }
 644         else if (ANYOF_MATCHES_ALL_OUTSIDE_BITMAP(o)) {
 645             nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
 646                                                       NUM_ANYOF_CODE_POINTS,
 647                                                       UV_MAX);
 648         }
 649         else if (ANYOF_HAS_AUX(o)) {
 650                 (void) GET_REGCLASS_AUX_DATA(prog, o, FALSE,
 651                                                 &unresolved,
 652                                                 &only_utf8_locale_invlist,
 653                                                 &nonbitmap_invlist);
 654
 655             /* The aux data may contain stuff that could fit in the bitmap.
 656              * This could come from a user-defined property being finally
 657              * resolved when this call was done; or much more likely because
 658              * there are matches that require UTF-8 to be valid, and so aren't
 659              * in the bitmap (or ANYOFR).  This is teased apart later */
 660             _invlist_intersection(nonbitmap_invlist,
 661                                   PL_InBitmap,
 662                                   &bitmap_range_not_in_bitmap);
 663             /* Leave just the things that don't fit into the bitmap */
 664             _invlist_subtract(nonbitmap_invlist,
 665                               PL_InBitmap,
 666                               &nonbitmap_invlist);
 667         }
 668
 669         /* Ready to start outputting.  First, the initial left bracket */
 670         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
 671
 672         if (   bitmap
 673             || bitmap_range_not_in_bitmap
 674             || only_utf8_locale_invlist
 675             || unresolved)
 676         {
 677             /* Then all the things that could fit in the bitmap */
 678             do_sep = put_charclass_bitmap_innards(
 679                                     sv,
 680                                     bitmap,
 681                                     bitmap_range_not_in_bitmap,
 682                                     only_utf8_locale_invlist,
 683                                     o,
 684                                     flags,
 685
 686                                     /* Can't try inverting for a
 687                                                    * better display if there
 688                                                    * are things that haven't
 689                                                    * been resolved */
 690                                     (unresolved != NULL || k == ANYOFR));
 691             SvREFCNT_dec(bitmap_range_not_in_bitmap);
 692
 693             /* If there are user-defined properties which haven't been defined
 694              * yet, output them.  If the result is not to be inverted, it is
 695              * clearest to output them in a separate [] from the bitmap range
 696              * stuff.  If the result is to be complemented, we have to show
 697              * everything in one [], as the inversion applies to the whole
 698              * thing.  Use {braces} to separate them from anything in the
 699              * bitmap and anything above the bitmap. */
 700             if (unresolved) {
 701                 if (inverted) {
 702                     if (! do_sep) { /* If didn't output anything in the bitmap
 703                                      */
 704                         sv_catpvs(sv, "^");
 705                     }
 706                     sv_catpvs(sv, "{");
 707                 }
 708                 else if (do_sep) {
 709                     Perl_sv_catpvf(aTHX_ sv,"%s][%s", PL_colors[1],
 710                                                       PL_colors[0]);
 711                 }
 712                 sv_catsv(sv, unresolved);
 713                 if (inverted) {
 714                     sv_catpvs(sv, "}");
 715                 }
 716                 do_sep = ! inverted;
 717             }
 718             else if (     do_sep == 2
 719                      && ! nonbitmap_invlist
 720                      &&   ANYOF_MATCHES_NONE_OUTSIDE_BITMAP(o))
 721             {
 722                 /* Here, the display shows the class as inverted, and
 723                  * everything above the lower display should also match, but
 724                  * there is no indication of that.  Add this range so the code
 725                  * below will add it to the display */
 726                 _invlist_union_complement_2nd(nonbitmap_invlist,
 727                                               PL_InBitmap,
 728                                               &nonbitmap_invlist);
 729             }
 730         }
 731
 732         /* And, finally, add the above-the-bitmap stuff */
 733         if (nonbitmap_invlist && _invlist_len(nonbitmap_invlist)) {
 734             SV* contents;
 735
 736             /* See if truncation size is overridden */
 737             const STRLEN dump_len = (PL_dump_re_max_len > 256)
 738                                     ? PL_dump_re_max_len
 739                                     : 256;
 740
 741             /* This is output in a separate [] */
 742             if (do_sep) {
 743                 Perl_sv_catpvf(aTHX_ sv,"%s][%s", PL_colors[1], PL_colors[0]);
 744             }
 745
 746             /* And, for easy of understanding, it is shown in the
 747              * uncomplemented form if possible.  The one exception being if
 748              * there are unresolved items, where the inversion has to be
 749              * delayed until runtime */
 750             if (inverted && ! unresolved) {
 751                 _invlist_invert(nonbitmap_invlist);
 752                 _invlist_subtract(nonbitmap_invlist, PL_InBitmap, &nonbitmap_invlist);
 753             }
 754
 755             contents = invlist_contents(nonbitmap_invlist,
 756                                         FALSE /* output suitable for catsv */
 757                                        );
 758
 759             /* If the output is shorter than the permissible maximum, just do it. */
 760             if (SvCUR(contents) <= dump_len) {
 761                 sv_catsv(sv, contents);
 762             }
 763             else {
 764                 const char * contents_string = SvPVX(contents);
 765                 STRLEN i = dump_len;
 766
 767                 /* Otherwise, start at the permissible max and work back to the
 768                  * first break possibility */
 769                 while (i > 0 && contents_string[i] != ' ') {
 770                     i--;
 771                 }
 772                 if (i == 0) {       /* Fail-safe.  Use the max if we couldn't
 773                                        find a legal break */
 774                     i = dump_len;
 775                 }
 776
 777                 sv_catpvn(sv, contents_string, i);
 778                 sv_catpvs(sv, "...");
 779             }
 780
 781             SvREFCNT_dec_NN(contents);
 782             SvREFCNT_dec_NN(nonbitmap_invlist);
 783         }
 784
 785         /* And finally the matching, closing ']' */
 786         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
 787
 788         if (op == ANYOFHs) {
 789             Perl_sv_catpvf(aTHX_ sv, " (Leading UTF-8 bytes=%s", _byte_dump_string((U8 *) ((struct regnode_anyofhs *) o)->string, FLAGS(o), 1));
 790         }
 791         else if (REGNODE_TYPE(op) != ANYOF) {
 792             U8 lowest = (op != ANYOFHr)
 793                          ? FLAGS(o)
 794                          : LOWEST_ANYOF_HRx_BYTE(FLAGS(o));
 795             U8 highest = (op == ANYOFHr)
 796                          ? HIGHEST_ANYOF_HRx_BYTE(FLAGS(o))
 797                          : (op == ANYOFH || op == ANYOFR)
 798                            ? 0xFF
 799                            : lowest;
 800 #ifndef EBCDIC
 801             if (op != ANYOFR || ! isASCII(ANYOFRbase(o) + ANYOFRdelta(o)))
 802 #endif
 803             {
 804                 Perl_sv_catpvf(aTHX_ sv, " (First UTF-8 byte=%02X", lowest);
 805                 if (lowest != highest) {
 806                     Perl_sv_catpvf(aTHX_ sv, "-%02X", highest);
 807                 }
 808                 Perl_sv_catpvf(aTHX_ sv, ")");
 809             }
 810         }
 811
 812         SvREFCNT_dec(unresolved);
 813     }
 814     else if (k == ANYOFM) {
 815         SV * cp_list = get_ANYOFM_contents(o);
 816
 817         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
 818         if (op == NANYOFM) {
 819             _invlist_invert(cp_list);
 820         }
 821
 822         put_charclass_bitmap_innards(sv, NULL, cp_list, NULL, NULL, 0, TRUE);
 823         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
 824
 825         SvREFCNT_dec(cp_list);
 826     }
 827     else if (k == ANYOFHbbm) {
 828         SV * cp_list = get_ANYOFHbbm_contents(o);
 829         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
 830
 831         sv_catsv(sv, invlist_contents(cp_list,
 832                                       FALSE /* output suitable for catsv */
 833                                      ));
 834         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
 835
 836         SvREFCNT_dec(cp_list);
 837     }
 838     else if (k == POSIXD || k == NPOSIXD) {
 839         U8 index = FLAGS(o) * 2;
 840         if (index < C_ARRAY_LENGTH(anyofs)) {
 841             if (*anyofs[index] != '[')  {
 842                 sv_catpvs(sv, "[");
 843             }
 844             sv_catpv(sv, anyofs[index]);
 845             if (*anyofs[index] != '[')  {
 846                 sv_catpvs(sv, "]");
 847             }
 848         }
 849         else {
 850             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
 851         }
 852     }
 853     else if (k == BOUND || k == NBOUND) {
 854         /* Must be synced with order of 'bound_type' in regcomp.h */
 855         const char * const bounds[] = {
 856             "",      /* Traditional */
 857             "{gcb}",
 858             "{lb}",
 859             "{sb}",
 860             "{wb}"
 861         };
 862         assert(FLAGS(o) < C_ARRAY_LENGTH(bounds));
 863         sv_catpv(sv, bounds[FLAGS(o)]);
 864     }
 865     else if (k == BRANCHJ && (op == UNLESSM || op == IFMATCH)) {
 866         Perl_sv_catpvf(aTHX_ sv, "[%d", -(o->flags));
 867         if (o->next_off) {
 868             Perl_sv_catpvf(aTHX_ sv, "..-%d", o->flags - o->next_off);
 869         }
 870         Perl_sv_catpvf(aTHX_ sv, "]");
 871     }
 872     else if (op == SBOL)
 873         Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
 874
 875     /* add on the verb argument if there is one */
 876     if ( ( k == VERB || op == ACCEPT || op == OPFAIL ) && o->flags) {
 877         if ( ARG(o) )
 878             Perl_sv_catpvf(aTHX_ sv, ":%" SVf,
 879                        SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
 880         else
 881             sv_catpvs(sv, ":NULL");
 882     }
 883 #else
 884     PERL_UNUSED_CONTEXT;
 885     PERL_UNUSED_ARG(sv);
 886     PERL_UNUSED_ARG(o);
 887     PERL_UNUSED_ARG(prog);
 888     PERL_UNUSED_ARG(reginfo);
 889     PERL_UNUSED_ARG(pRExC_state);
 890 #endif  /* DEBUGGING */
 891 }
 892
 893 #ifdef DEBUGGING
 894
 895 STATIC void
 896 S_put_code_point(pTHX_ SV *sv, UV c)
 897 {
 898     PERL_ARGS_ASSERT_PUT_CODE_POINT;
 899
 900     if (c > 255) {
 901         Perl_sv_catpvf(aTHX_ sv, "\\x{%04" UVXf "}", c);
 902     }
 903     else if (isPRINT(c)) {
 904         const char string = (char) c;
 905
 906         /* We use {phrase} as metanotation in the class, so also escape literal
 907          * braces */
 908         if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}')
 909             sv_catpvs(sv, "\\");
 910         sv_catpvn(sv, &string, 1);
 911     }
 912     else if (isMNEMONIC_CNTRL(c)) {
 913         Perl_sv_catpvf(aTHX_ sv, "%s", cntrl_to_mnemonic((U8) c));
 914     }
 915     else {
 916         Perl_sv_catpvf(aTHX_ sv, "\\x%02X", (U8) c);
 917     }
 918 }
 919
 920 STATIC void
 921 S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
 922 {
 923     /* Appends to 'sv' a displayable version of the range of code points from
 924      * 'start' to 'end'.  Mnemonics (like '\r') are used for the few controls
 925      * that have them, when they occur at the beginning or end of the range.
 926      * It uses hex to output the remaining code points, unless 'allow_literals'
 927      * is true, in which case the printable ASCII ones are output as-is (though
 928      * some of these will be escaped by put_code_point()).
 929      *
 930      * NOTE:  This is designed only for printing ranges of code points that fit
 931      *        inside an ANYOF bitmap.  Higher code points are simply suppressed
 932      */
 933
 934     const unsigned int min_range_count = 3;
 935
 936     assert(start <= end);
 937
 938     PERL_ARGS_ASSERT_PUT_RANGE;
 939
 940     while (start <= end) {
 941         UV this_end;
 942         const char * format;
 943
 944         if (    end - start < min_range_count
 945             && (end - start <= 2 || (isPRINT_A(start) && isPRINT_A(end))))
 946         {
 947             /* Output a range of 1 or 2 chars individually, or longer ranges
 948              * when printable */
 949             for (; start <= end; start++) {
 950                 put_code_point(sv, start);
 951             }
 952             break;
 953         }
 954
 955         /* If permitted by the input options, and there is a possibility that
 956          * this range contains a printable literal, look to see if there is
 957          * one. */
 958         if (allow_literals && start <= MAX_PRINT_A) {
 959
 960             /* If the character at the beginning of the range isn't an ASCII
 961              * printable, effectively split the range into two parts:
 962              *  1) the portion before the first such printable,
 963              *  2) the rest
 964              * and output them separately. */
 965             if (! isPRINT_A(start)) {
 966                 UV temp_end = start + 1;
 967
 968                 /* There is no point looking beyond the final possible
 969                  * printable, in MAX_PRINT_A */
 970                 UV max = MIN(end, MAX_PRINT_A);
 971
 972                 while (temp_end <= max && ! isPRINT_A(temp_end)) {
 973                     temp_end++;
 974                 }
 975
 976                 /* Here, temp_end points to one beyond the first printable if
 977                  * found, or to one beyond 'max' if not.  If none found, make
 978                  * sure that we use the entire range */
 979                 if (temp_end > MAX_PRINT_A) {
 980                     temp_end = end + 1;
 981                 }
 982
 983                 /* Output the first part of the split range: the part that
 984                  * doesn't have printables, with the parameter set to not look
 985                  * for literals (otherwise we would infinitely recurse) */
 986                 put_range(sv, start, temp_end - 1, FALSE);
 987
 988                 /* The 2nd part of the range (if any) starts here. */
 989                 start = temp_end;
 990
 991                 /* We do a continue, instead of dropping down, because even if
 992                  * the 2nd part is non-empty, it could be so short that we want
 993                  * to output it as individual characters, as tested for at the
 994                  * top of this loop.  */
 995                 continue;
 996             }
 997
 998             /* Here, 'start' is a printable ASCII.  If it is an alphanumeric,
 999              * output a sub-range of just the digits or letters, then process
1000              * the remaining portion as usual. */
1001             if (isALPHANUMERIC_A(start)) {
1002                 UV mask = (isDIGIT_A(start))
1003                            ? CC_DIGIT_
1004                              : isUPPER_A(start)
1005                                ? CC_UPPER_
1006                                : CC_LOWER_;
1007                 UV temp_end = start + 1;
1008
1009                 /* Find the end of the sub-range that includes just the
1010                  * characters in the same class as the first character in it */
1011                 while (temp_end <= end && generic_isCC_A_(temp_end, mask)) {
1012                     temp_end++;
1013                 }
1014                 temp_end--;
1015
1016                 /* For short ranges, don't duplicate the code above to output
1017                  * them; just call recursively */
1018                 if (temp_end - start < min_range_count) {
1019                     put_range(sv, start, temp_end, FALSE);
1020                 }
1021                 else {  /* Output as a range */
1022                     put_code_point(sv, start);
1023                     sv_catpvs(sv, "-");
1024                     put_code_point(sv, temp_end);
1025                 }
1026                 start = temp_end + 1;
1027                 continue;
1028             }
1029
1030             /* We output any other printables as individual characters */
1031             if (isPUNCT_A(start) || isSPACE_A(start)) {
1032                 while (start <= end && (isPUNCT_A(start)
1033                                         || isSPACE_A(start)))
1034                 {
1035                     put_code_point(sv, start);
1036                     start++;
1037                 }
1038                 continue;
1039             }
1040         } /* End of looking for literals */
1041
1042         /* Here is not to output as a literal.  Some control characters have
1043          * mnemonic names.  Split off any of those at the beginning and end of
1044          * the range to print mnemonically.  It isn't possible for many of
1045          * these to be in a row, so this won't overwhelm with output */
1046         if (   start <= end
1047             && (isMNEMONIC_CNTRL(start) || isMNEMONIC_CNTRL(end)))
1048         {
1049             while (isMNEMONIC_CNTRL(start) && start <= end) {
1050                 put_code_point(sv, start);
1051                 start++;
1052             }
1053
1054             /* If this didn't take care of the whole range ... */
1055             if (start <= end) {
1056
1057                 /* Look backwards from the end to find the final non-mnemonic
1058                  * */
1059                 UV temp_end = end;
1060                 while (isMNEMONIC_CNTRL(temp_end)) {
1061                     temp_end--;
1062                 }
1063
1064                 /* And separately output the interior range that doesn't start
1065                  * or end with mnemonics */
1066                 put_range(sv, start, temp_end, FALSE);
1067
1068                 /* Then output the mnemonic trailing controls */
1069                 start = temp_end + 1;
1070                 while (start <= end) {
1071                     put_code_point(sv, start);
1072                     start++;
1073                 }
1074                 break;
1075             }
1076         }
1077
1078         /* As a final resort, output the range or subrange as hex. */
1079
1080         if (start >= NUM_ANYOF_CODE_POINTS) {
1081             this_end = end;
1082         }
1083         else {  /* Have to split range at the bitmap boundary */
1084             this_end = (end < NUM_ANYOF_CODE_POINTS)
1085                         ? end
1086                         : NUM_ANYOF_CODE_POINTS - 1;
1087         }
1088 #if NUM_ANYOF_CODE_POINTS > 256
1089         format = (this_end < 256)
1090                  ? "\\x%02" UVXf "-\\x%02" UVXf
1091                  : "\\x{%04" UVXf "}-\\x{%04" UVXf "}";
1092 #else
1093         format = "\\x%02" UVXf "-\\x%02" UVXf;
1094 #endif
1095         GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
1096         Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
1097         GCC_DIAG_RESTORE_STMT;
1098         break;
1099     }
1100 }
1101
1102 STATIC void
1103 S_put_charclass_bitmap_innards_invlist(pTHX_ SV *sv, SV* invlist)
1104 {
1105     /* Concatenate onto the PV in 'sv' a displayable form of the inversion list
1106      * 'invlist' */
1107
1108     UV start, end;
1109     bool allow_literals = TRUE;
1110
1111     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_INVLIST;
1112
1113     /* Generally, it is more readable if printable characters are output as
1114      * literals, but if a range (nearly) spans all of them, it's best to output
1115      * it as a single range.  This code will use a single range if all but 2
1116      * ASCII printables are in it */
1117     invlist_iterinit(invlist);
1118     while (invlist_iternext(invlist, &start, &end)) {
1119
1120         /* If the range starts beyond the final printable, it doesn't have any
1121          * in it */
1122         if (start > MAX_PRINT_A) {
1123             break;
1124         }
1125
1126         /* In both ASCII and EBCDIC, a SPACE is the lowest printable.  To span
1127          * all but two, the range must start and end no later than 2 from
1128          * either end */
1129         if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
1130             if (end > MAX_PRINT_A) {
1131                 end = MAX_PRINT_A;
1132             }
1133             if (start < ' ') {
1134                 start = ' ';
1135             }
1136             if (end - start >= MAX_PRINT_A - ' ' - 2) {
1137                 allow_literals = FALSE;
1138             }
1139             break;
1140         }
1141     }
1142     invlist_iterfinish(invlist);
1143
1144     /* Here we have figured things out.  Output each range */
1145     invlist_iterinit(invlist);
1146     while (invlist_iternext(invlist, &start, &end)) {
1147         if (start >= NUM_ANYOF_CODE_POINTS) {
1148             break;
1149         }
1150         put_range(sv, start, end, allow_literals);
1151     }
1152     invlist_iterfinish(invlist);
1153
1154     return;
1155 }
1156
1157 STATIC SV*
1158 S_put_charclass_bitmap_innards_common(pTHX_
1159         SV* invlist,            /* The bitmap */
1160         SV* posixes,            /* Under /l, things like [:word:], \S */
1161         SV* only_utf8,          /* Under /d, matches iff the target is UTF-8 */
1162         SV* not_utf8,           /* /d, matches iff the target isn't UTF-8 */
1163         SV* only_utf8_locale,   /* Under /l, matches if the locale is UTF-8 */
1164         const bool invert       /* Is the result to be inverted? */
1165 )
1166 {
1167     /* Create and return an SV containing a displayable version of the bitmap
1168      * and associated information determined by the input parameters.  If the
1169      * output would have been only the inversion indicator '^', NULL is instead
1170      * returned. */
1171
1172     SV * output;
1173
1174     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_COMMON;
1175
1176     if (invert) {
1177         output = newSVpvs("^");
1178     }
1179     else {
1180         output = newSVpvs("");
1181     }
1182
1183     /* First, the code points in the bitmap that are unconditionally there */
1184     put_charclass_bitmap_innards_invlist(output, invlist);
1185
1186     /* Traditionally, these have been placed after the main code points */
1187     if (posixes) {
1188         sv_catsv(output, posixes);
1189     }
1190
1191     if (only_utf8 && _invlist_len(only_utf8)) {
1192         Perl_sv_catpvf(aTHX_ output, "%s{utf8}%s", PL_colors[1], PL_colors[0]);
1193         put_charclass_bitmap_innards_invlist(output, only_utf8);
1194     }
1195
1196     if (not_utf8 && _invlist_len(not_utf8)) {
1197         Perl_sv_catpvf(aTHX_ output, "%s{not utf8}%s", PL_colors[1], PL_colors[0]);
1198         put_charclass_bitmap_innards_invlist(output, not_utf8);
1199     }
1200
1201     if (only_utf8_locale && _invlist_len(only_utf8_locale)) {
1202         Perl_sv_catpvf(aTHX_ output, "%s{utf8 locale}%s", PL_colors[1], PL_colors[0]);
1203         put_charclass_bitmap_innards_invlist(output, only_utf8_locale);
1204
1205         /* This is the only list in this routine that can legally contain code
1206          * points outside the bitmap range.  The call just above to
1207          * 'put_charclass_bitmap_innards_invlist' will simply suppress them, so
1208          * output them here.  There's about a half-dozen possible, and none in
1209          * contiguous ranges longer than 2 */
1210         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
1211             UV start, end;
1212             SV* above_bitmap = NULL;
1213
1214             _invlist_subtract(only_utf8_locale, PL_InBitmap, &above_bitmap);
1215
1216             invlist_iterinit(above_bitmap);
1217             while (invlist_iternext(above_bitmap, &start, &end)) {
1218                 UV i;
1219
1220                 for (i = start; i <= end; i++) {
1221                     put_code_point(output, i);
1222                 }
1223             }
1224             invlist_iterfinish(above_bitmap);
1225             SvREFCNT_dec_NN(above_bitmap);
1226         }
1227     }
1228
1229     if (invert && SvCUR(output) == 1) {
1230         return NULL;
1231     }
1232
1233     return output;
1234 }
1235
1236 STATIC U8
1237 S_put_charclass_bitmap_innards(pTHX_ SV *sv,
1238                                      char *bitmap,
1239                                      SV *nonbitmap_invlist,
1240                                      SV *only_utf8_locale_invlist,
1241                                      const regnode * const node,
1242                                      const U8 flags,
1243                                      const bool force_as_is_display)
1244 {
1245     /* Appends to 'sv' a displayable version of the innards of the bracketed
1246      * character class defined by the other arguments:
1247      *  'bitmap' points to the bitmap, or NULL if to ignore that.
1248      *  'nonbitmap_invlist' is an inversion list of the code points that are in
1249      *      the bitmap range, but for some reason aren't in the bitmap; NULL if
1250      *      none.  The reasons for this could be that they require some
1251      *      condition such as the target string being or not being in UTF-8
1252      *      (under /d), or because they came from a user-defined property that
1253      *      was not resolved at the time of the regex compilation (under /u)
1254      *  'only_utf8_locale_invlist' is an inversion list of the code points that
1255      *      are valid only if the runtime locale is a UTF-8 one; NULL if none
1256      *  'node' is the regex pattern ANYOF node.  It is needed only when the
1257      *      above two parameters are not null, and is passed so that this
1258      *      routine can tease apart the various reasons for them.
1259      *  'flags' is the flags field of 'node'
1260      *  'force_as_is_display' is TRUE if this routine should definitely NOT try
1261      *      to invert things to see if that leads to a cleaner display.  If
1262      *      FALSE, this routine is free to use its judgment about doing this.
1263      *
1264      * It returns 0 if nothing was actually output.  (It may be that
1265      *              the bitmap, etc is empty.)
1266      *            1 if the output wasn't inverted (didn't begin with a '^')
1267      *            2 if the output was inverted (did begin with a '^')
1268      *
1269      * When called for outputting the bitmap of a non-ANYOF node, just pass the
1270      * bitmap, with the succeeding parameters set to NULL, and the final one to
1271      * FALSE.
1272      */
1273
1274     /* In general, it tries to display the 'cleanest' representation of the
1275      * innards, choosing whether to display them inverted or not, regardless of
1276      * whether the class itself is to be inverted.  However,  there are some
1277      * cases where it can't try inverting, as what actually matches isn't known
1278      * until runtime, and hence the inversion isn't either. */
1279
1280     bool inverting_allowed = ! force_as_is_display;
1281
1282     int i;
1283     STRLEN orig_sv_cur = SvCUR(sv);
1284
1285     SV* invlist;            /* Inversion list we accumulate of code points that
1286                                are unconditionally matched */
1287     SV* only_utf8 = NULL;   /* Under /d, list of matches iff the target is
1288                                UTF-8 */
1289     SV* not_utf8 =  NULL;   /* /d, list of matches iff the target isn't UTF-8
1290                              */
1291     SV* posixes = NULL;     /* Under /l, string of things like [:word:], \D */
1292     SV* only_utf8_locale = NULL;    /* Under /l, list of matches if the locale
1293                                        is UTF-8 */
1294
1295     SV* as_is_display;      /* The output string when we take the inputs
1296                                literally */
1297     SV* inverted_display;   /* The output string when we invert the inputs */
1298
1299     bool invert = cBOOL(flags & ANYOF_INVERT);  /* Is the input to be inverted
1300                                                    to match? */
1301     /* We are biased in favor of displaying things without them being inverted,
1302      * as that is generally easier to understand */
1303     const int bias = 5;
1304
1305     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
1306
1307     /* Start off with whatever code points are passed in.  (We clone, so we
1308      * don't change the caller's list) */
1309     if (nonbitmap_invlist) {
1310         assert(invlist_highest(nonbitmap_invlist) < NUM_ANYOF_CODE_POINTS);
1311         invlist = invlist_clone(nonbitmap_invlist, NULL);
1312     }
1313     else {  /* Worst case size is every other code point is matched */
1314         invlist = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
1315     }
1316
1317     if (flags) {
1318         if (OP(node) == ANYOFD) {
1319
1320             /* This flag indicates that the code points below 0x100 in the
1321              * nonbitmap list are precisely the ones that match only when the
1322              * target is UTF-8 (they should all be non-ASCII). */
1323             if (flags & ANYOF_HAS_EXTRA_RUNTIME_MATCHES) {
1324                 _invlist_intersection(invlist, PL_UpperLatin1, &only_utf8);
1325                 _invlist_subtract(invlist, only_utf8, &invlist);
1326             }
1327
1328             /* And this flag for matching all non-ASCII 0xFF and below */
1329             if (flags & ANYOFD_NON_UTF8_MATCHES_ALL_NON_ASCII__shared) {
1330                 not_utf8 = invlist_clone(PL_UpperLatin1, NULL);
1331             }
1332         }
1333         else if (OP(node) == ANYOFL || OP(node) == ANYOFPOSIXL) {
1334
1335             /* If either of these flags are set, what matches isn't
1336              * determinable except during execution, so don't know enough here
1337              * to invert */
1338             if (flags & (ANYOFL_FOLD|ANYOF_MATCHES_POSIXL)) {
1339                 inverting_allowed = FALSE;
1340             }
1341
1342             /* What the posix classes match also varies at runtime, so these
1343              * will be output symbolically. */
1344             if (ANYOF_POSIXL_TEST_ANY_SET(node)) {
1345                 int i;
1346
1347                 posixes = newSVpvs("");
1348                 for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
1349                     if (ANYOF_POSIXL_TEST(node, i)) {
1350                         sv_catpv(posixes, anyofs[i]);
1351                     }
1352                 }
1353             }
1354         }
1355     }
1356
1357     /* Accumulate the bit map into the unconditional match list */
1358     if (bitmap) {
1359         for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
1360             if (BITMAP_TEST(bitmap, i)) {
1361                 int start = i++;
1362                 for (;
1363                      i < NUM_ANYOF_CODE_POINTS && BITMAP_TEST(bitmap, i);
1364                      i++)
1365                 { /* empty */ }
1366                 invlist = _add_range_to_invlist(invlist, start, i-1);
1367             }
1368         }
1369     }
1370
1371     /* Make sure that the conditional match lists don't have anything in them
1372      * that match unconditionally; otherwise the output is quite confusing.
1373      * This could happen if the code that populates these misses some
1374      * duplication. */
1375     if (only_utf8) {
1376         _invlist_subtract(only_utf8, invlist, &only_utf8);
1377     }
1378     if (not_utf8) {
1379         _invlist_subtract(not_utf8, invlist, &not_utf8);
1380     }
1381
1382     if (only_utf8_locale_invlist) {
1383
1384         /* Since this list is passed in, we have to make a copy before
1385          * modifying it */
1386         only_utf8_locale = invlist_clone(only_utf8_locale_invlist, NULL);
1387
1388         _invlist_subtract(only_utf8_locale, invlist, &only_utf8_locale);
1389
1390         /* And, it can get really weird for us to try outputting an inverted
1391          * form of this list when it has things above the bitmap, so don't even
1392          * try */
1393         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
1394             inverting_allowed = FALSE;
1395         }
1396     }
1397
1398     /* Calculate what the output would be if we take the input as-is */
1399     as_is_display = put_charclass_bitmap_innards_common(invlist,
1400                                                     posixes,
1401                                                     only_utf8,
1402                                                     not_utf8,
1403                                                     only_utf8_locale,
1404                                                     invert);
1405
1406     /* If have to take the output as-is, just do that */
1407     if (! inverting_allowed) {
1408         if (as_is_display) {
1409             sv_catsv(sv, as_is_display);
1410             SvREFCNT_dec_NN(as_is_display);
1411         }
1412     }
1413     else { /* But otherwise, create the output again on the inverted input, and
1414               use whichever version is shorter */
1415
1416         int inverted_bias, as_is_bias;
1417
1418         /* We will apply our bias to whichever of the results doesn't have
1419          * the '^' */
1420         bool trial_invert;
1421         if (invert) {
1422             trial_invert = FALSE;
1423             as_is_bias = bias;
1424             inverted_bias = 0;
1425         }
1426         else {
1427             trial_invert = TRUE;
1428             as_is_bias = 0;
1429             inverted_bias = bias;
1430         }
1431
1432         /* Now invert each of the lists that contribute to the output,
1433          * excluding from the result things outside the possible range */
1434
1435         /* For the unconditional inversion list, we have to add in all the
1436          * conditional code points, so that when inverted, they will be gone
1437          * from it */
1438         _invlist_union(only_utf8, invlist, &invlist);
1439         _invlist_union(not_utf8, invlist, &invlist);
1440         _invlist_union(only_utf8_locale, invlist, &invlist);
1441         _invlist_invert(invlist);
1442         _invlist_intersection(invlist, PL_InBitmap, &invlist);
1443
1444         if (only_utf8) {
1445             _invlist_invert(only_utf8);
1446             _invlist_intersection(only_utf8, PL_UpperLatin1, &only_utf8);
1447         }
1448         else if (not_utf8) {
1449
1450             /* If a code point matches iff the target string is not in UTF-8,
1451              * then complementing the result has it not match iff not in UTF-8,
1452              * which is the same thing as matching iff it is UTF-8. */
1453             only_utf8 = not_utf8;
1454             not_utf8 = NULL;
1455         }
1456
1457         if (only_utf8_locale) {
1458             _invlist_invert(only_utf8_locale);
1459             _invlist_intersection(only_utf8_locale,
1460                                   PL_InBitmap,
1461                                   &only_utf8_locale);
1462         }
1463
1464         inverted_display = put_charclass_bitmap_innards_common(
1465                                             invlist,
1466                                             posixes,
1467                                             only_utf8,
1468                                             not_utf8,
1469                                             only_utf8_locale, trial_invert);
1470
1471         /* Use the shortest representation, taking into account our bias
1472          * against showing it inverted */
1473         if (   inverted_display
1474             && (   ! as_is_display
1475                 || (  SvCUR(inverted_display) + inverted_bias
1476                     < SvCUR(as_is_display)    + as_is_bias)))
1477         {
1478             sv_catsv(sv, inverted_display);
1479             invert = ! invert;
1480         }
1481         else if (as_is_display) {
1482             sv_catsv(sv, as_is_display);
1483         }
1484
1485         SvREFCNT_dec(as_is_display);
1486         SvREFCNT_dec(inverted_display);
1487     }
1488
1489     SvREFCNT_dec_NN(invlist);
1490     SvREFCNT_dec(only_utf8);
1491     SvREFCNT_dec(not_utf8);
1492     SvREFCNT_dec(posixes);
1493     SvREFCNT_dec(only_utf8_locale);
1494
1495     U8 did_output_something = (bool) (SvCUR(sv) > orig_sv_cur);
1496     if (did_output_something) {
1497         /* Distinguish between non and inverted cases */
1498         did_output_something += invert;
1499     }
1500
1501     return did_output_something;
1502 }
1503
1504
1505 const regnode *
1506 Perl_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
1507             const regnode *last, const regnode *plast,
1508             SV* sv, I32 indent, U32 depth)
1509 {
1510     const regnode *next;
1511     const regnode *optstart= NULL;
1512
1513     RXi_GET_DECL(r, ri);
1514     DECLARE_AND_GET_RE_DEBUG_FLAGS;
1515
1516     PERL_ARGS_ASSERT_DUMPUNTIL;
1517
1518 #ifdef DEBUG_DUMPUNTIL
1519     Perl_re_printf( aTHX_  "--- %d : %d - %d - %d\n", indent, node-start,
1520         last ? last-start : 0, plast ? plast-start : 0);
1521 #endif
1522
1523     if (plast && plast < last)
1524         last= plast;
1525
1526     while (node && (!last || node < last)) {
1527         const U8 op = OP(node);
1528
1529         if (op == CLOSE || op == SRCLOSE || op == WHILEM)
1530             indent--;
1531         next = regnext((regnode *)node);
1532         const regnode *after = regnode_after((regnode *)node,0);
1533
1534         /* Where, what. */
1535         if (op == OPTIMIZED) {
1536             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
1537                 optstart = node;
1538             else
1539                 goto after_print;
1540         } else
1541             CLEAR_OPTSTART;
1542
1543         regprop(r, sv, node, NULL, NULL);
1544         Perl_re_printf( aTHX_  "%4" IVdf ":%*s%s", (IV)(node - start),
1545                       (int)(2*indent + 1), "", SvPVX_const(sv));
1546
1547         if (op != OPTIMIZED) {
1548             if (next == NULL)           /* Next ptr. */
1549                 Perl_re_printf( aTHX_  " (0)");
1550             else if (REGNODE_TYPE(op) == BRANCH
1551                      && REGNODE_TYPE(OP(next)) != BRANCH )
1552                 Perl_re_printf( aTHX_  " (FAIL)");
1553             else
1554                 Perl_re_printf( aTHX_  " (%" IVdf ")", (IV)(next - start));
1555             Perl_re_printf( aTHX_ "\n");
1556         }
1557
1558       after_print:
1559         if (REGNODE_TYPE(op) == BRANCHJ) {
1560             assert(next);
1561             const regnode *nnode = (OP(next) == LONGJMP
1562                                    ? regnext((regnode *)next)
1563                                    : next);
1564             if (last && nnode > last)
1565                 nnode = last;
1566             DUMPUNTIL(after, nnode);
1567         }
1568         else if (REGNODE_TYPE(op) == BRANCH) {
1569             assert(next);
1570             DUMPUNTIL(after, next);
1571         }
1572         else if ( REGNODE_TYPE(op)  == TRIE ) {
1573             const regnode *this_trie = node;
1574             const U32 n = ARG(node);
1575             const reg_ac_data * const ac = op>=AHOCORASICK ?
1576                (reg_ac_data *)ri->data->data[n] :
1577                NULL;
1578             const reg_trie_data * const trie =
1579                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
1580 #ifdef DEBUGGING
1581             AV *const trie_words
1582                            = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
1583 #endif
1584             const regnode *nextbranch= NULL;
1585             I32 word_idx;
1586             SvPVCLEAR(sv);
1587             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
1588                 SV ** const elem_ptr = av_fetch_simple(trie_words, word_idx, 0);
1589
1590                 Perl_re_indentf( aTHX_  "%s ",
1591                     indent+3,
1592                     elem_ptr
1593                     ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
1594                                 SvCUR(*elem_ptr), PL_dump_re_max_len,
1595                                 PL_colors[0], PL_colors[1],
1596                                 (SvUTF8(*elem_ptr)
1597                                  ? PERL_PV_ESCAPE_UNI
1598                                  : 0)
1599                                 | PERL_PV_PRETTY_ELLIPSES
1600                                 | PERL_PV_PRETTY_LTGT
1601                             )
1602                     : "???"
1603                 );
1604                 if (trie->jump) {
1605                     U16 dist= trie->jump[word_idx+1];
1606                     Perl_re_printf( aTHX_  "(%" UVuf ")\n",
1607                                (UV)((dist ? this_trie + dist : next) - start));
1608                     if (dist) {
1609                         if (!nextbranch)
1610                             nextbranch= this_trie + trie->jump[0];
1611                         DUMPUNTIL(this_trie + dist, nextbranch);
1612                     }
1613                     if (nextbranch && REGNODE_TYPE(OP(nextbranch))==BRANCH)
1614                         nextbranch= regnext((regnode *)nextbranch);
1615                 } else {
1616                     Perl_re_printf( aTHX_  "\n");
1617                 }
1618             }
1619             if (last && next > last)
1620                 node= last;
1621             else
1622                 node= next;
1623         }
1624         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
1625             DUMPUNTIL(after, after + 1); /* +1 is NOT a REGNODE_AFTER */
1626         }
1627         else if (REGNODE_TYPE(op) == CURLY && op != CURLYX) {
1628             assert(next);
1629             DUMPUNTIL(after, next);
1630         }
1631         else if ( op == PLUS || op == STAR) {
1632             DUMPUNTIL(after, after + 1); /* +1 NOT a REGNODE_AFTER */
1633         }
1634         else if (REGNODE_TYPE(op) == EXACT || op == ANYOFHs) {
1635             /* Literal string, where present. */
1636             node = (const regnode *)REGNODE_AFTER_varies(node);
1637         }
1638         else {
1639             node = REGNODE_AFTER_opcode(node,op);
1640         }
1641         if (op == CURLYX || op == OPEN || op == SROPEN)
1642             indent++;
1643         if (REGNODE_TYPE(op) == END)
1644             break;
1645     }
1646     CLEAR_OPTSTART;
1647 #ifdef DEBUG_DUMPUNTIL
1648     Perl_re_printf( aTHX_  "--- %d\n", (int)indent);
1649 #endif
1650     return node;
1651 }
1652
1653 #endif  /* DEBUGGING */