regexec.c

   1 /*    regexec.c
   2  */
   3
   4 /*
   5  * "One Ring to rule them all, One Ring to find them..."
   6  */
   7
   8 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
   9  * confused with the original package (see point 3 below).  Thanks, Henry!
  10  */
  11
  12 /* Additional note: this code is very heavily munged from Henry's version
  13  * in places.  In some spots I've traded clarity for efficiency, so don't
  14  * blame Henry for some of the lack of readability.
  15  */
  16
  17 /* The names of the functions have been changed from regcomp and
  18  * regexec to  pregcomp and pregexec in order to avoid conflicts
  19  * with the POSIX routines of the same names.
  20 */
  21
  22 #ifdef PERL_EXT_RE_BUILD
  23 /* need to replace pregcomp et al, so enable that */
  24 #  ifndef PERL_IN_XSUB_RE
  25 #    define PERL_IN_XSUB_RE
  26 #  endif
  27 /* need access to debugger hooks */
  28 #  if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
  29 #    define DEBUGGING
  30 #  endif
  31 #endif
  32
  33 #ifdef PERL_IN_XSUB_RE
  34 /* We *really* need to overwrite these symbols: */
  35 #  define Perl_regexec_flags my_regexec
  36 #  define Perl_regdump my_regdump
  37 #  define Perl_regprop my_regprop
  38 #  define Perl_re_intuit_start my_re_intuit_start
  39 /* *These* symbols are masked to allow static link. */
  40 #  define Perl_pregexec my_pregexec
  41 #  define Perl_reginitcolors my_reginitcolors
  42 #  define Perl_regclass_swash my_regclass_swash
  43
  44 #  define PERL_NO_GET_CONTEXT
  45 #endif
  46
  47 /*SUPPRESS 112*/
  48 /*
  49  * pregcomp and pregexec -- regsub and regerror are not used in perl
  50  *
  51  *      Copyright (c) 1986 by University of Toronto.
  52  *      Written by Henry Spencer.  Not derived from licensed software.
  53  *
  54  *      Permission is granted to anyone to use this software for any
  55  *      purpose on any computer system, and to redistribute it freely,
  56  *      subject to the following restrictions:
  57  *
  58  *      1. The author is not responsible for the consequences of use of
  59  *              this software, no matter how awful, even if they arise
  60  *              from defects in it.
  61  *
  62  *      2. The origin of this software must not be misrepresented, either
  63  *              by explicit claim or by omission.
  64  *
  65  *      3. Altered versions must be plainly marked as such, and must not
  66  *              be misrepresented as being the original software.
  67  *
  68  ****    Alterations to Henry's code are...
  69  ****
  70  ****    Copyright (c) 1991-2001, Larry Wall
  71  ****
  72  ****    You may distribute under the terms of either the GNU General Public
  73  ****    License or the Artistic License, as specified in the README file.
  74  *
  75  * Beware that some of this code is subtly aware of the way operator
  76  * precedence is structured in regular expressions.  Serious changes in
  77  * regular-expression syntax might require a total rethink.
  78  */
  79 #include "EXTERN.h"
  80 #define PERL_IN_REGEXEC_C
  81 #include "perl.h"
  82
  83 #include "regcomp.h"
  84
  85 #define RF_tainted      1               /* tainted information used? */
  86 #define RF_warned       2               /* warned about big count? */
  87 #define RF_evaled       4               /* Did an EVAL with setting? */
  88 #define RF_utf8         8               /* String contains multibyte chars? */
  89
  90 #define UTF (PL_reg_flags & RF_utf8)
  91
  92 #define RS_init         1               /* eval environment created */
  93 #define RS_set          2               /* replsv value is set */
  94
  95 #ifndef STATIC
  96 #define STATIC  static
  97 #endif
  98
  99 /*
 100  * Forwards.
 101  */
 102
 103 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
 104 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
 105
 106 #define reghop_c(pos,off) ((char*)reghop((U8*)pos, off))
 107 #define reghopmaybe_c(pos,off) ((char*)reghopmaybe((U8*)pos, off))
 108 #define HOP(pos,off) (PL_reg_match_utf8 ? reghop((U8*)pos, off) : (U8*)(pos + off))
 109 #define HOPMAYBE(pos,off) (PL_reg_match_utf8 ? reghopmaybe((U8*)pos, off) : (U8*)(pos + off))
 110 #define HOPc(pos,off) ((char*)HOP(pos,off))
 111 #define HOPMAYBEc(pos,off) ((char*)HOPMAYBE(pos,off))
 112
 113 #define HOPBACK(pos, off) (             \
 114     (UTF && PL_reg_match_utf8)          \
 115         ? reghopmaybe((U8*)pos, -off)   \
 116     : (pos - off >= PL_bostr)           \
 117         ? (U8*)(pos - off)              \
 118     : (U8*)NULL                         \
 119 )
 120 #define HOPBACKc(pos, off) (char*)HOPBACK(pos, off)
 121
 122 #define reghop3_c(pos,off,lim) ((char*)reghop3((U8*)pos, off, (U8*)lim))
 123 #define reghopmaybe3_c(pos,off,lim) ((char*)reghopmaybe3((U8*)pos, off, (U8*)lim))
 124 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
 125 #define HOPMAYBE3(pos,off,lim) (PL_reg_match_utf8 ? reghopmaybe3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
 126 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
 127 #define HOPMAYBE3c(pos,off,lim) ((char*)HOPMAYBE3(pos,off,lim))
 128
 129 #define LOAD_UTF8_CHARCLASS(a,b) STMT_START { if (!CAT2(PL_utf8_,a)) (void)CAT2(is_utf8_, a)((U8*)b); } STMT_END
 130
 131 /* for use after a quantifier and before an EXACT-like node -- japhy */
 132 #define JUMPABLE(rn) ( \
 133     OP(rn) == OPEN || OP(rn) == CLOSE || OP(rn) == EVAL || \
 134     OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
 135     OP(rn) == PLUS || OP(rn) == MINMOD || \
 136     (PL_regkind[(U8)OP(rn)] == CURLY && ARG1(rn) > 0) \
 137 )
 138
 139 #define HAS_TEXT(rn) ( \
 140     PL_regkind[(U8)OP(rn)] == EXACT || PL_regkind[(U8)OP(rn)] == REF \
 141 )
 142
 143 #define FIND_NEXT_IMPT(rn) STMT_START { \
 144     while (JUMPABLE(rn)) \
 145         if (OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
 146             PL_regkind[(U8)OP(rn)] == CURLY) \
 147             rn = NEXTOPER(NEXTOPER(rn)); \
 148         else if (OP(rn) == PLUS) \
 149             rn = NEXTOPER(rn); \
 150         else rn += NEXT_OFF(rn); \
 151 } STMT_END
 152
 153 static void restore_pos(pTHX_ void *arg);
 154
 155 STATIC CHECKPOINT
 156 S_regcppush(pTHX_ I32 parenfloor)
 157 {
 158     int retval = PL_savestack_ix;
 159 #define REGCP_PAREN_ELEMS 4
 160     int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
 161     int p;
 162
 163     if (paren_elems_to_push < 0)
 164         Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
 165
 166 #define REGCP_OTHER_ELEMS 6
 167     SSCHECK(paren_elems_to_push + REGCP_OTHER_ELEMS);
 168     for (p = PL_regsize; p > parenfloor; p--) {
 169 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
 170         SSPUSHINT(PL_regendp[p]);
 171         SSPUSHINT(PL_regstartp[p]);
 172         SSPUSHPTR(PL_reg_start_tmp[p]);
 173         SSPUSHINT(p);
 174     }
 175 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
 176     SSPUSHINT(PL_regsize);
 177     SSPUSHINT(*PL_reglastparen);
 178     SSPUSHINT(*PL_reglastcloseparen);
 179     SSPUSHPTR(PL_reginput);
 180 #define REGCP_FRAME_ELEMS 2
 181 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
 182  * are needed for the regexp context stack bookkeeping. */
 183     SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
 184     SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
 185
 186     return retval;
 187 }
 188
 189 /* These are needed since we do not localize EVAL nodes: */
 190 #  define REGCP_SET(cp)  DEBUG_r(PerlIO_printf(Perl_debug_log,          \
 191                              "  Setting an EVAL scope, savestack=%"IVdf"\n",    \
 192                              (IV)PL_savestack_ix)); cp = PL_savestack_ix
 193
 194 #  define REGCP_UNWIND(cp)  DEBUG_r(cp != PL_savestack_ix ?             \
 195                                 PerlIO_printf(Perl_debug_log,           \
 196                                 "  Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
 197                                 (IV)(cp), (IV)PL_savestack_ix) : 0); regcpblow(cp)
 198
 199 STATIC char *
 200 S_regcppop(pTHX)
 201 {
 202     I32 i;
 203     U32 paren = 0;
 204     char *input;
 205     I32 tmps;
 206
 207     /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
 208     i = SSPOPINT;
 209     assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
 210     i = SSPOPINT; /* Parentheses elements to pop. */
 211     input = (char *) SSPOPPTR;
 212     *PL_reglastcloseparen = SSPOPINT;
 213     *PL_reglastparen = SSPOPINT;
 214     PL_regsize = SSPOPINT;
 215
 216     /* Now restore the parentheses context. */
 217     for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
 218          i > 0; i -= REGCP_PAREN_ELEMS) {
 219         paren = (U32)SSPOPINT;
 220         PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
 221         PL_regstartp[paren] = SSPOPINT;
 222         tmps = SSPOPINT;
 223         if (paren <= *PL_reglastparen)
 224             PL_regendp[paren] = tmps;
 225         DEBUG_r(
 226             PerlIO_printf(Perl_debug_log,
 227                           "     restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
 228                           (UV)paren, (IV)PL_regstartp[paren],
 229                           (IV)(PL_reg_start_tmp[paren] - PL_bostr),
 230                           (IV)PL_regendp[paren],
 231                           (paren > *PL_reglastparen ? "(no)" : ""));
 232         );
 233     }
 234     DEBUG_r(
 235         if (*PL_reglastparen + 1 <= PL_regnpar) {
 236             PerlIO_printf(Perl_debug_log,
 237                           "     restoring \\%"IVdf"..\\%"IVdf" to undef\n",
 238                           (IV)(*PL_reglastparen + 1), (IV)PL_regnpar);
 239         }
 240     );
 241 #if 1
 242     /* It would seem that the similar code in regtry()
 243      * already takes care of this, and in fact it is in
 244      * a better location to since this code can #if 0-ed out
 245      * but the code in regtry() is needed or otherwise tests
 246      * requiring null fields (pat.t#187 and split.t#{13,14}
 247      * (as of patchlevel 7877)  will fail.  Then again,
 248      * this code seems to be necessary or otherwise
 249      * building DynaLoader will fail:
 250      * "Error: '*' not in typemap in DynaLoader.xs, line 164"
 251      * --jhi */
 252     for (paren = *PL_reglastparen + 1; paren <= PL_regnpar; paren++) {
 253         if (paren > PL_regsize)
 254             PL_regstartp[paren] = -1;
 255         PL_regendp[paren] = -1;
 256     }
 257 #endif
 258     return input;
 259 }
 260
 261 STATIC char *
 262 S_regcp_set_to(pTHX_ I32 ss)
 263 {
 264     I32 tmp = PL_savestack_ix;
 265
 266     PL_savestack_ix = ss;
 267     regcppop();
 268     PL_savestack_ix = tmp;
 269     return Nullch;
 270 }
 271
 272 typedef struct re_cc_state
 273 {
 274     I32 ss;
 275     regnode *node;
 276     struct re_cc_state *prev;
 277     CURCUR *cc;
 278     regexp *re;
 279 } re_cc_state;
 280
 281 #define regcpblow(cp) LEAVE_SCOPE(cp)   /* Ignores regcppush()ed data. */
 282
 283 #define TRYPAREN(paren, n, input) {                             \
 284     if (paren) {                                                \
 285         if (n) {                                                \
 286             PL_regstartp[paren] = HOPc(input, -1) - PL_bostr;   \
 287             PL_regendp[paren] = input - PL_bostr;               \
 288         }                                                       \
 289         else                                                    \
 290             PL_regendp[paren] = -1;                             \
 291     }                                                           \
 292     if (regmatch(next))                                         \
 293         sayYES;                                                 \
 294     if (paren && n)                                             \
 295         PL_regendp[paren] = -1;                                 \
 296 }
 297
 298
 299 /*
 300  * pregexec and friends
 301  */
 302
 303 /*
 304  - pregexec - match a regexp against a string
 305  */
 306 I32
 307 Perl_pregexec(pTHX_ register regexp *prog, char *stringarg, register char *strend,
 308          char *strbeg, I32 minend, SV *screamer, U32 nosave)
 309 /* strend: pointer to null at end of string */
 310 /* strbeg: real beginning of string */
 311 /* minend: end of match must be >=minend after stringarg. */
 312 /* nosave: For optimizations. */
 313 {
 314     return
 315         regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
 316                       nosave ? 0 : REXEC_COPY_STR);
 317 }
 318
 319 STATIC void
 320 S_cache_re(pTHX_ regexp *prog)
 321 {
 322     PL_regprecomp = prog->precomp;              /* Needed for FAIL. */
 323 #ifdef DEBUGGING
 324     PL_regprogram = prog->program;
 325 #endif
 326     PL_regnpar = prog->nparens;
 327     PL_regdata = prog->data;
 328     PL_reg_re = prog;
 329 }
 330
 331 /*
 332  * Need to implement the following flags for reg_anch:
 333  *
 334  * USE_INTUIT_NOML              - Useful to call re_intuit_start() first
 335  * USE_INTUIT_ML
 336  * INTUIT_AUTORITATIVE_NOML     - Can trust a positive answer
 337  * INTUIT_AUTORITATIVE_ML
 338  * INTUIT_ONCE_NOML             - Intuit can match in one location only.
 339  * INTUIT_ONCE_ML
 340  *
 341  * Another flag for this function: SECOND_TIME (so that float substrs
 342  * with giant delta may be not rechecked).
 343  */
 344
 345 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
 346
 347 /* If SCREAM, then SvPVX(sv) should be compatible with strpos and strend.
 348    Otherwise, only SvCUR(sv) is used to get strbeg. */
 349
 350 /* XXXX We assume that strpos is strbeg unless sv. */
 351
 352 /* XXXX Some places assume that there is a fixed substring.
 353         An update may be needed if optimizer marks as "INTUITable"
 354         RExen without fixed substrings.  Similarly, it is assumed that
 355         lengths of all the strings are no more than minlen, thus they
 356         cannot come from lookahead.
 357         (Or minlen should take into account lookahead.) */
 358
 359 /* A failure to find a constant substring means that there is no need to make
 360    an expensive call to REx engine, thus we celebrate a failure.  Similarly,
 361    finding a substring too deep into the string means that less calls to
 362    regtry() should be needed.
 363
 364    REx compiler's optimizer found 4 possible hints:
 365         a) Anchored substring;
 366         b) Fixed substring;
 367         c) Whether we are anchored (beginning-of-line or \G);
 368         d) First node (of those at offset 0) which may distingush positions;
 369    We use a)b)d) and multiline-part of c), and try to find a position in the
 370    string which does not contradict any of them.
 371  */
 372
 373 /* Most of decisions we do here should have been done at compile time.
 374    The nodes of the REx which we used for the search should have been
 375    deleted from the finite automaton. */
 376
 377 char *
 378 Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
 379                      char *strend, U32 flags, re_scream_pos_data *data)
 380 {
 381     register I32 start_shift = 0;
 382     /* Should be nonnegative! */
 383     register I32 end_shift   = 0;
 384     register char *s;
 385     register SV *check;
 386     char *strbeg;
 387     char *t;
 388     I32 ml_anch;
 389     register char *other_last = Nullch; /* other substr checked before this */
 390     char *check_at = Nullch;            /* check substr found at this pos */
 391 #ifdef DEBUGGING
 392     char *i_strpos = strpos;
 393     SV *dsv = PERL_DEBUG_PAD_ZERO(0);
 394 #endif
 395
 396     if (prog->reganch & ROPT_UTF8) {
 397         DEBUG_r(PerlIO_printf(Perl_debug_log,
 398                               "UTF-8 regex...\n"));
 399         PL_reg_flags |= RF_utf8;
 400     }
 401
 402     DEBUG_r({
 403          char *s   = PL_reg_match_utf8 ?
 404                          sv_uni_display(dsv, sv, 60, 0) : strpos;
 405          int   len = PL_reg_match_utf8 ?
 406                          strlen(s) : strend - strpos;
 407          if (!PL_colorset)
 408               reginitcolors();
 409          if (PL_reg_match_utf8)
 410              DEBUG_r(PerlIO_printf(Perl_debug_log,
 411                                    "UTF-8 target...\n"));
 412          PerlIO_printf(Perl_debug_log,
 413                        "%sGuessing start of match, REx%s `%s%.60s%s%s' against `%s%.*s%s%s'...\n",
 414                        PL_colors[4],PL_colors[5],PL_colors[0],
 415                        prog->precomp,
 416                        PL_colors[1],
 417                        (strlen(prog->precomp) > 60 ? "..." : ""),
 418                        PL_colors[0],
 419                        (int)(len > 60 ? 60 : len),
 420                        s, PL_colors[1],
 421                        (len > 60 ? "..." : "")
 422               );
 423     });
 424
 425     if (prog->minlen > CHR_DIST((U8*)strend, (U8*)strpos)) {
 426         DEBUG_r(PerlIO_printf(Perl_debug_log,
 427                               "String too short... [re_intuit_start]\n"));
 428         goto fail;
 429     }
 430     strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
 431     PL_regeol = strend;
 432     check = prog->check_substr;
 433     if (prog->reganch & ROPT_ANCH) {    /* Match at beg-of-str or after \n */
 434         ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
 435                      || ( (prog->reganch & ROPT_ANCH_BOL)
 436                           && !PL_multiline ) ); /* Check after \n? */
 437
 438         if (!ml_anch) {
 439           if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */
 440                                   | ROPT_IMPLICIT)) /* not a real BOL */
 441                /* SvCUR is not set on references: SvRV and SvPVX overlap */
 442                && sv && !SvROK(sv)
 443                && (strpos != strbeg)) {
 444               DEBUG_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
 445               goto fail;
 446           }
 447           if (prog->check_offset_min == prog->check_offset_max &&
 448               !(prog->reganch & ROPT_CANY_SEEN)) {
 449             /* Substring at constant offset from beg-of-str... */
 450             I32 slen;
 451
 452             s = HOP3c(strpos, prog->check_offset_min, strend);
 453             if (SvTAIL(check)) {
 454                 slen = SvCUR(check);    /* >= 1 */
 455
 456                 if ( strend - s > slen || strend - s < slen - 1
 457                      || (strend - s == slen && strend[-1] != '\n')) {
 458                     DEBUG_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
 459                     goto fail_finish;
 460                 }
 461                 /* Now should match s[0..slen-2] */
 462                 slen--;
 463                 if (slen && (*SvPVX(check) != *s
 464                              || (slen > 1
 465                                  && memNE(SvPVX(check), s, slen)))) {
 466                   report_neq:
 467                     DEBUG_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
 468                     goto fail_finish;
 469                 }
 470             }
 471             else if (*SvPVX(check) != *s
 472                      || ((slen = SvCUR(check)) > 1
 473                          && memNE(SvPVX(check), s, slen)))
 474                 goto report_neq;
 475             goto success_at_start;
 476           }
 477         }
 478         /* Match is anchored, but substr is not anchored wrt beg-of-str. */
 479         s = strpos;
 480         start_shift = prog->check_offset_min; /* okay to underestimate on CC */
 481         end_shift = prog->minlen - start_shift -
 482             CHR_SVLEN(check) + (SvTAIL(check) != 0);
 483         if (!ml_anch) {
 484             I32 end = prog->check_offset_max + CHR_SVLEN(check)
 485                                          - (SvTAIL(check) != 0);
 486             I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
 487
 488             if (end_shift < eshift)
 489                 end_shift = eshift;
 490         }
 491     }
 492     else {                              /* Can match at random position */
 493         ml_anch = 0;
 494         s = strpos;
 495         start_shift = prog->check_offset_min; /* okay to underestimate on CC */
 496         /* Should be nonnegative! */
 497         end_shift = prog->minlen - start_shift -
 498             CHR_SVLEN(check) + (SvTAIL(check) != 0);
 499     }
 500
 501 #ifdef DEBUGGING        /* 7/99: reports of failure (with the older version) */
 502     if (end_shift < 0)
 503         Perl_croak(aTHX_ "panic: end_shift");
 504 #endif
 505
 506   restart:
 507     /* Find a possible match in the region s..strend by looking for
 508        the "check" substring in the region corrected by start/end_shift. */
 509     if (flags & REXEC_SCREAM) {
 510         I32 p = -1;                     /* Internal iterator of scream. */
 511         I32 *pp = data ? data->scream_pos : &p;
 512
 513         if (PL_screamfirst[BmRARE(check)] >= 0
 514             || ( BmRARE(check) == '\n'
 515                  && (BmPREVIOUS(check) == SvCUR(check) - 1)
 516                  && SvTAIL(check) ))
 517             s = screaminstr(sv, check,
 518                             start_shift + (s - strbeg), end_shift, pp, 0);
 519         else
 520             goto fail_finish;
 521         if (data)
 522             *data->scream_olds = s;
 523     }
 524     else if (prog->reganch & ROPT_CANY_SEEN)
 525         s = fbm_instr((U8*)(s + start_shift),
 526                       (U8*)(strend - end_shift),
 527                       check, PL_multiline ? FBMrf_MULTILINE : 0);
 528     else
 529         s = fbm_instr(HOP3(s, start_shift, strend),
 530                       HOP3(strend, -end_shift, strbeg),
 531                       check, PL_multiline ? FBMrf_MULTILINE : 0);
 532
 533     /* Update the count-of-usability, remove useless subpatterns,
 534         unshift s.  */
 535
 536     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s %s substr `%s%.*s%s'%s%s",
 537                           (s ? "Found" : "Did not find"),
 538                           ((check == prog->anchored_substr) ? "anchored" : "floating"),
 539                           PL_colors[0],
 540                           (int)(SvCUR(check) - (SvTAIL(check)!=0)),
 541                           SvPVX(check),
 542                           PL_colors[1], (SvTAIL(check) ? "$" : ""),
 543                           (s ? " at offset " : "...\n") ) );
 544
 545     if (!s)
 546         goto fail_finish;
 547
 548     check_at = s;
 549
 550     /* Finish the diagnostic message */
 551     DEBUG_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
 552
 553     /* Got a candidate.  Check MBOL anchoring, and the *other* substr.
 554        Start with the other substr.
 555        XXXX no SCREAM optimization yet - and a very coarse implementation
 556        XXXX /ttx+/ results in anchored=`ttx', floating=`x'.  floating will
 557                 *always* match.  Probably should be marked during compile...
 558        Probably it is right to do no SCREAM here...
 559      */
 560
 561     if (prog->float_substr && prog->anchored_substr) {
 562         /* Take into account the "other" substring. */
 563         /* XXXX May be hopelessly wrong for UTF... */
 564         if (!other_last)
 565             other_last = strpos;
 566         if (check == prog->float_substr) {
 567           do_other_anchored:
 568             {
 569                 char *last = HOP3c(s, -start_shift, strbeg), *last1, *last2;
 570                 char *s1 = s;
 571
 572                 t = s - prog->check_offset_max;
 573                 if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 574                     && (!(prog->reganch & ROPT_UTF8)
 575                         || ((t = reghopmaybe3_c(s, -(prog->check_offset_max), strpos))
 576                             && t > strpos)))
 577                     /* EMPTY */;
 578                 else
 579                     t = strpos;
 580                 t = HOP3c(t, prog->anchored_offset, strend);
 581                 if (t < other_last)     /* These positions already checked */
 582                     t = other_last;
 583                 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
 584                 if (last < last1)
 585                     last1 = last;
 586  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
 587                 /* On end-of-str: see comment below. */
 588                 s = fbm_instr((unsigned char*)t,
 589                               HOP3(HOP3(last1, prog->anchored_offset, strend)
 590                                    + SvCUR(prog->anchored_substr),
 591                                    -(SvTAIL(prog->anchored_substr)!=0), strbeg),
 592                               prog->anchored_substr,
 593                               PL_multiline ? FBMrf_MULTILINE : 0);
 594                 DEBUG_r(PerlIO_printf(Perl_debug_log,
 595                         "%s anchored substr `%s%.*s%s'%s",
 596                         (s ? "Found" : "Contradicts"),
 597                         PL_colors[0],
 598                           (int)(SvCUR(prog->anchored_substr)
 599                           - (SvTAIL(prog->anchored_substr)!=0)),
 600                           SvPVX(prog->anchored_substr),
 601                           PL_colors[1], (SvTAIL(prog->anchored_substr) ? "$" : "")));
 602                 if (!s) {
 603                     if (last1 >= last2) {
 604                         DEBUG_r(PerlIO_printf(Perl_debug_log,
 605                                                 ", giving up...\n"));
 606                         goto fail_finish;
 607                     }
 608                     DEBUG_r(PerlIO_printf(Perl_debug_log,
 609                         ", trying floating at offset %ld...\n",
 610                         (long)(HOP3c(s1, 1, strend) - i_strpos)));
 611                     other_last = HOP3c(last1, prog->anchored_offset+1, strend);
 612                     s = HOP3c(last, 1, strend);
 613                     goto restart;
 614                 }
 615                 else {
 616                     DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 617                           (long)(s - i_strpos)));
 618                     t = HOP3c(s, -prog->anchored_offset, strbeg);
 619                     other_last = HOP3c(s, 1, strend);
 620                     s = s1;
 621                     if (t == strpos)
 622                         goto try_at_start;
 623                     goto try_at_offset;
 624                 }
 625             }
 626         }
 627         else {          /* Take into account the floating substring. */
 628                 char *last, *last1;
 629                 char *s1 = s;
 630
 631                 t = HOP3c(s, -start_shift, strbeg);
 632                 last1 = last =
 633                     HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
 634                 if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
 635                     last = HOP3c(t, prog->float_max_offset, strend);
 636                 s = HOP3c(t, prog->float_min_offset, strend);
 637                 if (s < other_last)
 638                     s = other_last;
 639  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
 640                 /* fbm_instr() takes into account exact value of end-of-str
 641                    if the check is SvTAIL(ed).  Since false positives are OK,
 642                    and end-of-str is not later than strend we are OK. */
 643                 s = fbm_instr((unsigned char*)s,
 644                               (unsigned char*)last + SvCUR(prog->float_substr)
 645                                   - (SvTAIL(prog->float_substr)!=0),
 646                               prog->float_substr, PL_multiline ? FBMrf_MULTILINE : 0);
 647                 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s floating substr `%s%.*s%s'%s",
 648                         (s ? "Found" : "Contradicts"),
 649                         PL_colors[0],
 650                           (int)(SvCUR(prog->float_substr)
 651                           - (SvTAIL(prog->float_substr)!=0)),
 652                           SvPVX(prog->float_substr),
 653                           PL_colors[1], (SvTAIL(prog->float_substr) ? "$" : "")));
 654                 if (!s) {
 655                     if (last1 == last) {
 656                         DEBUG_r(PerlIO_printf(Perl_debug_log,
 657                                                 ", giving up...\n"));
 658                         goto fail_finish;
 659                     }
 660                     DEBUG_r(PerlIO_printf(Perl_debug_log,
 661                         ", trying anchored starting at offset %ld...\n",
 662                         (long)(s1 + 1 - i_strpos)));
 663                     other_last = last;
 664                     s = HOP3c(t, 1, strend);
 665                     goto restart;
 666                 }
 667                 else {
 668                     DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 669                           (long)(s - i_strpos)));
 670                     other_last = s; /* Fix this later. --Hugo */
 671                     s = s1;
 672                     if (t == strpos)
 673                         goto try_at_start;
 674                     goto try_at_offset;
 675                 }
 676         }
 677     }
 678
 679     t = s - prog->check_offset_max;
 680     if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 681         && (!(prog->reganch & ROPT_UTF8)
 682             || ((t = reghopmaybe3_c(s, -prog->check_offset_max, strpos))
 683                  && t > strpos))) {
 684         /* Fixed substring is found far enough so that the match
 685            cannot start at strpos. */
 686       try_at_offset:
 687         if (ml_anch && t[-1] != '\n') {
 688             /* Eventually fbm_*() should handle this, but often
 689                anchored_offset is not 0, so this check will not be wasted. */
 690             /* XXXX In the code below we prefer to look for "^" even in
 691                presence of anchored substrings.  And we search even
 692                beyond the found float position.  These pessimizations
 693                are historical artefacts only.  */
 694           find_anchor:
 695             while (t < strend - prog->minlen) {
 696                 if (*t == '\n') {
 697                     if (t < check_at - prog->check_offset_min) {
 698                         if (prog->anchored_substr) {
 699                             /* Since we moved from the found position,
 700                                we definitely contradict the found anchored
 701                                substr.  Due to the above check we do not
 702                                contradict "check" substr.
 703                                Thus we can arrive here only if check substr
 704                                is float.  Redo checking for "other"=="fixed".
 705                              */
 706                             strpos = t + 1;
 707                             DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
 708                                 PL_colors[0],PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
 709                             goto do_other_anchored;
 710                         }
 711                         /* We don't contradict the found floating substring. */
 712                         /* XXXX Why not check for STCLASS? */
 713                         s = t + 1;
 714                         DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
 715                             PL_colors[0],PL_colors[1], (long)(s - i_strpos)));
 716                         goto set_useful;
 717                     }
 718                     /* Position contradicts check-string */
 719                     /* XXXX probably better to look for check-string
 720                        than for "\n", so one should lower the limit for t? */
 721                     DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
 722                         PL_colors[0],PL_colors[1], (long)(t + 1 - i_strpos)));
 723                     other_last = strpos = s = t + 1;
 724                     goto restart;
 725                 }
 726                 t++;
 727             }
 728             DEBUG_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
 729                         PL_colors[0],PL_colors[1]));
 730             goto fail_finish;
 731         }
 732         else {
 733             DEBUG_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
 734                         PL_colors[0],PL_colors[1]));
 735         }
 736         s = t;
 737       set_useful:
 738         ++BmUSEFUL(prog->check_substr); /* hooray/5 */
 739     }
 740     else {
 741         /* The found string does not prohibit matching at strpos,
 742            - no optimization of calling REx engine can be performed,
 743            unless it was an MBOL and we are not after MBOL,
 744            or a future STCLASS check will fail this. */
 745       try_at_start:
 746         /* Even in this situation we may use MBOL flag if strpos is offset
 747            wrt the start of the string. */
 748         if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
 749             && (strpos != strbeg) && strpos[-1] != '\n'
 750             /* May be due to an implicit anchor of m{.*foo}  */
 751             && !(prog->reganch & ROPT_IMPLICIT))
 752         {
 753             t = strpos;
 754             goto find_anchor;
 755         }
 756         DEBUG_r( if (ml_anch)
 757             PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
 758                         (long)(strpos - i_strpos), PL_colors[0],PL_colors[1]);
 759         );
 760       success_at_start:
 761         if (!(prog->reganch & ROPT_NAUGHTY)     /* XXXX If strpos moved? */
 762             && prog->check_substr               /* Could be deleted already */
 763             && --BmUSEFUL(prog->check_substr) < 0
 764             && prog->check_substr == prog->float_substr)
 765         {
 766             /* If flags & SOMETHING - do not do it many times on the same match */
 767             DEBUG_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
 768             SvREFCNT_dec(prog->check_substr);
 769             prog->check_substr = Nullsv;        /* disable */
 770             prog->float_substr = Nullsv;        /* clear */
 771             check = Nullsv;                     /* abort */
 772             s = strpos;
 773             /* XXXX This is a remnant of the old implementation.  It
 774                     looks wasteful, since now INTUIT can use many
 775                     other heuristics. */
 776             prog->reganch &= ~RE_USE_INTUIT;
 777         }
 778         else
 779             s = strpos;
 780     }
 781
 782     /* Last resort... */
 783     /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
 784     if (prog->regstclass) {
 785         /* minlen == 0 is possible if regstclass is \b or \B,
 786            and the fixed substr is ''$.
 787            Since minlen is already taken into account, s+1 is before strend;
 788            accidentally, minlen >= 1 guaranties no false positives at s + 1
 789            even for \b or \B.  But (minlen? 1 : 0) below assumes that
 790            regstclass does not come from lookahead...  */
 791         /* If regstclass takes bytelength more than 1: If charlength==1, OK.
 792            This leaves EXACTF only, which is dealt with in find_byclass().  */
 793         U8* str = (U8*)STRING(prog->regstclass);
 794         int cl_l = (PL_regkind[(U8)OP(prog->regstclass)] == EXACT
 795                     ? CHR_DIST(str+STR_LEN(prog->regstclass), str)
 796                     : 1);
 797         char *endpos = (prog->anchored_substr || ml_anch)
 798                 ? HOP3c(s, (prog->minlen ? cl_l : 0), strend)
 799                 : (prog->float_substr
 800                    ? HOP3c(HOP3c(check_at, -start_shift, strbeg),
 801                            cl_l, strend)
 802                    : strend);
 803         char *startpos = strbeg;
 804
 805         t = s;
 806         if (prog->reganch & ROPT_UTF8) {
 807             PL_regdata = prog->data;
 808             PL_bostr = startpos;
 809         }
 810         s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1);
 811         if (!s) {
 812 #ifdef DEBUGGING
 813             char *what = 0;
 814 #endif
 815             if (endpos == strend) {
 816                 DEBUG_r( PerlIO_printf(Perl_debug_log,
 817                                 "Could not match STCLASS...\n") );
 818                 goto fail;
 819             }
 820             DEBUG_r( PerlIO_printf(Perl_debug_log,
 821                                    "This position contradicts STCLASS...\n") );
 822             if ((prog->reganch & ROPT_ANCH) && !ml_anch)
 823                 goto fail;
 824             /* Contradict one of substrings */
 825             if (prog->anchored_substr) {
 826                 if (prog->anchored_substr == check) {
 827                     DEBUG_r( what = "anchored" );
 828                   hop_and_restart:
 829                     s = HOP3c(t, 1, strend);
 830                     if (s + start_shift + end_shift > strend) {
 831                         /* XXXX Should be taken into account earlier? */
 832                         DEBUG_r( PerlIO_printf(Perl_debug_log,
 833                                                "Could not match STCLASS...\n") );
 834                         goto fail;
 835                     }
 836                     if (!check)
 837                         goto giveup;
 838                     DEBUG_r( PerlIO_printf(Perl_debug_log,
 839                                 "Looking for %s substr starting at offset %ld...\n",
 840                                  what, (long)(s + start_shift - i_strpos)) );
 841                     goto restart;
 842                 }
 843                 /* Have both, check_string is floating */
 844                 if (t + start_shift >= check_at) /* Contradicts floating=check */
 845                     goto retry_floating_check;
 846                 /* Recheck anchored substring, but not floating... */
 847                 s = check_at;
 848                 if (!check)
 849                     goto giveup;
 850                 DEBUG_r( PerlIO_printf(Perl_debug_log,
 851                           "Looking for anchored substr starting at offset %ld...\n",
 852                           (long)(other_last - i_strpos)) );
 853                 goto do_other_anchored;
 854             }
 855             /* Another way we could have checked stclass at the
 856                current position only: */
 857             if (ml_anch) {
 858                 s = t = t + 1;
 859                 if (!check)
 860                     goto giveup;
 861                 DEBUG_r( PerlIO_printf(Perl_debug_log,
 862                           "Looking for /%s^%s/m starting at offset %ld...\n",
 863                           PL_colors[0],PL_colors[1], (long)(t - i_strpos)) );
 864                 goto try_at_offset;
 865             }
 866             if (!prog->float_substr)    /* Could have been deleted */
 867                 goto fail;
 868             /* Check is floating subtring. */
 869           retry_floating_check:
 870             t = check_at - start_shift;
 871             DEBUG_r( what = "floating" );
 872             goto hop_and_restart;
 873         }
 874         if (t != s) {
 875             DEBUG_r(PerlIO_printf(Perl_debug_log,
 876                         "By STCLASS: moving %ld --> %ld\n",
 877                                   (long)(t - i_strpos), (long)(s - i_strpos))
 878                    );
 879         }
 880         else {
 881             DEBUG_r(PerlIO_printf(Perl_debug_log,
 882                                   "Does not contradict STCLASS...\n");
 883                    );
 884         }
 885     }
 886   giveup:
 887     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
 888                           PL_colors[4], (check ? "Guessed" : "Giving up"),
 889                           PL_colors[5], (long)(s - i_strpos)) );
 890     return s;
 891
 892   fail_finish:                          /* Substring not found */
 893     if (prog->check_substr)             /* could be removed already */
 894         BmUSEFUL(prog->check_substr) += 5; /* hooray */
 895   fail:
 896     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
 897                           PL_colors[4],PL_colors[5]));
 898     return Nullch;
 899 }
 900
 901 /* We know what class REx starts with.  Try to find this position... */
 902 STATIC char *
 903 S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *startpos, I32 norun)
 904 {
 905         I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
 906         char *m;
 907         STRLEN ln;
 908         unsigned int c1;
 909         unsigned int c2;
 910         char *e;
 911         register I32 tmp = 1;   /* Scratch variable? */
 912         register bool do_utf8 = PL_reg_match_utf8;
 913
 914         /* We know what class it must start with. */
 915         switch (OP(c)) {
 916         case ANYOF:
 917             while (s < strend) {
 918                 if (reginclass(c, (U8*)s, do_utf8)) {
 919                     if (tmp && (norun || regtry(prog, s)))
 920                         goto got_it;
 921                     else
 922                         tmp = doevery;
 923                 }
 924                 else
 925                     tmp = 1;
 926                 s += do_utf8 ? UTF8SKIP(s) : 1;
 927             }
 928             break;
 929         case CANY:
 930             while (s < strend) {
 931                 if (tmp && (norun || regtry(prog, s)))
 932                     goto got_it;
 933                 else
 934                     tmp = doevery;
 935                 s++;
 936             }
 937             break;
 938         case EXACTF:
 939             m = STRING(c);
 940             ln = STR_LEN(c);
 941             if (UTF) {
 942                 STRLEN ulen1, ulen2;
 943                 U8 tmpbuf1[UTF8_MAXLEN_UCLC+1];
 944                 U8 tmpbuf2[UTF8_MAXLEN_UCLC+1];
 945
 946                 to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
 947                 to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
 948
 949                 c1 = utf8_to_uvuni(tmpbuf1, 0);
 950                 c2 = utf8_to_uvuni(tmpbuf2, 0);
 951             }
 952             else {
 953                 c1 = *(U8*)m;
 954                 c2 = PL_fold[c1];
 955             }
 956             goto do_exactf;
 957         case EXACTFL:
 958             m = STRING(c);
 959             ln = STR_LEN(c);
 960             c1 = *(U8*)m;
 961             c2 = PL_fold_locale[c1];
 962           do_exactf:
 963             e = strend - ln;
 964
 965             if (norun && e < s)
 966                 e = s;                  /* Due to minlen logic of intuit() */
 967
 968             if (do_utf8) {
 969                 STRLEN len;
 970                 /* The ibcmp_utf8() uses to_uni_fold() which is more
 971                  * correct folding for Unicode than using lowercase.
 972                  * However, it doesn't work quite fully since the folding
 973                  * is a one-to-many mapping and the regex optimizer is
 974                  * unaware of this, so it may throw out good matches.
 975                  * Fortunately, not getting this right is allowed
 976                  * for Unicode Regular Expression Support level 1,
 977                  * only one-to-one matching is required. --jhi */
 978                 if (c1 == c2)
 979                     while (s <= e) {
 980                         if ( utf8_to_uvchr((U8*)s, &len) == c1
 981                              && (ln == len ||
 982                                  ibcmp_utf8(s, do_utf8,  strend - s,
 983                                             m, UTF, ln))
 984                              && (norun || regtry(prog, s)) )
 985                             goto got_it;
 986                         s += len;
 987                     }
 988                 else
 989                     while (s <= e) {
 990                         UV c = utf8_to_uvchr((U8*)s, &len);
 991                         if ( (c == c1 || c == c2)
 992                              && (ln == len ||
 993                                  ibcmp_utf8(s, do_utf8, strend - s,
 994                                             m, UTF, ln))
 995                              && (norun || regtry(prog, s)) )
 996                             goto got_it;
 997                         s += len;
 998                     }
 999             }
1000             else {
1001                 if (c1 == c2)
1002                     while (s <= e) {
1003                         if ( *(U8*)s == c1
1004                              && (ln == 1 || !(OP(c) == EXACTF
1005                                               ? ibcmp(s, m, ln)
1006                                               : ibcmp_locale(s, m, ln)))
1007                              && (norun || regtry(prog, s)) )
1008                             goto got_it;
1009                         s++;
1010                     }
1011                 else
1012                     while (s <= e) {
1013                         if ( (*(U8*)s == c1 || *(U8*)s == c2)
1014                              && (ln == 1 || !(OP(c) == EXACTF
1015                                               ? ibcmp(s, m, ln)
1016                                               : ibcmp_locale(s, m, ln)))
1017                              && (norun || regtry(prog, s)) )
1018                             goto got_it;
1019                         s++;
1020                     }
1021             }
1022             break;
1023         case BOUNDL:
1024             PL_reg_flags |= RF_tainted;
1025             /* FALL THROUGH */
1026         case BOUND:
1027             if (do_utf8) {
1028                 if (s == PL_bostr)
1029                     tmp = '\n';
1030                 else {
1031                     U8 *r = reghop3((U8*)s, -1, (U8*)startpos);
1032
1033                     if (s > (char*)r)
1034                         tmp = (I32)utf8n_to_uvchr(r, s - (char*)r, 0, 0);
1035                 }
1036                 tmp = ((OP(c) == BOUND ?
1037                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1038                 LOAD_UTF8_CHARCLASS(alnum,"a");
1039                 while (s < strend) {
1040                     if (tmp == !(OP(c) == BOUND ?
1041                                  swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1042                                  isALNUM_LC_utf8((U8*)s)))
1043                     {
1044                         tmp = !tmp;
1045                         if ((norun || regtry(prog, s)))
1046                             goto got_it;
1047                     }
1048                     s += UTF8SKIP(s);
1049                 }
1050             }
1051             else {
1052                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1053                 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1054                 while (s < strend) {
1055                     if (tmp ==
1056                         !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1057                         tmp = !tmp;
1058                         if ((norun || regtry(prog, s)))
1059                             goto got_it;
1060                     }
1061                     s++;
1062                 }
1063             }
1064             if ((!prog->minlen && tmp) && (norun || regtry(prog, s)))
1065                 goto got_it;
1066             break;
1067         case NBOUNDL:
1068             PL_reg_flags |= RF_tainted;
1069             /* FALL THROUGH */
1070         case NBOUND:
1071             if (do_utf8) {
1072                 if (s == PL_bostr)
1073                     tmp = '\n';
1074                 else {
1075                     U8 *r = reghop3((U8*)s, -1, (U8*)startpos);
1076
1077                     if (s > (char*)r)
1078                         tmp = (I32)utf8n_to_uvchr(r, s - (char*)r, 0, 0);
1079                 }
1080                 tmp = ((OP(c) == NBOUND ?
1081                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1082                 LOAD_UTF8_CHARCLASS(alnum,"a");
1083                 while (s < strend) {
1084                     if (tmp == !(OP(c) == NBOUND ?
1085                                  swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1086                                  isALNUM_LC_utf8((U8*)s)))
1087                         tmp = !tmp;
1088                     else if ((norun || regtry(prog, s)))
1089                         goto got_it;
1090                     s += UTF8SKIP(s);
1091                 }
1092             }
1093             else {
1094                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1095                 tmp = ((OP(c) == NBOUND ?
1096                         isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1097                 while (s < strend) {
1098                     if (tmp ==
1099                         !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1100                         tmp = !tmp;
1101                     else if ((norun || regtry(prog, s)))
1102                         goto got_it;
1103                     s++;
1104                 }
1105             }
1106             if ((!prog->minlen && !tmp) && (norun || regtry(prog, s)))
1107                 goto got_it;
1108             break;
1109         case ALNUM:
1110             if (do_utf8) {
1111                 LOAD_UTF8_CHARCLASS(alnum,"a");
1112                 while (s < strend) {
1113                     if (swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1114                         if (tmp && (norun || regtry(prog, s)))
1115                             goto got_it;
1116                         else
1117                             tmp = doevery;
1118                     }
1119                     else
1120                         tmp = 1;
1121                     s += UTF8SKIP(s);
1122                 }
1123             }
1124             else {
1125                 while (s < strend) {
1126                     if (isALNUM(*s)) {
1127                         if (tmp && (norun || regtry(prog, s)))
1128                             goto got_it;
1129                         else
1130                             tmp = doevery;
1131                     }
1132                     else
1133                         tmp = 1;
1134                     s++;
1135                 }
1136             }
1137             break;
1138         case ALNUML:
1139             PL_reg_flags |= RF_tainted;
1140             if (do_utf8) {
1141                 while (s < strend) {
1142                     if (isALNUM_LC_utf8((U8*)s)) {
1143                         if (tmp && (norun || regtry(prog, s)))
1144                             goto got_it;
1145                         else
1146                             tmp = doevery;
1147                     }
1148                     else
1149                         tmp = 1;
1150                     s += UTF8SKIP(s);
1151                 }
1152             }
1153             else {
1154                 while (s < strend) {
1155                     if (isALNUM_LC(*s)) {
1156                         if (tmp && (norun || regtry(prog, s)))
1157                             goto got_it;
1158                         else
1159                             tmp = doevery;
1160                     }
1161                     else
1162                         tmp = 1;
1163                     s++;
1164                 }
1165             }
1166             break;
1167         case NALNUM:
1168             if (do_utf8) {
1169                 LOAD_UTF8_CHARCLASS(alnum,"a");
1170                 while (s < strend) {
1171                     if (!swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1172                         if (tmp && (norun || regtry(prog, s)))
1173                             goto got_it;
1174                         else
1175                             tmp = doevery;
1176                     }
1177                     else
1178                         tmp = 1;
1179                     s += UTF8SKIP(s);
1180                 }
1181             }
1182             else {
1183                 while (s < strend) {
1184                     if (!isALNUM(*s)) {
1185                         if (tmp && (norun || regtry(prog, s)))
1186                             goto got_it;
1187                         else
1188                             tmp = doevery;
1189                     }
1190                     else
1191                         tmp = 1;
1192                     s++;
1193                 }
1194             }
1195             break;
1196         case NALNUML:
1197             PL_reg_flags |= RF_tainted;
1198             if (do_utf8) {
1199                 while (s < strend) {
1200                     if (!isALNUM_LC_utf8((U8*)s)) {
1201                         if (tmp && (norun || regtry(prog, s)))
1202                             goto got_it;
1203                         else
1204                             tmp = doevery;
1205                     }
1206                     else
1207                         tmp = 1;
1208                     s += UTF8SKIP(s);
1209                 }
1210             }
1211             else {
1212                 while (s < strend) {
1213                     if (!isALNUM_LC(*s)) {
1214                         if (tmp && (norun || regtry(prog, s)))
1215                             goto got_it;
1216                         else
1217                             tmp = doevery;
1218                     }
1219                     else
1220                         tmp = 1;
1221                     s++;
1222                 }
1223             }
1224             break;
1225         case SPACE:
1226             if (do_utf8) {
1227                 LOAD_UTF8_CHARCLASS(space," ");
1228                 while (s < strend) {
1229                     if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)) {
1230                         if (tmp && (norun || regtry(prog, s)))
1231                             goto got_it;
1232                         else
1233                             tmp = doevery;
1234                     }
1235                     else
1236                         tmp = 1;
1237                     s += UTF8SKIP(s);
1238                 }
1239             }
1240             else {
1241                 while (s < strend) {
1242                     if (isSPACE(*s)) {
1243                         if (tmp && (norun || regtry(prog, s)))
1244                             goto got_it;
1245                         else
1246                             tmp = doevery;
1247                     }
1248                     else
1249                         tmp = 1;
1250                     s++;
1251                 }
1252             }
1253             break;
1254         case SPACEL:
1255             PL_reg_flags |= RF_tainted;
1256             if (do_utf8) {
1257                 while (s < strend) {
1258                     if (*s == ' ' || isSPACE_LC_utf8((U8*)s)) {
1259                         if (tmp && (norun || regtry(prog, s)))
1260                             goto got_it;
1261                         else
1262                             tmp = doevery;
1263                     }
1264                     else
1265                         tmp = 1;
1266                     s += UTF8SKIP(s);
1267                 }
1268             }
1269             else {
1270                 while (s < strend) {
1271                     if (isSPACE_LC(*s)) {
1272                         if (tmp && (norun || regtry(prog, s)))
1273                             goto got_it;
1274                         else
1275                             tmp = doevery;
1276                     }
1277                     else
1278                         tmp = 1;
1279                     s++;
1280                 }
1281             }
1282             break;
1283         case NSPACE:
1284             if (do_utf8) {
1285                 LOAD_UTF8_CHARCLASS(space," ");
1286                 while (s < strend) {
1287                     if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8))) {
1288                         if (tmp && (norun || regtry(prog, s)))
1289                             goto got_it;
1290                         else
1291                             tmp = doevery;
1292                     }
1293                     else
1294                         tmp = 1;
1295                     s += UTF8SKIP(s);
1296                 }
1297             }
1298             else {
1299                 while (s < strend) {
1300                     if (!isSPACE(*s)) {
1301                         if (tmp && (norun || regtry(prog, s)))
1302                             goto got_it;
1303                         else
1304                             tmp = doevery;
1305                     }
1306                     else
1307                         tmp = 1;
1308                     s++;
1309                 }
1310             }
1311             break;
1312         case NSPACEL:
1313             PL_reg_flags |= RF_tainted;
1314             if (do_utf8) {
1315                 while (s < strend) {
1316                     if (!(*s == ' ' || isSPACE_LC_utf8((U8*)s))) {
1317                         if (tmp && (norun || regtry(prog, s)))
1318                             goto got_it;
1319                         else
1320                             tmp = doevery;
1321                     }
1322                     else
1323                         tmp = 1;
1324                     s += UTF8SKIP(s);
1325                 }
1326             }
1327             else {
1328                 while (s < strend) {
1329                     if (!isSPACE_LC(*s)) {
1330                         if (tmp && (norun || regtry(prog, s)))
1331                             goto got_it;
1332                         else
1333                             tmp = doevery;
1334                     }
1335                     else
1336                         tmp = 1;
1337                     s++;
1338                 }
1339             }
1340             break;
1341         case DIGIT:
1342             if (do_utf8) {
1343                 LOAD_UTF8_CHARCLASS(digit,"0");
1344                 while (s < strend) {
1345                     if (swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1346                         if (tmp && (norun || regtry(prog, s)))
1347                             goto got_it;
1348                         else
1349                             tmp = doevery;
1350                     }
1351                     else
1352                         tmp = 1;
1353                     s += UTF8SKIP(s);
1354                 }
1355             }
1356             else {
1357                 while (s < strend) {
1358                     if (isDIGIT(*s)) {
1359                         if (tmp && (norun || regtry(prog, s)))
1360                             goto got_it;
1361                         else
1362                             tmp = doevery;
1363                     }
1364                     else
1365                         tmp = 1;
1366                     s++;
1367                 }
1368             }
1369             break;
1370         case DIGITL:
1371             PL_reg_flags |= RF_tainted;
1372             if (do_utf8) {
1373                 while (s < strend) {
1374                     if (isDIGIT_LC_utf8((U8*)s)) {
1375                         if (tmp && (norun || regtry(prog, s)))
1376                             goto got_it;
1377                         else
1378                             tmp = doevery;
1379                     }
1380                     else
1381                         tmp = 1;
1382                     s += UTF8SKIP(s);
1383                 }
1384             }
1385             else {
1386                 while (s < strend) {
1387                     if (isDIGIT_LC(*s)) {
1388                         if (tmp && (norun || regtry(prog, s)))
1389                             goto got_it;
1390                         else
1391                             tmp = doevery;
1392                     }
1393                     else
1394                         tmp = 1;
1395                     s++;
1396                 }
1397             }
1398             break;
1399         case NDIGIT:
1400             if (do_utf8) {
1401                 LOAD_UTF8_CHARCLASS(digit,"0");
1402                 while (s < strend) {
1403                     if (!swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1404                         if (tmp && (norun || regtry(prog, s)))
1405                             goto got_it;
1406                         else
1407                             tmp = doevery;
1408                     }
1409                     else
1410                         tmp = 1;
1411                     s += UTF8SKIP(s);
1412                 }
1413             }
1414             else {
1415                 while (s < strend) {
1416                     if (!isDIGIT(*s)) {
1417                         if (tmp && (norun || regtry(prog, s)))
1418                             goto got_it;
1419                         else
1420                             tmp = doevery;
1421                     }
1422                     else
1423                         tmp = 1;
1424                     s++;
1425                 }
1426             }
1427             break;
1428         case NDIGITL:
1429             PL_reg_flags |= RF_tainted;
1430             if (do_utf8) {
1431                 while (s < strend) {
1432                     if (!isDIGIT_LC_utf8((U8*)s)) {
1433                         if (tmp && (norun || regtry(prog, s)))
1434                             goto got_it;
1435                         else
1436                             tmp = doevery;
1437                     }
1438                     else
1439                         tmp = 1;
1440                     s += UTF8SKIP(s);
1441                 }
1442             }
1443             else {
1444                 while (s < strend) {
1445                     if (!isDIGIT_LC(*s)) {
1446                         if (tmp && (norun || regtry(prog, s)))
1447                             goto got_it;
1448                         else
1449                             tmp = doevery;
1450                     }
1451                     else
1452                         tmp = 1;
1453                     s++;
1454                 }
1455             }
1456             break;
1457         default:
1458             Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1459             break;
1460         }
1461         return 0;
1462       got_it:
1463         return s;
1464 }
1465
1466 /*
1467  - regexec_flags - match a regexp against a string
1468  */
1469 I32
1470 Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *strend,
1471               char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1472 /* strend: pointer to null at end of string */
1473 /* strbeg: real beginning of string */
1474 /* minend: end of match must be >=minend after stringarg. */
1475 /* data: May be used for some additional optimizations. */
1476 /* nosave: For optimizations. */
1477 {
1478     register char *s;
1479     register regnode *c;
1480     register char *startpos = stringarg;
1481     I32 minlen;         /* must match at least this many chars */
1482     I32 dontbother = 0; /* how many characters not to try at end */
1483     /* I32 start_shift = 0; */          /* Offset of the start to find
1484                                          constant substr. */            /* CC */
1485     I32 end_shift = 0;                  /* Same for the end. */         /* CC */
1486     I32 scream_pos = -1;                /* Internal iterator of scream. */
1487     char *scream_olds;
1488     SV* oreplsv = GvSV(PL_replgv);
1489     bool do_utf8 = DO_UTF8(sv);
1490 #ifdef DEBUGGING
1491     SV *dsv = PERL_DEBUG_PAD_ZERO(0);
1492 #endif
1493
1494     PL_regcc = 0;
1495
1496     cache_re(prog);
1497 #ifdef DEBUGGING
1498     PL_regnarrate = DEBUG_r_TEST;
1499 #endif
1500
1501     /* Be paranoid... */
1502     if (prog == NULL || startpos == NULL) {
1503         Perl_croak(aTHX_ "NULL regexp parameter");
1504         return 0;
1505     }
1506
1507     minlen = prog->minlen;
1508     if (strend - startpos < minlen) {
1509         DEBUG_r(PerlIO_printf(Perl_debug_log,
1510                               "String too short [regexec_flags]...\n"));
1511         goto phooey;
1512     }
1513
1514     /* Check validity of program. */
1515     if (UCHARAT(prog->program) != REG_MAGIC) {
1516         Perl_croak(aTHX_ "corrupted regexp program");
1517     }
1518
1519     PL_reg_flags = 0;
1520     PL_reg_eval_set = 0;
1521     PL_reg_maxiter = 0;
1522
1523     if (prog->reganch & ROPT_UTF8)
1524         PL_reg_flags |= RF_utf8;
1525
1526     /* Mark beginning of line for ^ and lookbehind. */
1527     PL_regbol = startpos;
1528     PL_bostr  = strbeg;
1529     PL_reg_sv = sv;
1530
1531     /* Mark end of line for $ (and such) */
1532     PL_regeol = strend;
1533
1534     /* see how far we have to get to not match where we matched before */
1535     PL_regtill = startpos+minend;
1536
1537     /* We start without call_cc context.  */
1538     PL_reg_call_cc = 0;
1539
1540     /* If there is a "must appear" string, look for it. */
1541     s = startpos;
1542
1543     if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to have PL_reg_ganch */
1544         MAGIC *mg;
1545
1546         if (flags & REXEC_IGNOREPOS)    /* Means: check only at start */
1547             PL_reg_ganch = startpos;
1548         else if (sv && SvTYPE(sv) >= SVt_PVMG
1549                   && SvMAGIC(sv)
1550                   && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1551                   && mg->mg_len >= 0) {
1552             PL_reg_ganch = strbeg + mg->mg_len; /* Defined pos() */
1553             if (prog->reganch & ROPT_ANCH_GPOS) {
1554                 if (s > PL_reg_ganch)
1555                     goto phooey;
1556                 s = PL_reg_ganch;
1557             }
1558         }
1559         else                            /* pos() not defined */
1560             PL_reg_ganch = strbeg;
1561     }
1562
1563     if (do_utf8 == (UTF!=0) &&
1564         !(flags & REXEC_CHECKED) && prog->check_substr != Nullsv) {
1565         re_scream_pos_data d;
1566
1567         d.scream_olds = &scream_olds;
1568         d.scream_pos = &scream_pos;
1569         s = re_intuit_start(prog, sv, s, strend, flags, &d);
1570         if (!s) {
1571             DEBUG_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1572             goto phooey;        /* not present */
1573         }
1574     }
1575
1576     DEBUG_r({
1577          char *s   = do_utf8 ? sv_uni_display(dsv, sv, 60, 0) : startpos;
1578          int   len = do_utf8 ? strlen(s) : strend - startpos;
1579          if (!PL_colorset)
1580              reginitcolors();
1581          PerlIO_printf(Perl_debug_log,
1582                        "%sMatching REx%s `%s%.60s%s%s' against `%s%.*s%s%s'\n",
1583                        PL_colors[4],PL_colors[5],PL_colors[0],
1584                        prog->precomp,
1585                        PL_colors[1],
1586                        (strlen(prog->precomp) > 60 ? "..." : ""),
1587                        PL_colors[0],
1588                        (int)(len > 60 ? 60 : len),
1589                        s, PL_colors[1],
1590                        (len > 60 ? "..." : "")
1591               );
1592     });
1593
1594     /* Simplest case:  anchored match need be tried only once. */
1595     /*  [unless only anchor is BOL and multiline is set] */
1596     if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
1597         if (s == startpos && regtry(prog, startpos))
1598             goto got_it;
1599         else if (PL_multiline || (prog->reganch & ROPT_IMPLICIT)
1600                  || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
1601         {
1602             char *end;
1603
1604             if (minlen)
1605                 dontbother = minlen - 1;
1606             end = HOP3c(strend, -dontbother, strbeg) - 1;
1607             /* for multiline we only have to try after newlines */
1608             if (prog->check_substr) {
1609                 if (s == startpos)
1610                     goto after_try;
1611                 while (1) {
1612                     if (regtry(prog, s))
1613                         goto got_it;
1614                   after_try:
1615                     if (s >= end)
1616                         goto phooey;
1617                     if (prog->reganch & RE_USE_INTUIT) {
1618                         s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
1619                         if (!s)
1620                             goto phooey;
1621                     }
1622                     else
1623                         s++;
1624                 }
1625             } else {
1626                 if (s > startpos)
1627                     s--;
1628                 while (s < end) {
1629                     if (*s++ == '\n') { /* don't need PL_utf8skip here */
1630                         if (regtry(prog, s))
1631                             goto got_it;
1632                     }
1633                 }
1634             }
1635         }
1636         goto phooey;
1637     } else if (prog->reganch & ROPT_ANCH_GPOS) {
1638         if (regtry(prog, PL_reg_ganch))
1639             goto got_it;
1640         goto phooey;
1641     }
1642
1643     /* Messy cases:  unanchored match. */
1644     if (prog->anchored_substr && prog->reganch & ROPT_SKIP) {
1645         /* we have /x+whatever/ */
1646         /* it must be a one character string (XXXX Except UTF?) */
1647         char ch = SvPVX(prog->anchored_substr)[0];
1648 #ifdef DEBUGGING
1649         int did_match = 0;
1650 #endif
1651
1652         if (do_utf8) {
1653             while (s < strend) {
1654                 if (*s == ch) {
1655                     DEBUG_r( did_match = 1 );
1656                     if (regtry(prog, s)) goto got_it;
1657                     s += UTF8SKIP(s);
1658                     while (s < strend && *s == ch)
1659                         s += UTF8SKIP(s);
1660                 }
1661                 s += UTF8SKIP(s);
1662             }
1663         }
1664         else {
1665             while (s < strend) {
1666                 if (*s == ch) {
1667                     DEBUG_r( did_match = 1 );
1668                     if (regtry(prog, s)) goto got_it;
1669                     s++;
1670                     while (s < strend && *s == ch)
1671                         s++;
1672                 }
1673                 s++;
1674             }
1675         }
1676         DEBUG_r(if (!did_match)
1677                 PerlIO_printf(Perl_debug_log,
1678                                   "Did not find anchored character...\n")
1679                );
1680     }
1681     /*SUPPRESS 560*/
1682     else if (do_utf8 == (UTF!=0) &&
1683              (prog->anchored_substr != Nullsv
1684               || (prog->float_substr != Nullsv
1685                   && prog->float_max_offset < strend - s))) {
1686         SV *must = prog->anchored_substr
1687             ? prog->anchored_substr : prog->float_substr;
1688         I32 back_max =
1689             prog->anchored_substr ? prog->anchored_offset : prog->float_max_offset;
1690         I32 back_min =
1691             prog->anchored_substr ? prog->anchored_offset : prog->float_min_offset;
1692         char *last = HOP3c(strend,      /* Cannot start after this */
1693                           -(I32)(CHR_SVLEN(must)
1694                                  - (SvTAIL(must) != 0) + back_min), strbeg);
1695         char *last1;            /* Last position checked before */
1696 #ifdef DEBUGGING
1697         int did_match = 0;
1698 #endif
1699
1700         if (s > PL_bostr)
1701             last1 = HOPc(s, -1);
1702         else
1703             last1 = s - 1;      /* bogus */
1704
1705         /* XXXX check_substr already used to find `s', can optimize if
1706            check_substr==must. */
1707         scream_pos = -1;
1708         dontbother = end_shift;
1709         strend = HOPc(strend, -dontbother);
1710         while ( (s <= last) &&
1711                 ((flags & REXEC_SCREAM)
1712                  ? (s = screaminstr(sv, must, HOP3c(s, back_min, strend) - strbeg,
1713                                     end_shift, &scream_pos, 0))
1714                  : (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend),
1715                                   (unsigned char*)strend, must,
1716                                   PL_multiline ? FBMrf_MULTILINE : 0))) ) {
1717             DEBUG_r( did_match = 1 );
1718             if (HOPc(s, -back_max) > last1) {
1719                 last1 = HOPc(s, -back_min);
1720                 s = HOPc(s, -back_max);
1721             }
1722             else {
1723                 char *t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
1724
1725                 last1 = HOPc(s, -back_min);
1726                 s = t;
1727             }
1728             if (do_utf8) {
1729                 while (s <= last1) {
1730                     if (regtry(prog, s))
1731                         goto got_it;
1732                     s += UTF8SKIP(s);
1733                 }
1734             }
1735             else {
1736                 while (s <= last1) {
1737                     if (regtry(prog, s))
1738                         goto got_it;
1739                     s++;
1740                 }
1741             }
1742         }
1743         DEBUG_r(if (!did_match)
1744                     PerlIO_printf(Perl_debug_log,
1745                                   "Did not find %s substr `%s%.*s%s'%s...\n",
1746                               ((must == prog->anchored_substr)
1747                                ? "anchored" : "floating"),
1748                               PL_colors[0],
1749                               (int)(SvCUR(must) - (SvTAIL(must)!=0)),
1750                               SvPVX(must),
1751                                   PL_colors[1], (SvTAIL(must) ? "$" : ""))
1752                );
1753         goto phooey;
1754     }
1755     else if ((c = prog->regstclass)) {
1756         if (minlen && PL_regkind[(U8)OP(prog->regstclass)] != EXACT)
1757             /* don't bother with what can't match */
1758             strend = HOPc(strend, -(minlen - 1));
1759         DEBUG_r({
1760             SV *prop = sv_newmortal();
1761             regprop(prop, c);
1762             PerlIO_printf(Perl_debug_log, "Matching stclass `%s' against `%s'\n", SvPVX(prop), UTF ? sv_uni_display(dsv, sv, 60, 0) : s);
1763         });
1764         if (find_byclass(prog, c, s, strend, startpos, 0))
1765             goto got_it;
1766         DEBUG_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n"));
1767     }
1768     else {
1769         dontbother = 0;
1770         if (prog->float_substr != Nullsv) {     /* Trim the end. */
1771             char *last;
1772
1773             if (flags & REXEC_SCREAM) {
1774                 last = screaminstr(sv, prog->float_substr, s - strbeg,
1775                                    end_shift, &scream_pos, 1); /* last one */
1776                 if (!last)
1777                     last = scream_olds; /* Only one occurrence. */
1778             }
1779             else {
1780                 STRLEN len;
1781                 char *little = SvPV(prog->float_substr, len);
1782
1783                 if (SvTAIL(prog->float_substr)) {
1784                     if (memEQ(strend - len + 1, little, len - 1))
1785                         last = strend - len + 1;
1786                     else if (!PL_multiline)
1787                         last = memEQ(strend - len, little, len)
1788                             ? strend - len : Nullch;
1789                     else
1790                         goto find_last;
1791                 } else {
1792                   find_last:
1793                     if (len)
1794                         last = rninstr(s, strend, little, little + len);
1795                     else
1796                         last = strend;  /* matching `$' */
1797                 }
1798             }
1799             if (last == NULL) {
1800                 DEBUG_r(PerlIO_printf(Perl_debug_log,
1801                                       "%sCan't trim the tail, match fails (should not happen)%s\n",
1802                                       PL_colors[4],PL_colors[5]));
1803                 goto phooey; /* Should not happen! */
1804             }
1805             dontbother = strend - last + prog->float_min_offset;
1806         }
1807         if (minlen && (dontbother < minlen))
1808             dontbother = minlen - 1;
1809         strend -= dontbother;              /* this one's always in bytes! */
1810         /* We don't know much -- general case. */
1811         if (do_utf8) {
1812             for (;;) {
1813                 if (regtry(prog, s))
1814                     goto got_it;
1815                 if (s >= strend)
1816                     break;
1817                 s += UTF8SKIP(s);
1818             };
1819         }
1820         else {
1821             do {
1822                 if (regtry(prog, s))
1823                     goto got_it;
1824             } while (s++ < strend);
1825         }
1826     }
1827
1828     /* Failure. */
1829     goto phooey;
1830
1831 got_it:
1832     RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
1833
1834     if (PL_reg_eval_set) {
1835         /* Preserve the current value of $^R */
1836         if (oreplsv != GvSV(PL_replgv))
1837             sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
1838                                                   restored, the value remains
1839                                                   the same. */
1840         restore_pos(aTHX_ 0);
1841     }
1842
1843     /* make sure $`, $&, $', and $digit will work later */
1844     if ( !(flags & REXEC_NOT_FIRST) ) {
1845         if (RX_MATCH_COPIED(prog)) {
1846             Safefree(prog->subbeg);
1847             RX_MATCH_COPIED_off(prog);
1848         }
1849         if (flags & REXEC_COPY_STR) {
1850             I32 i = PL_regeol - startpos + (stringarg - strbeg);
1851
1852             s = savepvn(strbeg, i);
1853             prog->subbeg = s;
1854             prog->sublen = i;
1855             RX_MATCH_COPIED_on(prog);
1856         }
1857         else {
1858             prog->subbeg = strbeg;
1859             prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
1860         }
1861     }
1862
1863     return 1;
1864
1865 phooey:
1866     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
1867                           PL_colors[4],PL_colors[5]));
1868     if (PL_reg_eval_set)
1869         restore_pos(aTHX_ 0);
1870     return 0;
1871 }
1872
1873 /*
1874  - regtry - try match at specific point
1875  */
1876 STATIC I32                      /* 0 failure, 1 success */
1877 S_regtry(pTHX_ regexp *prog, char *startpos)
1878 {
1879     register I32 i;
1880     register I32 *sp;
1881     register I32 *ep;
1882     CHECKPOINT lastcp;
1883
1884 #ifdef DEBUGGING
1885     PL_regindent = 0;   /* XXXX Not good when matches are reenterable... */
1886 #endif
1887     if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
1888         MAGIC *mg;
1889
1890         PL_reg_eval_set = RS_init;
1891         DEBUG_r(DEBUG_s(
1892             PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
1893                           (IV)(PL_stack_sp - PL_stack_base));
1894             ));
1895         SAVEI32(cxstack[cxstack_ix].blk_oldsp);
1896         cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
1897         /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
1898         SAVETMPS;
1899         /* Apparently this is not needed, judging by wantarray. */
1900         /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
1901            cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
1902
1903         if (PL_reg_sv) {
1904             /* Make $_ available to executed code. */
1905             if (PL_reg_sv != DEFSV) {
1906                 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
1907                 SAVESPTR(DEFSV);
1908                 DEFSV = PL_reg_sv;
1909             }
1910
1911             if (!(SvTYPE(PL_reg_sv) >= SVt_PVMG && SvMAGIC(PL_reg_sv)
1912                   && (mg = mg_find(PL_reg_sv, PERL_MAGIC_regex_global)))) {
1913                 /* prepare for quick setting of pos */
1914                 sv_magic(PL_reg_sv, (SV*)0,
1915                         PERL_MAGIC_regex_global, Nullch, 0);
1916                 mg = mg_find(PL_reg_sv, PERL_MAGIC_regex_global);
1917                 mg->mg_len = -1;
1918             }
1919             PL_reg_magic    = mg;
1920             PL_reg_oldpos   = mg->mg_len;
1921             SAVEDESTRUCTOR_X(restore_pos, 0);
1922         }
1923         if (!PL_reg_curpm) {
1924             Newz(22,PL_reg_curpm, 1, PMOP);
1925 #ifdef USE_ITHREADS
1926             {
1927                 SV* repointer = newSViv(0);
1928                 /* so we know which PL_regex_padav element is PL_reg_curpm */
1929                 SvFLAGS(repointer) |= SVf_BREAK;
1930                 av_push(PL_regex_padav,repointer);
1931                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
1932                 PL_regex_pad = AvARRAY(PL_regex_padav);
1933             }
1934 #endif
1935         }
1936         PM_SETRE(PL_reg_curpm, prog);
1937         PL_reg_oldcurpm = PL_curpm;
1938         PL_curpm = PL_reg_curpm;
1939         if (RX_MATCH_COPIED(prog)) {
1940             /*  Here is a serious problem: we cannot rewrite subbeg,
1941                 since it may be needed if this match fails.  Thus
1942                 $` inside (?{}) could fail... */
1943             PL_reg_oldsaved = prog->subbeg;
1944             PL_reg_oldsavedlen = prog->sublen;
1945             RX_MATCH_COPIED_off(prog);
1946         }
1947         else
1948             PL_reg_oldsaved = Nullch;
1949         prog->subbeg = PL_bostr;
1950         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
1951     }
1952     prog->startp[0] = startpos - PL_bostr;
1953     PL_reginput = startpos;
1954     PL_regstartp = prog->startp;
1955     PL_regendp = prog->endp;
1956     PL_reglastparen = &prog->lastparen;
1957     PL_reglastcloseparen = &prog->lastcloseparen;
1958     prog->lastparen = 0;
1959     PL_regsize = 0;
1960     DEBUG_r(PL_reg_starttry = startpos);
1961     if (PL_reg_start_tmpl <= prog->nparens) {
1962         PL_reg_start_tmpl = prog->nparens*3/2 + 3;
1963         if(PL_reg_start_tmp)
1964             Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
1965         else
1966             New(22,PL_reg_start_tmp, PL_reg_start_tmpl, char*);
1967     }
1968
1969 #ifdef DEBUGGING
1970     sv_setpvn(PERL_DEBUG_PAD(0), "", 0);
1971     sv_setpvn(PERL_DEBUG_PAD(1), "", 0);
1972     sv_setpvn(PERL_DEBUG_PAD(2), "", 0);
1973 #endif
1974
1975     /* XXXX What this code is doing here?!!!  There should be no need
1976        to do this again and again, PL_reglastparen should take care of
1977        this!  --ilya*/
1978
1979     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
1980      * Actually, the code in regcppop() (which Ilya may be meaning by
1981      * PL_reglastparen), is not needed at all by the test suite
1982      * (op/regexp, op/pat, op/split), but that code is needed, oddly
1983      * enough, for building DynaLoader, or otherwise this
1984      * "Error: '*' not in typemap in DynaLoader.xs, line 164"
1985      * will happen.  Meanwhile, this code *is* needed for the
1986      * above-mentioned test suite tests to succeed.  The common theme
1987      * on those tests seems to be returning null fields from matches.
1988      * --jhi */
1989 #if 1
1990     sp = prog->startp;
1991     ep = prog->endp;
1992     if (prog->nparens) {
1993         for (i = prog->nparens; i > *PL_reglastparen; i--) {
1994             *++sp = -1;
1995             *++ep = -1;
1996         }
1997     }
1998 #endif
1999     REGCP_SET(lastcp);
2000     if (regmatch(prog->program + 1)) {
2001         prog->endp[0] = PL_reginput - PL_bostr;
2002         return 1;
2003     }
2004     REGCP_UNWIND(lastcp);
2005     return 0;
2006 }
2007
2008 #define RE_UNWIND_BRANCH        1
2009 #define RE_UNWIND_BRANCHJ       2
2010
2011 union re_unwind_t;
2012
2013 typedef struct {                /* XX: makes sense to enlarge it... */
2014     I32 type;
2015     I32 prev;
2016     CHECKPOINT lastcp;
2017 } re_unwind_generic_t;
2018
2019 typedef struct {
2020     I32 type;
2021     I32 prev;
2022     CHECKPOINT lastcp;
2023     I32 lastparen;
2024     regnode *next;
2025     char *locinput;
2026     I32 nextchr;
2027 #ifdef DEBUGGING
2028     int regindent;
2029 #endif
2030 } re_unwind_branch_t;
2031
2032 typedef union re_unwind_t {
2033     I32 type;
2034     re_unwind_generic_t generic;
2035     re_unwind_branch_t branch;
2036 } re_unwind_t;
2037
2038 #define sayYES goto yes
2039 #define sayNO goto no
2040 #define sayYES_FINAL goto yes_final
2041 #define sayYES_LOUD  goto yes_loud
2042 #define sayNO_FINAL  goto no_final
2043 #define sayNO_SILENT goto do_no
2044 #define saySAME(x) if (x) goto yes; else goto no
2045
2046 #define REPORT_CODE_OFF 24
2047
2048 /*
2049  - regmatch - main matching routine
2050  *
2051  * Conceptually the strategy is simple:  check to see whether the current
2052  * node matches, call self recursively to see whether the rest matches,
2053  * and then act accordingly.  In practice we make some effort to avoid
2054  * recursion, in particular by going through "ordinary" nodes (that don't
2055  * need to know whether the rest of the match failed) by a loop instead of
2056  * by recursion.
2057  */
2058 /* [lwall] I've hoisted the register declarations to the outer block in order to
2059  * maybe save a little bit of pushing and popping on the stack.  It also takes
2060  * advantage of machines that use a register save mask on subroutine entry.
2061  */
2062 STATIC I32                      /* 0 failure, 1 success */
2063 S_regmatch(pTHX_ regnode *prog)
2064 {
2065     register regnode *scan;     /* Current node. */
2066     regnode *next;              /* Next node. */
2067     regnode *inner;             /* Next node in internal branch. */
2068     register I32 nextchr;       /* renamed nextchr - nextchar colides with
2069                                    function of same name */
2070     register I32 n;             /* no or next */
2071     register I32 ln = 0;        /* len or last */
2072     register char *s = Nullch;  /* operand or save */
2073     register char *locinput = PL_reginput;
2074     register I32 c1 = 0, c2 = 0, paren; /* case fold search, parenth */
2075     int minmod = 0, sw = 0, logical = 0;
2076     I32 unwind = 0;
2077 #if 0
2078     I32 firstcp = PL_savestack_ix;
2079 #endif
2080     register bool do_utf8 = PL_reg_match_utf8;
2081 #ifdef DEBUGGING
2082     SV *dsv0 = PERL_DEBUG_PAD_ZERO(0);
2083     SV *dsv1 = PERL_DEBUG_PAD_ZERO(1);
2084     SV *dsv2 = PERL_DEBUG_PAD_ZERO(2);
2085 #endif
2086
2087 #ifdef DEBUGGING
2088     PL_regindent++;
2089 #endif
2090
2091     /* Note that nextchr is a byte even in UTF */
2092     nextchr = UCHARAT(locinput);
2093     scan = prog;
2094     while (scan != NULL) {
2095
2096         DEBUG_r( {
2097             SV *prop = sv_newmortal();
2098             int docolor = *PL_colors[0];
2099             int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2100             int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
2101             /* The part of the string before starttry has one color
2102                (pref0_len chars), between starttry and current
2103                position another one (pref_len - pref0_len chars),
2104                after the current position the third one.
2105                We assume that pref0_len <= pref_len, otherwise we
2106                decrease pref0_len.  */
2107             int pref_len = (locinput - PL_bostr) > (5 + taill) - l
2108                 ? (5 + taill) - l : locinput - PL_bostr;
2109             int pref0_len;
2110
2111             while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2112                 pref_len++;
2113             pref0_len = pref_len  - (locinput - PL_reg_starttry);
2114             if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
2115                 l = ( PL_regeol - locinput > (5 + taill) - pref_len
2116                       ? (5 + taill) - pref_len : PL_regeol - locinput);
2117             while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2118                 l--;
2119             if (pref0_len < 0)
2120                 pref0_len = 0;
2121             if (pref0_len > pref_len)
2122                 pref0_len = pref_len;
2123             regprop(prop, scan);
2124             {
2125               char *s0 =
2126                 do_utf8 ?
2127                 pv_uni_display(dsv0, (U8*)(locinput - pref_len),
2128                                pref0_len, 60, 0) :
2129                 locinput - pref_len;
2130               int len0 = do_utf8 ? strlen(s0) : pref0_len;
2131               char *s1 = do_utf8 ?
2132                 pv_uni_display(dsv1, (U8*)(locinput - pref_len + pref0_len),
2133                                pref_len - pref0_len, 60, 0) :
2134                 locinput - pref_len + pref0_len;
2135               int len1 = do_utf8 ? strlen(s1) : pref_len - pref0_len;
2136               char *s2 = do_utf8 ?
2137                 pv_uni_display(dsv2, (U8*)locinput,
2138                                PL_regeol - locinput, 60, 0) :
2139                 locinput;
2140               int len2 = do_utf8 ? strlen(s2) : l;
2141               PerlIO_printf(Perl_debug_log,
2142                             "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n",
2143                             (IV)(locinput - PL_bostr),
2144                             PL_colors[4],
2145                             len0, s0,
2146                             PL_colors[5],
2147                             PL_colors[2],
2148                             len1, s1,
2149                             PL_colors[3],
2150                             (docolor ? "" : "> <"),
2151                             PL_colors[0],
2152                             len2, s2,
2153                             PL_colors[1],
2154                             15 - l - pref_len + 1,
2155                             "",
2156                             (IV)(scan - PL_regprogram), PL_regindent*2, "",
2157                             SvPVX(prop));
2158             }
2159         });
2160
2161         next = scan + NEXT_OFF(scan);
2162         if (next == scan)
2163             next = NULL;
2164
2165         switch (OP(scan)) {
2166         case BOL:
2167             if (locinput == PL_bostr || (PL_multiline &&
2168                 (nextchr || locinput < PL_regeol) && locinput[-1] == '\n') )
2169             {
2170                 /* regtill = regbol; */
2171                 break;
2172             }
2173             sayNO;
2174         case MBOL:
2175             if (locinput == PL_bostr ||
2176                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2177             {
2178                 break;
2179             }
2180             sayNO;
2181         case SBOL:
2182             if (locinput == PL_bostr)
2183                 break;
2184             sayNO;
2185         case GPOS:
2186             if (locinput == PL_reg_ganch)
2187                 break;
2188             sayNO;
2189         case EOL:
2190             if (PL_multiline)
2191                 goto meol;
2192             else
2193                 goto seol;
2194         case MEOL:
2195           meol:
2196             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2197                 sayNO;
2198             break;
2199         case SEOL:
2200           seol:
2201             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2202                 sayNO;
2203             if (PL_regeol - locinput > 1)
2204                 sayNO;
2205             break;
2206         case EOS:
2207             if (PL_regeol != locinput)
2208                 sayNO;
2209             break;
2210         case SANY:
2211             if (!nextchr && locinput >= PL_regeol)
2212                 sayNO;
2213             if (do_utf8) {
2214                 locinput += PL_utf8skip[nextchr];
2215                 if (locinput > PL_regeol)
2216                     sayNO;
2217                 nextchr = UCHARAT(locinput);
2218             }
2219             else
2220                 nextchr = UCHARAT(++locinput);
2221             break;
2222         case CANY:
2223             if (!nextchr && locinput >= PL_regeol)
2224                 sayNO;
2225             nextchr = UCHARAT(++locinput);
2226             break;
2227         case REG_ANY:
2228             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2229                 sayNO;
2230             if (do_utf8) {
2231                 locinput += PL_utf8skip[nextchr];
2232                 if (locinput > PL_regeol)
2233                     sayNO;
2234                 nextchr = UCHARAT(locinput);
2235             }
2236             else
2237                 nextchr = UCHARAT(++locinput);
2238             break;
2239         case EXACT:
2240             s = STRING(scan);
2241             ln = STR_LEN(scan);
2242             if (do_utf8 != (UTF!=0)) {
2243                 /* The target and the pattern have differing utf8ness. */
2244                 char *l = locinput;
2245                 char *e = s + ln;
2246                 STRLEN ulen;
2247
2248                 if (do_utf8) {
2249                     /* The target is utf8, the pattern is not utf8. */
2250                     while (s < e) {
2251                         if (l >= PL_regeol)
2252                              sayNO;
2253                         if (NATIVE_TO_UNI(*(U8*)s) !=
2254                             utf8_to_uvchr((U8*)l, &ulen))
2255                              sayNO;
2256                         l += ulen;
2257                         s ++;
2258                     }
2259                 }
2260                 else {
2261                     /* The target is not utf8, the pattern is utf8. */
2262                     while (s < e) {
2263                         if (l >= PL_regeol)
2264                             sayNO;
2265                         if (NATIVE_TO_UNI(*((U8*)l)) !=
2266                             utf8_to_uvchr((U8*)s, &ulen))
2267                             sayNO;
2268                         s += ulen;
2269                         l ++;
2270                     }
2271                 }
2272                 locinput = l;
2273                 nextchr = UCHARAT(locinput);
2274                 break;
2275             }
2276             /* The target and the pattern have the same utf8ness. */
2277             /* Inline the first character, for speed. */
2278             if (UCHARAT(s) != nextchr)
2279                 sayNO;
2280             if (PL_regeol - locinput < ln)
2281                 sayNO;
2282             if (ln > 1 && memNE(s, locinput, ln))
2283                 sayNO;
2284             locinput += ln;
2285             nextchr = UCHARAT(locinput);
2286             break;
2287         case EXACTFL:
2288             PL_reg_flags |= RF_tainted;
2289             /* FALL THROUGH */
2290         case EXACTF:
2291             s = STRING(scan);
2292             ln = STR_LEN(scan);
2293
2294             {
2295                 char *l = locinput;
2296                 char *e = s + ln;
2297                 U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
2298
2299                 if (do_utf8 != (UTF!=0)) {
2300                      /* The target and the pattern have differing utf8ness. */
2301                      STRLEN ulen1, ulen2;
2302                      UV cs, cl;
2303
2304                      if (do_utf8) {
2305                           /* The target is utf8, the pattern is not utf8. */
2306                           while (s < e) {
2307                                if (l >= PL_regeol)
2308                                     sayNO;
2309
2310                                cs = to_uni_fold(NATIVE_TO_UNI(*(U8*)s),
2311                                                 (U8*)s, &ulen1);
2312                                cl = utf8_to_uvchr((U8*)l, &ulen2);
2313
2314                                if (cs != cl) {
2315                                     cl = to_uni_fold(cl, (U8*)l, &ulen2);
2316                                     if (ulen1 != ulen2 || cs != cl)
2317                                          sayNO;
2318                                }
2319                                l += ulen1;
2320                                s ++;
2321                           }
2322                      }
2323                      else {
2324                           /* The target is not utf8, the pattern is utf8. */
2325                           while (s < e) {
2326                                if (l >= PL_regeol)
2327                                     sayNO;
2328
2329                                cs = utf8_to_uvchr((U8*)s, &ulen1);
2330
2331                                cl = to_uni_fold(NATIVE_TO_UNI(*(U8*)l),
2332                                                 (U8*)l, &ulen2);
2333
2334                                if (cs != cl) {
2335                                     cs = to_uni_fold(cs, (U8*)s, &ulen1);
2336                                     if (ulen1 != ulen2 || cs != cl)
2337                                          sayNO;
2338                                }
2339                                l ++;
2340                                s += ulen1;
2341                           }
2342                      }
2343                      locinput = l;
2344                      nextchr = UCHARAT(locinput);
2345                      break;
2346                 }
2347
2348                 if (do_utf8 && UTF) {
2349                      /* Both the target and the pattern are utf8. */
2350                      STRLEN ulen;
2351
2352                      while (s < e) {
2353                           if (l >= PL_regeol)
2354                                sayNO;
2355                           if (UTF8SKIP(s) != UTF8SKIP(l) ||
2356                               memNE(s, (char*)l, UTF8SKIP(s))) {
2357                                to_utf8_fold((U8*)l, tmpbuf, &ulen);
2358                                if (UTF8SKIP(s) != ulen ||
2359                                    memNE(s, (char*)tmpbuf, ulen))
2360                                     sayNO;
2361                           }
2362                           l += UTF8SKIP(l);
2363                           s += UTF8SKIP(s);
2364                      }
2365                      locinput = l;
2366                      nextchr = UCHARAT(locinput);
2367                      break;
2368                 }
2369             }
2370
2371             /* Neither the target and the pattern are utf8. */
2372
2373             /* Inline the first character, for speed. */
2374             if (UCHARAT(s) != nextchr &&
2375                 UCHARAT(s) != ((OP(scan) == EXACTF)
2376                                ? PL_fold : PL_fold_locale)[nextchr])
2377                 sayNO;
2378             if (PL_regeol - locinput < ln)
2379                 sayNO;
2380             if (ln > 1 && (OP(scan) == EXACTF
2381                            ? ibcmp(s, locinput, ln)
2382                            : ibcmp_locale(s, locinput, ln)))
2383                 sayNO;
2384             locinput += ln;
2385             nextchr = UCHARAT(locinput);
2386             break;
2387         case ANYOF:
2388             if (do_utf8) {
2389                 if (!reginclass(scan, (U8*)locinput, do_utf8))
2390                     sayNO;
2391                 if (locinput >= PL_regeol)
2392                     sayNO;
2393                 locinput += PL_utf8skip[nextchr];
2394                 nextchr = UCHARAT(locinput);
2395             }
2396             else {
2397                 if (nextchr < 0)
2398                     nextchr = UCHARAT(locinput);
2399                 if (!reginclass(scan, (U8*)locinput, do_utf8))
2400                     sayNO;
2401                 if (!nextchr && locinput >= PL_regeol)
2402                     sayNO;
2403                 nextchr = UCHARAT(++locinput);
2404             }
2405             break;
2406         case ALNUML:
2407             PL_reg_flags |= RF_tainted;
2408             /* FALL THROUGH */
2409         case ALNUM:
2410             if (!nextchr)
2411                 sayNO;
2412             if (do_utf8) {
2413                 LOAD_UTF8_CHARCLASS(alnum,"a");
2414                 if (!(OP(scan) == ALNUM
2415                       ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
2416                       : isALNUM_LC_utf8((U8*)locinput)))
2417                 {
2418                     sayNO;
2419                 }
2420                 locinput += PL_utf8skip[nextchr];
2421                 nextchr = UCHARAT(locinput);
2422                 break;
2423             }
2424             if (!(OP(scan) == ALNUM
2425                   ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
2426                 sayNO;
2427             nextchr = UCHARAT(++locinput);
2428             break;
2429         case NALNUML:
2430             PL_reg_flags |= RF_tainted;
2431             /* FALL THROUGH */
2432         case NALNUM:
2433             if (!nextchr && locinput >= PL_regeol)
2434                 sayNO;
2435             if (do_utf8) {
2436                 LOAD_UTF8_CHARCLASS(alnum,"a");
2437                 if (OP(scan) == NALNUM
2438                     ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
2439                     : isALNUM_LC_utf8((U8*)locinput))
2440                 {
2441                     sayNO;
2442                 }
2443                 locinput += PL_utf8skip[nextchr];
2444                 nextchr = UCHARAT(locinput);
2445                 break;
2446             }
2447             if (OP(scan) == NALNUM
2448                 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
2449                 sayNO;
2450             nextchr = UCHARAT(++locinput);
2451             break;
2452         case BOUNDL:
2453         case NBOUNDL:
2454             PL_reg_flags |= RF_tainted;
2455             /* FALL THROUGH */
2456         case BOUND:
2457         case NBOUND:
2458             /* was last char in word? */
2459             if (do_utf8) {
2460                 if (locinput == PL_bostr)
2461                     ln = '\n';
2462                 else {
2463                     U8 *r = reghop((U8*)locinput, -1);
2464
2465                     ln = utf8n_to_uvchr(r, s - (char*)r, 0, 0);
2466                 }
2467                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
2468                     ln = isALNUM_uni(ln);
2469                     LOAD_UTF8_CHARCLASS(alnum,"a");
2470                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
2471                 }
2472                 else {
2473                     ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
2474                     n = isALNUM_LC_utf8((U8*)locinput);
2475                 }
2476             }
2477             else {
2478                 ln = (locinput != PL_bostr) ?
2479                     UCHARAT(locinput - 1) : '\n';
2480                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
2481                     ln = isALNUM(ln);
2482                     n = isALNUM(nextchr);
2483                 }
2484                 else {
2485                     ln = isALNUM_LC(ln);
2486                     n = isALNUM_LC(nextchr);
2487                 }
2488             }
2489             if (((!ln) == (!n)) == (OP(scan) == BOUND ||
2490                                     OP(scan) == BOUNDL))
2491                     sayNO;
2492             break;
2493         case SPACEL:
2494             PL_reg_flags |= RF_tainted;
2495             /* FALL THROUGH */
2496         case SPACE:
2497             if (!nextchr)
2498                 sayNO;
2499             if (do_utf8) {
2500                 if (UTF8_IS_CONTINUED(nextchr)) {
2501                     LOAD_UTF8_CHARCLASS(space," ");
2502                     if (!(OP(scan) == SPACE
2503                           ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
2504                           : isSPACE_LC_utf8((U8*)locinput)))
2505                     {
2506                         sayNO;
2507                     }
2508                     locinput += PL_utf8skip[nextchr];
2509                     nextchr = UCHARAT(locinput);
2510                     break;
2511                 }
2512                 if (!(OP(scan) == SPACE
2513                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
2514                     sayNO;
2515                 nextchr = UCHARAT(++locinput);
2516             }
2517             else {
2518                 if (!(OP(scan) == SPACE
2519                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
2520                     sayNO;
2521                 nextchr = UCHARAT(++locinput);
2522             }
2523             break;
2524         case NSPACEL:
2525             PL_reg_flags |= RF_tainted;
2526             /* FALL THROUGH */
2527         case NSPACE:
2528             if (!nextchr && locinput >= PL_regeol)
2529                 sayNO;
2530             if (do_utf8) {
2531                 LOAD_UTF8_CHARCLASS(space," ");
2532                 if (OP(scan) == NSPACE
2533                     ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
2534                     : isSPACE_LC_utf8((U8*)locinput))
2535                 {
2536                     sayNO;
2537                 }
2538                 locinput += PL_utf8skip[nextchr];
2539                 nextchr = UCHARAT(locinput);
2540                 break;
2541             }
2542             if (OP(scan) == NSPACE
2543                 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
2544                 sayNO;
2545             nextchr = UCHARAT(++locinput);
2546             break;
2547         case DIGITL:
2548             PL_reg_flags |= RF_tainted;
2549             /* FALL THROUGH */
2550         case DIGIT:
2551             if (!nextchr)
2552                 sayNO;
2553             if (do_utf8) {
2554                 LOAD_UTF8_CHARCLASS(digit,"0");
2555                 if (!(OP(scan) == DIGIT
2556                       ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
2557                       : isDIGIT_LC_utf8((U8*)locinput)))
2558                 {
2559                     sayNO;
2560                 }
2561                 locinput += PL_utf8skip[nextchr];
2562                 nextchr = UCHARAT(locinput);
2563                 break;
2564             }
2565             if (!(OP(scan) == DIGIT
2566                   ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
2567                 sayNO;
2568             nextchr = UCHARAT(++locinput);
2569             break;
2570         case NDIGITL:
2571             PL_reg_flags |= RF_tainted;
2572             /* FALL THROUGH */
2573         case NDIGIT:
2574             if (!nextchr && locinput >= PL_regeol)
2575                 sayNO;
2576             if (do_utf8) {
2577                 LOAD_UTF8_CHARCLASS(digit,"0");
2578                 if (OP(scan) == NDIGIT
2579                     ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
2580                     : isDIGIT_LC_utf8((U8*)locinput))
2581                 {
2582                     sayNO;
2583                 }
2584                 locinput += PL_utf8skip[nextchr];
2585                 nextchr = UCHARAT(locinput);
2586                 break;
2587             }
2588             if (OP(scan) == NDIGIT
2589                 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
2590                 sayNO;
2591             nextchr = UCHARAT(++locinput);
2592             break;
2593         case CLUMP:
2594             LOAD_UTF8_CHARCLASS(mark,"~");
2595             if (locinput >= PL_regeol ||
2596                 swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
2597                 sayNO;
2598             locinput += PL_utf8skip[nextchr];
2599             while (locinput < PL_regeol &&
2600                    swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
2601                 locinput += UTF8SKIP(locinput);
2602             if (locinput > PL_regeol)
2603                 sayNO;
2604             nextchr = UCHARAT(locinput);
2605             break;
2606         case REFFL:
2607             PL_reg_flags |= RF_tainted;
2608             /* FALL THROUGH */
2609         case REF:
2610         case REFF:
2611             n = ARG(scan);  /* which paren pair */
2612             ln = PL_regstartp[n];
2613             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
2614             if (*PL_reglastparen < n || ln == -1)
2615                 sayNO;                  /* Do not match unless seen CLOSEn. */
2616             if (ln == PL_regendp[n])
2617                 break;
2618
2619             s = PL_bostr + ln;
2620             if (do_utf8 && OP(scan) != REF) {   /* REF can do byte comparison */
2621                 char *l = locinput;
2622                 char *e = PL_bostr + PL_regendp[n];
2623                 /*
2624                  * Note that we can't do the "other character" lookup trick as
2625                  * in the 8-bit case (no pun intended) because in Unicode we
2626                  * have to map both upper and title case to lower case.
2627                  */
2628                 if (OP(scan) == REFF) {
2629                     STRLEN ulen1, ulen2;
2630                     U8 tmpbuf1[UTF8_MAXLEN_UCLC+1];
2631                     U8 tmpbuf2[UTF8_MAXLEN_UCLC+1];
2632                     while (s < e) {
2633                         if (l >= PL_regeol)
2634                             sayNO;
2635                         toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
2636                         toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
2637                         if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
2638                             sayNO;
2639                         s += ulen1;
2640                         l += ulen2;
2641                     }
2642                 }
2643                 locinput = l;
2644                 nextchr = UCHARAT(locinput);
2645                 break;
2646             }
2647
2648             /* Inline the first character, for speed. */
2649             if (UCHARAT(s) != nextchr &&
2650                 (OP(scan) == REF ||
2651                  (UCHARAT(s) != ((OP(scan) == REFF
2652                                   ? PL_fold : PL_fold_locale)[nextchr]))))
2653                 sayNO;
2654             ln = PL_regendp[n] - ln;
2655             if (locinput + ln > PL_regeol)
2656                 sayNO;
2657             if (ln > 1 && (OP(scan) == REF
2658                            ? memNE(s, locinput, ln)
2659                            : (OP(scan) == REFF
2660                               ? ibcmp(s, locinput, ln)
2661                               : ibcmp_locale(s, locinput, ln))))
2662                 sayNO;
2663             locinput += ln;
2664             nextchr = UCHARAT(locinput);
2665             break;
2666
2667         case NOTHING:
2668         case TAIL:
2669             break;
2670         case BACK:
2671             break;
2672         case EVAL:
2673         {
2674             dSP;
2675             OP_4tree *oop = PL_op;
2676             COP *ocurcop = PL_curcop;
2677             SV **ocurpad = PL_curpad;
2678             SV *ret;
2679
2680             n = ARG(scan);
2681             PL_op = (OP_4tree*)PL_regdata->data[n];
2682             DEBUG_r( PerlIO_printf(Perl_debug_log, "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
2683             PL_curpad = AvARRAY((AV*)PL_regdata->data[n + 2]);
2684             PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
2685
2686             {
2687                 SV **before = SP;
2688                 CALLRUNOPS(aTHX);                       /* Scalar context. */
2689                 SPAGAIN;
2690                 if (SP == before)
2691                     ret = Nullsv;   /* protect against empty (?{}) blocks. */
2692                 else {
2693                     ret = POPs;
2694                     PUTBACK;
2695                 }
2696             }
2697
2698             PL_op = oop;
2699             PL_curpad = ocurpad;
2700             PL_curcop = ocurcop;
2701             if (logical) {
2702                 if (logical == 2) {     /* Postponed subexpression. */
2703                     regexp *re;
2704                     MAGIC *mg = Null(MAGIC*);
2705                     re_cc_state state;
2706                     CHECKPOINT cp, lastcp;
2707
2708                     if(SvROK(ret) || SvRMAGICAL(ret)) {
2709                         SV *sv = SvROK(ret) ? SvRV(ret) : ret;
2710
2711                         if(SvMAGICAL(sv))
2712                             mg = mg_find(sv, PERL_MAGIC_qr);
2713                     }
2714                     if (mg) {
2715                         re = (regexp *)mg->mg_obj;
2716                         (void)ReREFCNT_inc(re);
2717                     }
2718                     else {
2719                         STRLEN len;
2720                         char *t = SvPV(ret, len);
2721                         PMOP pm;
2722                         char *oprecomp = PL_regprecomp;
2723                         I32 osize = PL_regsize;
2724                         I32 onpar = PL_regnpar;
2725
2726                         Zero(&pm, 1, PMOP);
2727                         re = CALLREGCOMP(aTHX_ t, t + len, &pm);
2728                         if (!(SvFLAGS(ret)
2729                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)))
2730                             sv_magic(ret,(SV*)ReREFCNT_inc(re),
2731                                         PERL_MAGIC_qr,0,0);
2732                         PL_regprecomp = oprecomp;
2733                         PL_regsize = osize;
2734                         PL_regnpar = onpar;
2735                     }
2736                     DEBUG_r(
2737                         PerlIO_printf(Perl_debug_log,
2738                                       "Entering embedded `%s%.60s%s%s'\n",
2739                                       PL_colors[0],
2740                                       re->precomp,
2741                                       PL_colors[1],
2742                                       (strlen(re->precomp) > 60 ? "..." : ""))
2743                         );
2744                     state.node = next;
2745                     state.prev = PL_reg_call_cc;
2746                     state.cc = PL_regcc;
2747                     state.re = PL_reg_re;
2748
2749                     PL_regcc = 0;
2750
2751                     cp = regcppush(0);  /* Save *all* the positions. */
2752                     REGCP_SET(lastcp);
2753                     cache_re(re);
2754                     state.ss = PL_savestack_ix;
2755                     *PL_reglastparen = 0;
2756                     *PL_reglastcloseparen = 0;
2757                     PL_reg_call_cc = &state;
2758                     PL_reginput = locinput;
2759
2760                     /* XXXX This is too dramatic a measure... */
2761                     PL_reg_maxiter = 0;
2762
2763                     if (regmatch(re->program + 1)) {
2764                         /* Even though we succeeded, we need to restore
2765                            global variables, since we may be wrapped inside
2766                            SUSPEND, thus the match may be not finished yet. */
2767
2768                         /* XXXX Do this only if SUSPENDed? */
2769                         PL_reg_call_cc = state.prev;
2770                         PL_regcc = state.cc;
2771                         PL_reg_re = state.re;
2772                         cache_re(PL_reg_re);
2773
2774                         /* XXXX This is too dramatic a measure... */
2775                         PL_reg_maxiter = 0;
2776
2777                         /* These are needed even if not SUSPEND. */
2778                         ReREFCNT_dec(re);
2779                         regcpblow(cp);
2780                         sayYES;
2781                     }
2782                     ReREFCNT_dec(re);
2783                     REGCP_UNWIND(lastcp);
2784                     regcppop();
2785                     PL_reg_call_cc = state.prev;
2786                     PL_regcc = state.cc;
2787                     PL_reg_re = state.re;
2788                     cache_re(PL_reg_re);
2789
2790                     /* XXXX This is too dramatic a measure... */
2791                     PL_reg_maxiter = 0;
2792
2793                     logical = 0;
2794                     sayNO;
2795                 }
2796                 sw = SvTRUE(ret);
2797                 logical = 0;
2798             }
2799             else
2800                 sv_setsv(save_scalar(PL_replgv), ret);
2801             break;
2802         }
2803         case OPEN:
2804             n = ARG(scan);  /* which paren pair */
2805             PL_reg_start_tmp[n] = locinput;
2806             if (n > PL_regsize)
2807                 PL_regsize = n;
2808             break;
2809         case CLOSE:
2810             n = ARG(scan);  /* which paren pair */
2811             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
2812             PL_regendp[n] = locinput - PL_bostr;
2813             if (n > *PL_reglastparen)
2814                 *PL_reglastparen = n;
2815             *PL_reglastcloseparen = n;
2816             break;
2817         case GROUPP:
2818             n = ARG(scan);  /* which paren pair */
2819             sw = (*PL_reglastparen >= n && PL_regendp[n] != -1);
2820             break;
2821         case IFTHEN:
2822             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
2823             if (sw)
2824                 next = NEXTOPER(NEXTOPER(scan));
2825             else {
2826                 next = scan + ARG(scan);
2827                 if (OP(next) == IFTHEN) /* Fake one. */
2828                     next = NEXTOPER(NEXTOPER(next));
2829             }
2830             break;
2831         case LOGICAL:
2832             logical = scan->flags;
2833             break;
2834 /*******************************************************************
2835  PL_regcc contains infoblock about the innermost (...)* loop, and
2836  a pointer to the next outer infoblock.
2837
2838  Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
2839
2840    1) After matching X, regnode for CURLYX is processed;
2841
2842    2) This regnode creates infoblock on the stack, and calls
2843       regmatch() recursively with the starting point at WHILEM node;
2844
2845    3) Each hit of WHILEM node tries to match A and Z (in the order
2846       depending on the current iteration, min/max of {min,max} and
2847       greediness).  The information about where are nodes for "A"
2848       and "Z" is read from the infoblock, as is info on how many times "A"
2849       was already matched, and greediness.
2850
2851    4) After A matches, the same WHILEM node is hit again.
2852
2853    5) Each time WHILEM is hit, PL_regcc is the infoblock created by CURLYX
2854       of the same pair.  Thus when WHILEM tries to match Z, it temporarily
2855       resets PL_regcc, since this Y(A)*Z can be a part of some other loop:
2856       as in (Y(A)*Z)*.  If Z matches, the automaton will hit the WHILEM node
2857       of the external loop.
2858
2859  Currently present infoblocks form a tree with a stem formed by PL_curcc
2860  and whatever it mentions via ->next, and additional attached trees
2861  corresponding to temporarily unset infoblocks as in "5" above.
2862
2863  In the following picture infoblocks for outer loop of
2864  (Y(A)*?Z)*?T are denoted O, for inner I.  NULL starting block
2865  is denoted by x.  The matched string is YAAZYAZT.  Temporarily postponed
2866  infoblocks are drawn below the "reset" infoblock.
2867
2868  In fact in the picture below we do not show failed matches for Z and T
2869  by WHILEM blocks.  [We illustrate minimal matches, since for them it is
2870  more obvious *why* one needs to *temporary* unset infoblocks.]
2871
2872   Matched       REx position    InfoBlocks      Comment
2873                 (Y(A)*?Z)*?T    x
2874                 Y(A)*?Z)*?T     x <- O
2875   Y             (A)*?Z)*?T      x <- O
2876   Y             A)*?Z)*?T       x <- O <- I
2877   YA            )*?Z)*?T        x <- O <- I
2878   YA            A)*?Z)*?T       x <- O <- I
2879   YAA           )*?Z)*?T        x <- O <- I
2880   YAA           Z)*?T           x <- O          # Temporary unset I
2881                                      I
2882
2883   YAAZ          Y(A)*?Z)*?T     x <- O
2884                                      I
2885
2886   YAAZY         (A)*?Z)*?T      x <- O
2887                                      I
2888
2889   YAAZY         A)*?Z)*?T       x <- O <- I
2890                                      I
2891
2892   YAAZYA        )*?Z)*?T        x <- O <- I
2893                                      I
2894
2895   YAAZYA        Z)*?T           x <- O          # Temporary unset I
2896                                      I,I
2897
2898   YAAZYAZ       )*?T            x <- O
2899                                      I,I
2900
2901   YAAZYAZ       T               x               # Temporary unset O
2902                                 O
2903                                 I,I
2904
2905   YAAZYAZT                      x
2906                                 O
2907                                 I,I
2908  *******************************************************************/
2909         case CURLYX: {
2910                 CURCUR cc;
2911                 CHECKPOINT cp = PL_savestack_ix;
2912                 /* No need to save/restore up to this paren */
2913                 I32 parenfloor = scan->flags;
2914
2915                 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
2916                     next += ARG(next);
2917                 cc.oldcc = PL_regcc;
2918                 PL_regcc = &cc;
2919                 /* XXXX Probably it is better to teach regpush to support
2920                    parenfloor > PL_regsize... */
2921                 if (parenfloor > *PL_reglastparen)
2922                     parenfloor = *PL_reglastparen; /* Pessimization... */
2923                 cc.parenfloor = parenfloor;
2924                 cc.cur = -1;
2925                 cc.min = ARG1(scan);
2926                 cc.max  = ARG2(scan);
2927                 cc.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
2928                 cc.next = next;
2929                 cc.minmod = minmod;
2930                 cc.lastloc = 0;
2931                 PL_reginput = locinput;
2932                 n = regmatch(PREVOPER(next));   /* start on the WHILEM */
2933                 regcpblow(cp);
2934                 PL_regcc = cc.oldcc;
2935                 saySAME(n);
2936             }
2937             /* NOT REACHED */
2938         case WHILEM: {
2939                 /*
2940                  * This is really hard to understand, because after we match
2941                  * what we're trying to match, we must make sure the rest of
2942                  * the REx is going to match for sure, and to do that we have
2943                  * to go back UP the parse tree by recursing ever deeper.  And
2944                  * if it fails, we have to reset our parent's current state
2945                  * that we can try again after backing off.
2946                  */
2947
2948                 CHECKPOINT cp, lastcp;
2949                 CURCUR* cc = PL_regcc;
2950                 char *lastloc = cc->lastloc; /* Detection of 0-len. */
2951
2952                 n = cc->cur + 1;        /* how many we know we matched */
2953                 PL_reginput = locinput;
2954
2955                 DEBUG_r(
2956                     PerlIO_printf(Perl_debug_log,
2957                                   "%*s  %ld out of %ld..%ld  cc=%lx\n",
2958                                   REPORT_CODE_OFF+PL_regindent*2, "",
2959                                   (long)n, (long)cc->min,
2960                                   (long)cc->max, (long)cc)
2961                     );
2962
2963                 /* If degenerate scan matches "", assume scan done. */
2964
2965                 if (locinput == cc->lastloc && n >= cc->min) {
2966                     PL_regcc = cc->oldcc;
2967                     if (PL_regcc)
2968                         ln = PL_regcc->cur;
2969                     DEBUG_r(
2970                         PerlIO_printf(Perl_debug_log,
2971                            "%*s  empty match detected, try continuation...\n",
2972                            REPORT_CODE_OFF+PL_regindent*2, "")
2973                         );
2974                     if (regmatch(cc->next))
2975                         sayYES;
2976                     if (PL_regcc)
2977                         PL_regcc->cur = ln;
2978                     PL_regcc = cc;
2979                     sayNO;
2980                 }
2981
2982                 /* First just match a string of min scans. */
2983
2984                 if (n < cc->min) {
2985                     cc->cur = n;
2986                     cc->lastloc = locinput;
2987                     if (regmatch(cc->scan))
2988                         sayYES;
2989                     cc->cur = n - 1;
2990                     cc->lastloc = lastloc;
2991                     sayNO;
2992                 }
2993
2994                 if (scan->flags) {
2995                     /* Check whether we already were at this position.
2996                         Postpone detection until we know the match is not
2997                         *that* much linear. */
2998                 if (!PL_reg_maxiter) {
2999                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
3000                     PL_reg_leftiter = PL_reg_maxiter;
3001                 }
3002                 if (PL_reg_leftiter-- == 0) {
3003                     I32 size = (PL_reg_maxiter + 7)/8;
3004                     if (PL_reg_poscache) {
3005                         if (PL_reg_poscache_size < size) {
3006                             Renew(PL_reg_poscache, size, char);
3007                             PL_reg_poscache_size = size;
3008                         }
3009                         Zero(PL_reg_poscache, size, char);
3010                     }
3011                     else {
3012                         PL_reg_poscache_size = size;
3013                         Newz(29, PL_reg_poscache, size, char);
3014                     }
3015                     DEBUG_r(
3016                         PerlIO_printf(Perl_debug_log,
3017               "%sDetected a super-linear match, switching on caching%s...\n",
3018                                       PL_colors[4], PL_colors[5])
3019                         );
3020                 }
3021                 if (PL_reg_leftiter < 0) {
3022                     I32 o = locinput - PL_bostr, b;
3023
3024                     o = (scan->flags & 0xf) - 1 + o * (scan->flags>>4);
3025                     b = o % 8;
3026                     o /= 8;
3027                     if (PL_reg_poscache[o] & (1<<b)) {
3028                     DEBUG_r(
3029                         PerlIO_printf(Perl_debug_log,
3030                                       "%*s  already tried at this position...\n",
3031                                       REPORT_CODE_OFF+PL_regindent*2, "")
3032                         );
3033                         sayNO_SILENT;
3034                     }
3035                     PL_reg_poscache[o] |= (1<<b);
3036                 }
3037                 }
3038
3039                 /* Prefer next over scan for minimal matching. */
3040
3041                 if (cc->minmod) {
3042                     PL_regcc = cc->oldcc;
3043                     if (PL_regcc)
3044                         ln = PL_regcc->cur;
3045                     cp = regcppush(cc->parenfloor);
3046                     REGCP_SET(lastcp);
3047                     if (regmatch(cc->next)) {
3048                         regcpblow(cp);
3049                         sayYES; /* All done. */
3050                     }
3051                     REGCP_UNWIND(lastcp);
3052                     regcppop();
3053                     if (PL_regcc)
3054                         PL_regcc->cur = ln;
3055                     PL_regcc = cc;
3056
3057                     if (n >= cc->max) { /* Maximum greed exceeded? */
3058                         if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3059                             && !(PL_reg_flags & RF_warned)) {
3060                             PL_reg_flags |= RF_warned;
3061                             Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
3062                                  "Complex regular subexpression recursion",
3063                                  REG_INFTY - 1);
3064                         }
3065                         sayNO;
3066                     }
3067
3068                     DEBUG_r(
3069                         PerlIO_printf(Perl_debug_log,
3070                                       "%*s  trying longer...\n",
3071                                       REPORT_CODE_OFF+PL_regindent*2, "")
3072                         );
3073                     /* Try scanning more and see if it helps. */
3074                     PL_reginput = locinput;
3075                     cc->cur = n;
3076                     cc->lastloc = locinput;
3077                     cp = regcppush(cc->parenfloor);
3078                     REGCP_SET(lastcp);
3079                     if (regmatch(cc->scan)) {
3080                         regcpblow(cp);
3081                         sayYES;
3082                     }
3083                     REGCP_UNWIND(lastcp);
3084                     regcppop();
3085                     cc->cur = n - 1;
3086                     cc->lastloc = lastloc;
3087                     sayNO;
3088                 }
3089
3090                 /* Prefer scan over next for maximal matching. */
3091
3092                 if (n < cc->max) {      /* More greed allowed? */
3093                     cp = regcppush(cc->parenfloor);
3094                     cc->cur = n;
3095                     cc->lastloc = locinput;
3096                     REGCP_SET(lastcp);
3097                     if (regmatch(cc->scan)) {
3098                         regcpblow(cp);
3099                         sayYES;
3100                     }
3101                     REGCP_UNWIND(lastcp);
3102                     regcppop();         /* Restore some previous $<digit>s? */
3103                     PL_reginput = locinput;
3104                     DEBUG_r(
3105                         PerlIO_printf(Perl_debug_log,
3106                                       "%*s  failed, try continuation...\n",
3107                                       REPORT_CODE_OFF+PL_regindent*2, "")
3108                         );
3109                 }
3110                 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3111                         && !(PL_reg_flags & RF_warned)) {
3112                     PL_reg_flags |= RF_warned;
3113                     Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
3114                          "Complex regular subexpression recursion",
3115                          REG_INFTY - 1);
3116                 }
3117
3118                 /* Failed deeper matches of scan, so see if this one works. */
3119                 PL_regcc = cc->oldcc;
3120                 if (PL_regcc)
3121                     ln = PL_regcc->cur;
3122                 if (regmatch(cc->next))
3123                     sayYES;
3124                 if (PL_regcc)
3125                     PL_regcc->cur = ln;
3126                 PL_regcc = cc;
3127                 cc->cur = n - 1;
3128                 cc->lastloc = lastloc;
3129                 sayNO;
3130             }
3131             /* NOT REACHED */
3132         case BRANCHJ:
3133             next = scan + ARG(scan);
3134             if (next == scan)
3135                 next = NULL;
3136             inner = NEXTOPER(NEXTOPER(scan));
3137             goto do_branch;
3138         case BRANCH:
3139             inner = NEXTOPER(scan);
3140           do_branch:
3141             {
3142                 c1 = OP(scan);
3143                 if (OP(next) != c1)     /* No choice. */
3144                     next = inner;       /* Avoid recursion. */
3145                 else {
3146                     I32 lastparen = *PL_reglastparen;
3147                     I32 unwind1;
3148                     re_unwind_branch_t *uw;
3149
3150                     /* Put unwinding data on stack */
3151                     unwind1 = SSNEWt(1,re_unwind_branch_t);
3152                     uw = SSPTRt(unwind1,re_unwind_branch_t);
3153                     uw->prev = unwind;
3154                     unwind = unwind1;
3155                     uw->type = ((c1 == BRANCH)
3156                                 ? RE_UNWIND_BRANCH
3157                                 : RE_UNWIND_BRANCHJ);
3158                     uw->lastparen = lastparen;
3159                     uw->next = next;
3160                     uw->locinput = locinput;
3161                     uw->nextchr = nextchr;
3162 #ifdef DEBUGGING
3163                     uw->regindent = ++PL_regindent;
3164 #endif
3165
3166                     REGCP_SET(uw->lastcp);
3167
3168                     /* Now go into the first branch */
3169                     next = inner;
3170                 }
3171             }
3172             break;
3173         case MINMOD:
3174             minmod = 1;
3175             break;
3176         case CURLYM:
3177         {
3178             I32 l = 0;
3179             CHECKPOINT lastcp;
3180
3181             /* We suppose that the next guy does not need
3182                backtracking: in particular, it is of constant length,
3183                and has no parenths to influence future backrefs. */
3184             ln = ARG1(scan);  /* min to match */
3185             n  = ARG2(scan);  /* max to match */
3186             paren = scan->flags;
3187             if (paren) {
3188                 if (paren > PL_regsize)
3189                     PL_regsize = paren;
3190                 if (paren > *PL_reglastparen)
3191                     *PL_reglastparen = paren;
3192             }
3193             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3194             if (paren)
3195                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
3196             PL_reginput = locinput;
3197             if (minmod) {
3198                 minmod = 0;
3199                 if (ln && regrepeat_hard(scan, ln, &l) < ln)
3200                     sayNO;
3201                 /* if we matched something zero-length we don't need to
3202                    backtrack - capturing parens are already defined, so
3203                    the caveat in the maximal case doesn't apply
3204
3205                    XXXX if ln == 0, we can redo this check first time
3206                    through the following loop
3207                 */
3208                 if (ln && l == 0)
3209                     n = ln;     /* don't backtrack */
3210                 locinput = PL_reginput;
3211                 if (HAS_TEXT(next) || JUMPABLE(next)) {
3212                     regnode *text_node = next;
3213
3214                     if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
3215
3216                     if (! HAS_TEXT(text_node)) c1 = c2 = -1000;
3217                     else {
3218                         if (PL_regkind[(U8)OP(text_node)] == REF) {
3219                             I32 n, ln;
3220                             n = ARG(text_node);  /* which paren pair */
3221                             ln = PL_regstartp[n];
3222                             /* assume yes if we haven't seen CLOSEn */
3223                             if (
3224                                 *PL_reglastparen < n ||
3225                                 ln == -1 ||
3226                                 ln == PL_regendp[n]
3227                             ) {
3228                                 c1 = c2 = -1000;
3229                                 goto assume_ok_MM;
3230                             }
3231                             c1 = *(PL_bostr + ln);
3232                         }
3233                         else { c1 = (U8)*STRING(text_node); }
3234                         if (OP(text_node) == EXACTF || OP(text_node) == REFF)
3235                             c2 = PL_fold[c1];
3236                         else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
3237                             c2 = PL_fold_locale[c1];
3238                         else
3239                             c2 = c1;
3240                     }
3241                 }
3242                 else
3243                     c1 = c2 = -1000;
3244             assume_ok_MM:
3245                 REGCP_SET(lastcp);
3246                 /* This may be improved if l == 0.  */
3247                 while (n >= ln || (n == REG_INFTY && ln > 0 && l)) { /* ln overflow ? */
3248                     /* If it could work, try it. */
3249                     if (c1 == -1000 ||
3250                         UCHARAT(PL_reginput) == c1 ||
3251                         UCHARAT(PL_reginput) == c2)
3252                     {
3253                         if (paren) {
3254                             if (ln) {
3255                                 PL_regstartp[paren] =
3256                                     HOPc(PL_reginput, -l) - PL_bostr;
3257                                 PL_regendp[paren] = PL_reginput - PL_bostr;
3258                             }
3259                             else
3260                                 PL_regendp[paren] = -1;
3261                         }
3262                         if (regmatch(next))
3263                             sayYES;
3264                         REGCP_UNWIND(lastcp);
3265                     }
3266                     /* Couldn't or didn't -- move forward. */
3267                     PL_reginput = locinput;
3268                     if (regrepeat_hard(scan, 1, &l)) {
3269                         ln++;
3270                         locinput = PL_reginput;
3271                     }
3272                     else
3273                         sayNO;
3274                 }
3275             }
3276             else {
3277                 n = regrepeat_hard(scan, n, &l);
3278                 /* if we matched something zero-length we don't need to
3279                    backtrack, unless the minimum count is zero and we
3280                    are capturing the result - in that case the capture
3281                    being defined or not may affect later execution
3282                 */
3283                 if (n != 0 && l == 0 && !(paren && ln == 0))
3284                     ln = n;     /* don't backtrack */
3285                 locinput = PL_reginput;
3286                 DEBUG_r(
3287                     PerlIO_printf(Perl_debug_log,
3288                                   "%*s  matched %"IVdf" times, len=%"IVdf"...\n",
3289                                   (int)(REPORT_CODE_OFF+PL_regindent*2), "",
3290                                   (IV) n, (IV)l)
3291                     );
3292                 if (n >= ln) {
3293                     if (HAS_TEXT(next) || JUMPABLE(next)) {
3294                         regnode *text_node = next;
3295
3296                         if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
3297
3298                         if (! HAS_TEXT(text_node)) c1 = c2 = -1000;
3299                         else {
3300                             if (PL_regkind[(U8)OP(text_node)] == REF) {
3301                                 I32 n, ln;
3302                                 n = ARG(text_node);  /* which paren pair */
3303                                 ln = PL_regstartp[n];
3304                                 /* assume yes if we haven't seen CLOSEn */
3305                                 if (
3306                                     *PL_reglastparen < n ||
3307                                     ln == -1 ||
3308                                     ln == PL_regendp[n]
3309                                 ) {
3310                                     c1 = c2 = -1000;
3311                                     goto assume_ok_REG;
3312                                 }
3313                                 c1 = *(PL_bostr + ln);
3314                             }
3315                             else { c1 = (U8)*STRING(text_node); }
3316
3317                             if (OP(text_node) == EXACTF || OP(text_node) == REFF)
3318                                 c2 = PL_fold[c1];
3319                             else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
3320                                 c2 = PL_fold_locale[c1];
3321                             else
3322                                 c2 = c1;
3323                         }
3324                     }
3325                     else
3326                         c1 = c2 = -1000;
3327                 }
3328             assume_ok_REG:
3329                 REGCP_SET(lastcp);
3330                 while (n >= ln) {
3331                     /* If it could work, try it. */
3332                     if (c1 == -1000 ||
3333                         UCHARAT(PL_reginput) == c1 ||
3334                         UCHARAT(PL_reginput) == c2)
3335                     {
3336                         DEBUG_r(
3337                                 PerlIO_printf(Perl_debug_log,
3338                                               "%*s  trying tail with n=%"IVdf"...\n",
3339                                               (int)(REPORT_CODE_OFF+PL_regindent*2), "", (IV)n)
3340                             );
3341                         if (paren) {
3342                             if (n) {
3343                                 PL_regstartp[paren] = HOPc(PL_reginput, -l) - PL_bostr;
3344                                 PL_regendp[paren] = PL_reginput - PL_bostr;
3345                             }
3346                             else
3347                                 PL_regendp[paren] = -1;
3348                         }
3349                         if (regmatch(next))
3350                             sayYES;
3351                         REGCP_UNWIND(lastcp);
3352                     }
3353                     /* Couldn't or didn't -- back up. */
3354                     n--;
3355                     locinput = HOPc(locinput, -l);
3356                     PL_reginput = locinput;
3357                 }
3358             }
3359             sayNO;
3360             break;
3361         }
3362         case CURLYN:
3363             paren = scan->flags;        /* Which paren to set */
3364             if (paren > PL_regsize)
3365                 PL_regsize = paren;
3366             if (paren > *PL_reglastparen)
3367                 *PL_reglastparen = paren;
3368             ln = ARG1(scan);  /* min to match */
3369             n  = ARG2(scan);  /* max to match */
3370             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
3371             goto repeat;
3372         case CURLY:
3373             paren = 0;
3374             ln = ARG1(scan);  /* min to match */
3375             n  = ARG2(scan);  /* max to match */
3376             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3377             goto repeat;
3378         case STAR:
3379             ln = 0;
3380             n = REG_INFTY;
3381             scan = NEXTOPER(scan);
3382             paren = 0;
3383             goto repeat;
3384         case PLUS:
3385             ln = 1;
3386             n = REG_INFTY;
3387             scan = NEXTOPER(scan);
3388             paren = 0;
3389           repeat:
3390             /*
3391             * Lookahead to avoid useless match attempts
3392             * when we know what character comes next.
3393             */
3394
3395             /*
3396             * Used to only do .*x and .*?x, but now it allows
3397             * for )'s, ('s and (?{ ... })'s to be in the way
3398             * of the quantifier and the EXACT-like node.  -- japhy
3399             */
3400
3401             if (HAS_TEXT(next) || JUMPABLE(next)) {
3402                 U8 *s;
3403                 regnode *text_node = next;
3404
3405                 if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
3406
3407                 if (! HAS_TEXT(text_node)) c1 = c2 = -1000;
3408                 else {
3409                     if (PL_regkind[(U8)OP(text_node)] == REF) {
3410                         I32 n, ln;
3411                         n = ARG(text_node);  /* which paren pair */
3412                         ln = PL_regstartp[n];
3413                         /* assume yes if we haven't seen CLOSEn */
3414                         if (
3415                             *PL_reglastparen < n ||
3416                             ln == -1 ||
3417                             ln == PL_regendp[n]
3418                         ) {
3419                             c1 = c2 = -1000;
3420                             goto assume_ok_easy;
3421                         }
3422                         s = (U8*)PL_bostr + ln;
3423                     }
3424                     else { s = (U8*)STRING(text_node); }
3425
3426                     if (!UTF) {
3427                         c2 = c1 = *s;
3428                         if (OP(text_node) == EXACTF || OP(text_node) == REFF)
3429                             c2 = PL_fold[c1];
3430                         else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
3431                             c2 = PL_fold_locale[c1];
3432                     }
3433                     else { /* UTF */
3434                         if (OP(text_node) == EXACTF || OP(text_node) == REFF) {
3435                              STRLEN ulen1, ulen2;
3436                              U8 tmpbuf1[UTF8_MAXLEN_UCLC+1];
3437                              U8 tmpbuf2[UTF8_MAXLEN_UCLC+1];
3438
3439                              to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
3440                              to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
3441
3442                              c1 = utf8_to_uvuni(tmpbuf1, 0);
3443                              c2 = utf8_to_uvuni(tmpbuf2, 0);
3444                         }
3445                         else {
3446                             c2 = c1 = utf8_to_uvchr(s, NULL);
3447                         }
3448                     }
3449                 }
3450             }
3451             else
3452                 c1 = c2 = -1000;
3453         assume_ok_easy:
3454             PL_reginput = locinput;
3455             if (minmod) {
3456                 CHECKPOINT lastcp;
3457                 minmod = 0;
3458                 if (ln && regrepeat(scan, ln) < ln)
3459                     sayNO;
3460                 locinput = PL_reginput;
3461                 REGCP_SET(lastcp);
3462                 if (c1 != -1000) {
3463                     char *e; /* Should not check after this */
3464                     char *old = locinput;
3465
3466                     if  (n == REG_INFTY) {
3467                         e = PL_regeol - 1;
3468                         if (do_utf8)
3469                             while (UTF8_IS_CONTINUATION(*(U8*)e))
3470                                 e--;
3471                     }
3472                     else if (do_utf8) {
3473                         int m = n - ln;
3474                         for (e = locinput;
3475                              m >0 && e + UTF8SKIP(e) <= PL_regeol; m--)
3476                             e += UTF8SKIP(e);
3477                     }
3478                     else {
3479                         e = locinput + n - ln;
3480                         if (e >= PL_regeol)
3481                             e = PL_regeol - 1;
3482                     }
3483                     while (1) {
3484                         int count;
3485                         /* Find place 'next' could work */
3486                         if (!do_utf8) {
3487                             if (c1 == c2) {
3488                                 while (locinput <= e &&
3489                                        UCHARAT(locinput) != c1)
3490                                     locinput++;
3491                             } else {
3492                                 while (locinput <= e
3493                                        && UCHARAT(locinput) != c1
3494                                        && UCHARAT(locinput) != c2)
3495                                     locinput++;
3496                             }
3497                             count = locinput - old;
3498                         }
3499                         else {
3500                             STRLEN len;
3501                             if (c1 == c2) {
3502                                 for (count = 0;
3503                                      locinput <= e &&
3504                                          utf8_to_uvchr((U8*)locinput, &len) != c1;
3505                                      count++)
3506                                     locinput += len;
3507
3508                             } else {
3509                                 for (count = 0; locinput <= e; count++) {
3510                                     UV c = utf8_to_uvchr((U8*)locinput, &len);
3511                                     if (c == c1 || c == c2)
3512                                         break;
3513                                     locinput += len;
3514                                 }
3515                             }
3516                         }
3517                         if (locinput > e)
3518                             sayNO;
3519                         /* PL_reginput == old now */
3520                         if (locinput != old) {
3521                             ln = 1;     /* Did some */
3522                             if (regrepeat(scan, count) < count)
3523                                 sayNO;
3524                         }
3525                         /* PL_reginput == locinput now */
3526                         TRYPAREN(paren, ln, locinput);
3527                         PL_reginput = locinput; /* Could be reset... */
3528                         REGCP_UNWIND(lastcp);
3529                         /* Couldn't or didn't -- move forward. */
3530                         old = locinput;
3531                         if (do_utf8)
3532                             locinput += UTF8SKIP(locinput);
3533                         else
3534                             locinput++;
3535                     }
3536                 }
3537                 else
3538                 while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */
3539                     UV c;
3540                     if (c1 != -1000) {
3541                         if (do_utf8)
3542                             c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3543                         else
3544                             c = UCHARAT(PL_reginput);
3545                         /* If it could work, try it. */
3546                         if (c == c1 || c == c2)
3547                         {
3548                             TRYPAREN(paren, n, PL_reginput);
3549                             REGCP_UNWIND(lastcp);
3550                         }
3551                     }
3552                     /* If it could work, try it. */
3553                     else if (c1 == -1000)
3554                     {
3555                         TRYPAREN(paren, n, PL_reginput);
3556                         REGCP_UNWIND(lastcp);
3557                     }
3558                     /* Couldn't or didn't -- move forward. */
3559                     PL_reginput = locinput;
3560                     if (regrepeat(scan, 1)) {
3561                         ln++;
3562                         locinput = PL_reginput;
3563                     }
3564                     else
3565                         sayNO;
3566                 }
3567             }
3568             else {
3569                 CHECKPOINT lastcp;
3570                 n = regrepeat(scan, n);
3571                 locinput = PL_reginput;
3572                 if (ln < n && PL_regkind[(U8)OP(next)] == EOL &&
3573                     (!PL_multiline  || OP(next) == SEOL || OP(next) == EOS)) {
3574                     ln = n;                     /* why back off? */
3575                     /* ...because $ and \Z can match before *and* after
3576                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
3577                        We should back off by one in this case. */
3578                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
3579                         ln--;
3580                 }
3581                 REGCP_SET(lastcp);
3582                 if (paren) {
3583                     UV c = 0;
3584                     while (n >= ln) {
3585                         if (c1 != -1000) {
3586                             if (do_utf8)
3587                                 c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3588                             else
3589                                 c = UCHARAT(PL_reginput);
3590                         }
3591                         /* If it could work, try it. */
3592                         if (c1 == -1000 || c == c1 || c == c2)
3593                             {
3594                                 TRYPAREN(paren, n, PL_reginput);
3595                                 REGCP_UNWIND(lastcp);
3596                             }
3597                         /* Couldn't or didn't -- back up. */
3598                         n--;
3599                         PL_reginput = locinput = HOPc(locinput, -1);
3600                     }
3601                 }
3602                 else {
3603                     UV c = 0;
3604                     while (n >= ln) {
3605                         if (c1 != -1000) {
3606                             if (do_utf8)
3607                                 c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3608                             else
3609                                 c = UCHARAT(PL_reginput);
3610                         }
3611                         /* If it could work, try it. */
3612                         if (c1 == -1000 || c == c1 || c == c2)
3613                             {
3614                                 TRYPAREN(paren, n, PL_reginput);
3615                                 REGCP_UNWIND(lastcp);
3616                             }
3617                         /* Couldn't or didn't -- back up. */
3618                         n--;
3619                         PL_reginput = locinput = HOPc(locinput, -1);
3620                     }
3621                 }
3622             }
3623             sayNO;
3624             break;
3625         case END:
3626             if (PL_reg_call_cc) {
3627                 re_cc_state *cur_call_cc = PL_reg_call_cc;
3628                 CURCUR *cctmp = PL_regcc;
3629                 regexp *re = PL_reg_re;
3630                 CHECKPOINT cp, lastcp;
3631
3632                 cp = regcppush(0);      /* Save *all* the positions. */
3633                 REGCP_SET(lastcp);
3634                 regcp_set_to(PL_reg_call_cc->ss); /* Restore parens of
3635                                                     the caller. */
3636                 PL_reginput = locinput; /* Make position available to
3637                                            the callcc. */
3638                 cache_re(PL_reg_call_cc->re);
3639                 PL_regcc = PL_reg_call_cc->cc;
3640                 PL_reg_call_cc = PL_reg_call_cc->prev;
3641                 if (regmatch(cur_call_cc->node)) {
3642                     PL_reg_call_cc = cur_call_cc;
3643                     regcpblow(cp);
3644                     sayYES;
3645                 }
3646                 REGCP_UNWIND(lastcp);
3647                 regcppop();
3648                 PL_reg_call_cc = cur_call_cc;
3649                 PL_regcc = cctmp;
3650                 PL_reg_re = re;
3651                 cache_re(re);
3652
3653                 DEBUG_r(
3654                     PerlIO_printf(Perl_debug_log,
3655                                   "%*s  continuation failed...\n",
3656                                   REPORT_CODE_OFF+PL_regindent*2, "")
3657                     );
3658                 sayNO_SILENT;
3659             }
3660             if (locinput < PL_regtill) {
3661                 DEBUG_r(PerlIO_printf(Perl_debug_log,
3662                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
3663                                       PL_colors[4],
3664                                       (long)(locinput - PL_reg_starttry),
3665                                       (long)(PL_regtill - PL_reg_starttry),
3666                                       PL_colors[5]));
3667                 sayNO_FINAL;            /* Cannot match: too short. */
3668             }
3669             PL_reginput = locinput;     /* put where regtry can find it */
3670             sayYES_FINAL;               /* Success! */
3671         case SUCCEED:
3672             PL_reginput = locinput;     /* put where regtry can find it */
3673             sayYES_LOUD;                /* Success! */
3674         case SUSPEND:
3675             n = 1;
3676             PL_reginput = locinput;
3677             goto do_ifmatch;
3678         case UNLESSM:
3679             n = 0;
3680             if (scan->flags) {
3681                 s = HOPBACKc(locinput, scan->flags);
3682                 if (!s)
3683                     goto say_yes;
3684                 PL_reginput = s;
3685             }
3686             else
3687                 PL_reginput = locinput;
3688             goto do_ifmatch;
3689         case IFMATCH:
3690             n = 1;
3691             if (scan->flags) {
3692                 s = HOPBACKc(locinput, scan->flags);
3693                 if (!s)
3694                     goto say_no;
3695                 PL_reginput = s;
3696             }
3697             else
3698                 PL_reginput = locinput;
3699
3700           do_ifmatch:
3701             inner = NEXTOPER(NEXTOPER(scan));
3702             if (regmatch(inner) != n) {
3703               say_no:
3704                 if (logical) {
3705                     logical = 0;
3706                     sw = 0;
3707                     goto do_longjump;
3708                 }
3709                 else
3710                     sayNO;
3711             }
3712           say_yes:
3713             if (logical) {
3714                 logical = 0;
3715                 sw = 1;
3716             }
3717             if (OP(scan) == SUSPEND) {
3718                 locinput = PL_reginput;
3719                 nextchr = UCHARAT(locinput);
3720             }
3721             /* FALL THROUGH. */
3722         case LONGJMP:
3723           do_longjump:
3724             next = scan + ARG(scan);
3725             if (next == scan)
3726                 next = NULL;
3727             break;
3728         default:
3729             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
3730                           PTR2UV(scan), OP(scan));
3731             Perl_croak(aTHX_ "regexp memory corruption");
3732         }
3733       reenter:
3734         scan = next;
3735     }
3736
3737     /*
3738     * We get here only if there's trouble -- normally "case END" is
3739     * the terminating point.
3740     */
3741     Perl_croak(aTHX_ "corrupted regexp pointers");
3742     /*NOTREACHED*/
3743     sayNO;
3744
3745 yes_loud:
3746     DEBUG_r(
3747         PerlIO_printf(Perl_debug_log,
3748                       "%*s  %scould match...%s\n",
3749                       REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],PL_colors[5])
3750         );
3751     goto yes;
3752 yes_final:
3753     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
3754                           PL_colors[4],PL_colors[5]));
3755 yes:
3756 #ifdef DEBUGGING
3757     PL_regindent--;
3758 #endif
3759
3760 #if 0                                   /* Breaks $^R */
3761     if (unwind)
3762         regcpblow(firstcp);
3763 #endif
3764     return 1;
3765
3766 no:
3767     DEBUG_r(
3768         PerlIO_printf(Perl_debug_log,
3769                       "%*s  %sfailed...%s\n",
3770                       REPORT_CODE_OFF+PL_regindent*2, "",PL_colors[4],PL_colors[5])
3771         );
3772     goto do_no;
3773 no_final:
3774 do_no:
3775     if (unwind) {
3776         re_unwind_t *uw = SSPTRt(unwind,re_unwind_t);
3777
3778         switch (uw->type) {
3779         case RE_UNWIND_BRANCH:
3780         case RE_UNWIND_BRANCHJ:
3781         {
3782             re_unwind_branch_t *uwb = &(uw->branch);
3783             I32 lastparen = uwb->lastparen;
3784
3785             REGCP_UNWIND(uwb->lastcp);
3786             for (n = *PL_reglastparen; n > lastparen; n--)
3787                 PL_regendp[n] = -1;
3788             *PL_reglastparen = n;
3789             scan = next = uwb->next;
3790             if ( !scan ||
3791                  OP(scan) != (uwb->type == RE_UNWIND_BRANCH
3792                               ? BRANCH : BRANCHJ) ) {           /* Failure */
3793                 unwind = uwb->prev;
3794 #ifdef DEBUGGING
3795                 PL_regindent--;
3796 #endif
3797                 goto do_no;
3798             }
3799             /* Have more choice yet.  Reuse the same uwb.  */
3800             /*SUPPRESS 560*/
3801             if ((n = (uwb->type == RE_UNWIND_BRANCH
3802                       ? NEXT_OFF(next) : ARG(next))))
3803                 next += n;
3804             else
3805                 next = NULL;    /* XXXX Needn't unwinding in this case... */
3806             uwb->next = next;
3807             next = NEXTOPER(scan);
3808             if (uwb->type == RE_UNWIND_BRANCHJ)
3809                 next = NEXTOPER(next);
3810             locinput = uwb->locinput;
3811             nextchr = uwb->nextchr;
3812 #ifdef DEBUGGING
3813             PL_regindent = uwb->regindent;
3814 #endif
3815
3816             goto reenter;
3817         }
3818         /* NOT REACHED */
3819         default:
3820             Perl_croak(aTHX_ "regexp unwind memory corruption");
3821         }
3822         /* NOT REACHED */
3823     }
3824 #ifdef DEBUGGING
3825     PL_regindent--;
3826 #endif
3827     return 0;
3828 }
3829
3830 /*
3831  - regrepeat - repeatedly match something simple, report how many
3832  */
3833 /*
3834  * [This routine now assumes that it will only match on things of length 1.
3835  * That was true before, but now we assume scan - reginput is the count,
3836  * rather than incrementing count on every character.  [Er, except utf8.]]
3837  */
3838 STATIC I32
3839 S_regrepeat(pTHX_ regnode *p, I32 max)
3840 {
3841     register char *scan;
3842     register I32 c;
3843     register char *loceol = PL_regeol;
3844     register I32 hardcount = 0;
3845     register bool do_utf8 = PL_reg_match_utf8;
3846
3847     scan = PL_reginput;
3848     if (max != REG_INFTY && max < loceol - scan)
3849       loceol = scan + max;
3850     switch (OP(p)) {
3851     case REG_ANY:
3852         if (do_utf8) {
3853             loceol = PL_regeol;
3854             while (scan < loceol && hardcount < max && *scan != '\n') {
3855                 scan += UTF8SKIP(scan);
3856                 hardcount++;
3857             }
3858         } else {
3859             while (scan < loceol && *scan != '\n')
3860                 scan++;
3861         }
3862         break;
3863     case SANY:
3864         scan = loceol;
3865         break;
3866     case CANY:
3867         scan = loceol;
3868         break;
3869     case EXACT:         /* length of string is 1 */
3870         c = (U8)*STRING(p);
3871         while (scan < loceol && UCHARAT(scan) == c)
3872             scan++;
3873         break;
3874     case EXACTF:        /* length of string is 1 */
3875         c = (U8)*STRING(p);
3876         while (scan < loceol &&
3877                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
3878             scan++;
3879         break;
3880     case EXACTFL:       /* length of string is 1 */
3881         PL_reg_flags |= RF_tainted;
3882         c = (U8)*STRING(p);
3883         while (scan < loceol &&
3884                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
3885             scan++;
3886         break;
3887     case ANYOF:
3888         if (do_utf8) {
3889             loceol = PL_regeol;
3890             while (hardcount < max && scan < loceol &&
3891                    reginclass(p, (U8*)scan, do_utf8)) {
3892                 scan += UTF8SKIP(scan);
3893                 hardcount++;
3894             }
3895         } else {
3896             while (scan < loceol && reginclass(p, (U8*)scan, do_utf8))
3897                 scan++;
3898         }
3899         break;
3900     case ALNUM:
3901         if (do_utf8) {
3902             loceol = PL_regeol;
3903             LOAD_UTF8_CHARCLASS(alnum,"a");
3904             while (hardcount < max && scan < loceol &&
3905                    swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
3906                 scan += UTF8SKIP(scan);
3907                 hardcount++;
3908             }
3909         } else {
3910             while (scan < loceol && isALNUM(*scan))
3911                 scan++;
3912         }
3913         break;
3914     case ALNUML:
3915         PL_reg_flags |= RF_tainted;
3916         if (do_utf8) {
3917             loceol = PL_regeol;
3918             while (hardcount < max && scan < loceol &&
3919                    isALNUM_LC_utf8((U8*)scan)) {
3920                 scan += UTF8SKIP(scan);
3921                 hardcount++;
3922             }
3923         } else {
3924             while (scan < loceol && isALNUM_LC(*scan))
3925                 scan++;
3926         }
3927         break;
3928     case NALNUM:
3929         if (do_utf8) {
3930             loceol = PL_regeol;
3931             LOAD_UTF8_CHARCLASS(alnum,"a");
3932             while (hardcount < max && scan < loceol &&
3933                    !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
3934                 scan += UTF8SKIP(scan);
3935                 hardcount++;
3936             }
3937         } else {
3938             while (scan < loceol && !isALNUM(*scan))
3939                 scan++;
3940         }
3941         break;
3942     case NALNUML:
3943         PL_reg_flags |= RF_tainted;
3944         if (do_utf8) {
3945             loceol = PL_regeol;
3946             while (hardcount < max && scan < loceol &&
3947                    !isALNUM_LC_utf8((U8*)scan)) {
3948                 scan += UTF8SKIP(scan);
3949                 hardcount++;
3950             }
3951         } else {
3952             while (scan < loceol && !isALNUM_LC(*scan))
3953                 scan++;
3954         }
3955         break;
3956     case SPACE:
3957         if (do_utf8) {
3958             loceol = PL_regeol;
3959             LOAD_UTF8_CHARCLASS(space," ");
3960             while (hardcount < max && scan < loceol &&
3961                    (*scan == ' ' ||
3962                     swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
3963                 scan += UTF8SKIP(scan);
3964                 hardcount++;
3965             }
3966         } else {
3967             while (scan < loceol && isSPACE(*scan))
3968                 scan++;
3969         }
3970         break;
3971     case SPACEL:
3972         PL_reg_flags |= RF_tainted;
3973         if (do_utf8) {
3974             loceol = PL_regeol;
3975             while (hardcount < max && scan < loceol &&
3976                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
3977                 scan += UTF8SKIP(scan);
3978                 hardcount++;
3979             }
3980         } else {
3981             while (scan < loceol && isSPACE_LC(*scan))
3982                 scan++;
3983         }
3984         break;
3985     case NSPACE:
3986         if (do_utf8) {
3987             loceol = PL_regeol;
3988             LOAD_UTF8_CHARCLASS(space," ");
3989             while (hardcount < max && scan < loceol &&
3990                    !(*scan == ' ' ||
3991                      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
3992                 scan += UTF8SKIP(scan);
3993                 hardcount++;
3994             }
3995         } else {
3996             while (scan < loceol && !isSPACE(*scan))
3997                 scan++;
3998             break;
3999         }
4000     case NSPACEL:
4001         PL_reg_flags |= RF_tainted;
4002         if (do_utf8) {
4003             loceol = PL_regeol;
4004             while (hardcount < max && scan < loceol &&
4005                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
4006                 scan += UTF8SKIP(scan);
4007                 hardcount++;
4008             }
4009         } else {
4010             while (scan < loceol && !isSPACE_LC(*scan))
4011                 scan++;
4012         }
4013         break;
4014     case DIGIT:
4015         if (do_utf8) {
4016             loceol = PL_regeol;
4017             LOAD_UTF8_CHARCLASS(digit,"0");
4018             while (hardcount < max && scan < loceol &&
4019                    swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
4020                 scan += UTF8SKIP(scan);
4021                 hardcount++;
4022             }
4023         } else {
4024             while (scan < loceol && isDIGIT(*scan))
4025                 scan++;
4026         }
4027         break;
4028     case NDIGIT:
4029         if (do_utf8) {
4030             loceol = PL_regeol;
4031             LOAD_UTF8_CHARCLASS(digit,"0");
4032             while (hardcount < max && scan < loceol &&
4033                    !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
4034                 scan += UTF8SKIP(scan);
4035                 hardcount++;
4036             }
4037         } else {
4038             while (scan < loceol && !isDIGIT(*scan))
4039                 scan++;
4040         }
4041         break;
4042     default:            /* Called on something of 0 width. */
4043         break;          /* So match right here or not at all. */
4044     }
4045
4046     if (hardcount)
4047         c = hardcount;
4048     else
4049         c = scan - PL_reginput;
4050     PL_reginput = scan;
4051
4052     DEBUG_r(
4053         {
4054                 SV *prop = sv_newmortal();
4055
4056                 regprop(prop, p);
4057                 PerlIO_printf(Perl_debug_log,
4058                               "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
4059                               REPORT_CODE_OFF+1, "", SvPVX(prop),(IV)c,(IV)max);
4060         });
4061
4062     return(c);
4063 }
4064
4065 /*
4066  - regrepeat_hard - repeatedly match something, report total lenth and length
4067  *
4068  * The repeater is supposed to have constant length.
4069  */
4070
4071 STATIC I32
4072 S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
4073 {
4074     register char *scan = Nullch;
4075     register char *start;
4076     register char *loceol = PL_regeol;
4077     I32 l = 0;
4078     I32 count = 0, res = 1;
4079
4080     if (!max)
4081         return 0;
4082
4083     start = PL_reginput;
4084     if (PL_reg_match_utf8) {
4085         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
4086             if (!count++) {
4087                 l = 0;
4088                 while (start < PL_reginput) {
4089                     l++;
4090                     start += UTF8SKIP(start);
4091                 }
4092                 *lp = l;
4093                 if (l == 0)
4094                     return max;
4095             }
4096             if (count == max)
4097                 return count;
4098         }
4099     }
4100     else {
4101         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
4102             if (!count++) {
4103                 *lp = l = PL_reginput - start;
4104                 if (max != REG_INFTY && l*max < loceol - scan)
4105                     loceol = scan + l*max;
4106                 if (l == 0)
4107                     return max;
4108             }
4109         }
4110     }
4111     if (!res)
4112         PL_reginput = scan;
4113
4114     return count;
4115 }
4116
4117 /*
4118 - regclass_swash - prepare the utf8 swash
4119 */
4120
4121 SV *
4122 Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** initsvp)
4123 {
4124     SV *sw = NULL;
4125     SV *si = NULL;
4126
4127     if (PL_regdata && PL_regdata->count) {
4128         U32 n = ARG(node);
4129
4130         if (PL_regdata->what[n] == 's') {
4131             SV *rv = (SV*)PL_regdata->data[n];
4132             AV *av = (AV*)SvRV((SV*)rv);
4133             SV **a;
4134
4135             si = *av_fetch(av, 0, FALSE);
4136             a  =  av_fetch(av, 1, FALSE);
4137
4138             if (a)
4139                 sw = *a;
4140             else if (si && doinit) {
4141                 sw = swash_init("utf8", "", si, 1, 0);
4142                 (void)av_store(av, 1, sw);
4143             }
4144         }
4145     }
4146
4147     if (initsvp)
4148         *initsvp = si;
4149
4150     return sw;
4151 }
4152
4153 /*
4154  - reginclass - determine if a character falls into a character class
4155  */
4156
4157 STATIC bool
4158 S_reginclass(pTHX_ register regnode *n, register U8* p, register bool do_utf8)
4159 {
4160     char flags = ANYOF_FLAGS(n);
4161     bool match = FALSE;
4162     UV c;
4163     STRLEN len = 0;
4164
4165     c = do_utf8 ? utf8_to_uvchr(p, &len) : *p;
4166
4167     if (do_utf8 || (flags & ANYOF_UNICODE)) {
4168         if (do_utf8 && !ANYOF_RUNTIME(n)) {
4169             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
4170                 match = TRUE;
4171         }
4172         if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
4173             match = TRUE;
4174         if (!match) {
4175             SV *sw = regclass_swash(n, TRUE, 0);
4176
4177             if (sw) {
4178                 if (swash_fetch(sw, p, do_utf8))
4179                     match = TRUE;
4180                 else if (flags & ANYOF_FOLD) {
4181                     STRLEN ulen;
4182                     U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
4183
4184                     to_utf8_fold(p, tmpbuf, &ulen);
4185                     if (swash_fetch(sw, tmpbuf, do_utf8))
4186                         match = TRUE;
4187                     to_utf8_upper(p, tmpbuf, &ulen);
4188                     if (swash_fetch(sw, tmpbuf, do_utf8))
4189                         match = TRUE;
4190                 }
4191             }
4192         }
4193     }
4194     if (!match && c < 256) {
4195         if (ANYOF_BITMAP_TEST(n, c))
4196             match = TRUE;
4197         else if (flags & ANYOF_FOLD) {
4198           I32 f;
4199
4200             if (flags & ANYOF_LOCALE) {
4201                 PL_reg_flags |= RF_tainted;
4202                 f = PL_fold_locale[c];
4203             }
4204             else
4205                 f = PL_fold[c];
4206             if (f != c && ANYOF_BITMAP_TEST(n, f))
4207                 match = TRUE;
4208         }
4209
4210         if (!match && (flags & ANYOF_CLASS)) {
4211             PL_reg_flags |= RF_tainted;
4212             if (
4213                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
4214                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
4215                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
4216                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
4217                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
4218                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
4219                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
4220                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
4221                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
4222                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
4223                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
4224                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
4225                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
4226                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
4227                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
4228                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
4229                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
4230                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
4231                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
4232                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
4233                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
4234                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
4235                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
4236                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
4237                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
4238                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
4239                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
4240                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
4241                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
4242                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
4243                 ) /* How's that for a conditional? */
4244             {
4245                 match = TRUE;
4246             }
4247         }
4248     }
4249
4250     return (flags & ANYOF_INVERT) ? !match : match;
4251 }
4252
4253 STATIC U8 *
4254 S_reghop(pTHX_ U8 *s, I32 off)
4255 {
4256     return S_reghop3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
4257 }
4258
4259 STATIC U8 *
4260 S_reghop3(pTHX_ U8 *s, I32 off, U8* lim)
4261 {
4262     if (off >= 0) {
4263         while (off-- && s < lim) {
4264             /* XXX could check well-formedness here */
4265             s += UTF8SKIP(s);
4266         }
4267     }
4268     else {
4269         while (off++) {
4270             if (s > lim) {
4271                 s--;
4272                 if (UTF8_IS_CONTINUED(*s)) {
4273                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
4274                         s--;
4275                 }
4276                 /* XXX could check well-formedness here */
4277             }
4278         }
4279     }
4280     return s;
4281 }
4282
4283 STATIC U8 *
4284 S_reghopmaybe(pTHX_ U8 *s, I32 off)
4285 {
4286     return S_reghopmaybe3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
4287 }
4288
4289 STATIC U8 *
4290 S_reghopmaybe3(pTHX_ U8* s, I32 off, U8* lim)
4291 {
4292     if (off >= 0) {
4293         while (off-- && s < lim) {
4294             /* XXX could check well-formedness here */
4295             s += UTF8SKIP(s);
4296         }
4297         if (off >= 0)
4298             return 0;
4299     }
4300     else {
4301         while (off++) {
4302             if (s > lim) {
4303                 s--;
4304                 if (UTF8_IS_CONTINUED(*s)) {
4305                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
4306                         s--;
4307                 }
4308                 /* XXX could check well-formedness here */
4309             }
4310             else
4311                 break;
4312         }
4313         if (off <= 0)
4314             return 0;
4315     }
4316     return s;
4317 }
4318
4319 static void
4320 restore_pos(pTHX_ void *arg)
4321 {
4322     if (PL_reg_eval_set) {
4323         if (PL_reg_oldsaved) {
4324             PL_reg_re->subbeg = PL_reg_oldsaved;
4325             PL_reg_re->sublen = PL_reg_oldsavedlen;
4326             RX_MATCH_COPIED_on(PL_reg_re);
4327         }
4328         PL_reg_magic->mg_len = PL_reg_oldpos;
4329         PL_reg_eval_set = 0;
4330         PL_curpm = PL_reg_oldcurpm;
4331     }
4332 }