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