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, (I32)(strend - s),
 983                                             m, UTF, (I32)ln))
 984                              && (norun || regtry(prog, s)) )
 985                             goto got_it;
 986                         s += len;
 987                     }
 988                 }
 989                 else {
 990                     while (s <= e) {
 991                         U8 tmpbuf [UTF8_MAXLEN+1];
 992                         U8 foldbuf[UTF8_MAXLEN_FOLD+1];
 993                         STRLEN foldlen;
 994                         UV c = utf8_to_uvchr((U8*)s, &len);
 995                         UV f;
 996
 997                         uvchr_to_utf8(tmpbuf, c);
 998                         f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
 999
1000                         if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1001                             c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1002                             c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1003                         if ( (c == c1 || c == c2 || f == c1 || f == c2)
1004                              && ibcmp_utf8(s, do_utf8, (I32)(strend - s),
1005                                            m, UTF, (I32)ln)
1006                              && (norun || regtry(prog, s)) )
1007                             goto got_it;
1008                         s += len;
1009                     }
1010                 }
1011             }
1012             else {
1013                 if (c1 == c2)
1014                     while (s <= e) {
1015                         if ( *(U8*)s == c1
1016                              && (ln == 1 || !(OP(c) == EXACTF
1017                                               ? ibcmp(s, m, ln)
1018                                               : ibcmp_locale(s, m, ln)))
1019                              && (norun || regtry(prog, s)) )
1020                             goto got_it;
1021                         s++;
1022                     }
1023                 else
1024                     while (s <= e) {
1025                         if ( (*(U8*)s == c1 || *(U8*)s == c2)
1026                              && (ln == 1 || !(OP(c) == EXACTF
1027                                               ? ibcmp(s, m, ln)
1028                                               : ibcmp_locale(s, m, ln)))
1029                              && (norun || regtry(prog, s)) )
1030                             goto got_it;
1031                         s++;
1032                     }
1033             }
1034             break;
1035         case BOUNDL:
1036             PL_reg_flags |= RF_tainted;
1037             /* FALL THROUGH */
1038         case BOUND:
1039             if (do_utf8) {
1040                 if (s == PL_bostr)
1041                     tmp = '\n';
1042                 else {
1043                     U8 *r = reghop3((U8*)s, -1, (U8*)startpos);
1044
1045                     if (s > (char*)r)
1046                         tmp = (I32)utf8n_to_uvchr(r, s - (char*)r, 0, 0);
1047                 }
1048                 tmp = ((OP(c) == BOUND ?
1049                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1050                 LOAD_UTF8_CHARCLASS(alnum,"a");
1051                 while (s < strend) {
1052                     if (tmp == !(OP(c) == BOUND ?
1053                                  swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1054                                  isALNUM_LC_utf8((U8*)s)))
1055                     {
1056                         tmp = !tmp;
1057                         if ((norun || regtry(prog, s)))
1058                             goto got_it;
1059                     }
1060                     s += UTF8SKIP(s);
1061                 }
1062             }
1063             else {
1064                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1065                 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1066                 while (s < strend) {
1067                     if (tmp ==
1068                         !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1069                         tmp = !tmp;
1070                         if ((norun || regtry(prog, s)))
1071                             goto got_it;
1072                     }
1073                     s++;
1074                 }
1075             }
1076             if ((!prog->minlen && tmp) && (norun || regtry(prog, s)))
1077                 goto got_it;
1078             break;
1079         case NBOUNDL:
1080             PL_reg_flags |= RF_tainted;
1081             /* FALL THROUGH */
1082         case NBOUND:
1083             if (do_utf8) {
1084                 if (s == PL_bostr)
1085                     tmp = '\n';
1086                 else {
1087                     U8 *r = reghop3((U8*)s, -1, (U8*)startpos);
1088
1089                     if (s > (char*)r)
1090                         tmp = (I32)utf8n_to_uvchr(r, s - (char*)r, 0, 0);
1091                 }
1092                 tmp = ((OP(c) == NBOUND ?
1093                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1094                 LOAD_UTF8_CHARCLASS(alnum,"a");
1095                 while (s < strend) {
1096                     if (tmp == !(OP(c) == NBOUND ?
1097                                  swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1098                                  isALNUM_LC_utf8((U8*)s)))
1099                         tmp = !tmp;
1100                     else if ((norun || regtry(prog, s)))
1101                         goto got_it;
1102                     s += UTF8SKIP(s);
1103                 }
1104             }
1105             else {
1106                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1107                 tmp = ((OP(c) == NBOUND ?
1108                         isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1109                 while (s < strend) {
1110                     if (tmp ==
1111                         !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1112                         tmp = !tmp;
1113                     else if ((norun || regtry(prog, s)))
1114                         goto got_it;
1115                     s++;
1116                 }
1117             }
1118             if ((!prog->minlen && !tmp) && (norun || regtry(prog, s)))
1119                 goto got_it;
1120             break;
1121         case ALNUM:
1122             if (do_utf8) {
1123                 LOAD_UTF8_CHARCLASS(alnum,"a");
1124                 while (s < strend) {
1125                     if (swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1126                         if (tmp && (norun || regtry(prog, s)))
1127                             goto got_it;
1128                         else
1129                             tmp = doevery;
1130                     }
1131                     else
1132                         tmp = 1;
1133                     s += UTF8SKIP(s);
1134                 }
1135             }
1136             else {
1137                 while (s < strend) {
1138                     if (isALNUM(*s)) {
1139                         if (tmp && (norun || regtry(prog, s)))
1140                             goto got_it;
1141                         else
1142                             tmp = doevery;
1143                     }
1144                     else
1145                         tmp = 1;
1146                     s++;
1147                 }
1148             }
1149             break;
1150         case ALNUML:
1151             PL_reg_flags |= RF_tainted;
1152             if (do_utf8) {
1153                 while (s < strend) {
1154                     if (isALNUM_LC_utf8((U8*)s)) {
1155                         if (tmp && (norun || regtry(prog, s)))
1156                             goto got_it;
1157                         else
1158                             tmp = doevery;
1159                     }
1160                     else
1161                         tmp = 1;
1162                     s += UTF8SKIP(s);
1163                 }
1164             }
1165             else {
1166                 while (s < strend) {
1167                     if (isALNUM_LC(*s)) {
1168                         if (tmp && (norun || regtry(prog, s)))
1169                             goto got_it;
1170                         else
1171                             tmp = doevery;
1172                     }
1173                     else
1174                         tmp = 1;
1175                     s++;
1176                 }
1177             }
1178             break;
1179         case NALNUM:
1180             if (do_utf8) {
1181                 LOAD_UTF8_CHARCLASS(alnum,"a");
1182                 while (s < strend) {
1183                     if (!swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1184                         if (tmp && (norun || regtry(prog, s)))
1185                             goto got_it;
1186                         else
1187                             tmp = doevery;
1188                     }
1189                     else
1190                         tmp = 1;
1191                     s += UTF8SKIP(s);
1192                 }
1193             }
1194             else {
1195                 while (s < strend) {
1196                     if (!isALNUM(*s)) {
1197                         if (tmp && (norun || regtry(prog, s)))
1198                             goto got_it;
1199                         else
1200                             tmp = doevery;
1201                     }
1202                     else
1203                         tmp = 1;
1204                     s++;
1205                 }
1206             }
1207             break;
1208         case NALNUML:
1209             PL_reg_flags |= RF_tainted;
1210             if (do_utf8) {
1211                 while (s < strend) {
1212                     if (!isALNUM_LC_utf8((U8*)s)) {
1213                         if (tmp && (norun || regtry(prog, s)))
1214                             goto got_it;
1215                         else
1216                             tmp = doevery;
1217                     }
1218                     else
1219                         tmp = 1;
1220                     s += UTF8SKIP(s);
1221                 }
1222             }
1223             else {
1224                 while (s < strend) {
1225                     if (!isALNUM_LC(*s)) {
1226                         if (tmp && (norun || regtry(prog, s)))
1227                             goto got_it;
1228                         else
1229                             tmp = doevery;
1230                     }
1231                     else
1232                         tmp = 1;
1233                     s++;
1234                 }
1235             }
1236             break;
1237         case SPACE:
1238             if (do_utf8) {
1239                 LOAD_UTF8_CHARCLASS(space," ");
1240                 while (s < strend) {
1241                     if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)) {
1242                         if (tmp && (norun || regtry(prog, s)))
1243                             goto got_it;
1244                         else
1245                             tmp = doevery;
1246                     }
1247                     else
1248                         tmp = 1;
1249                     s += UTF8SKIP(s);
1250                 }
1251             }
1252             else {
1253                 while (s < strend) {
1254                     if (isSPACE(*s)) {
1255                         if (tmp && (norun || regtry(prog, s)))
1256                             goto got_it;
1257                         else
1258                             tmp = doevery;
1259                     }
1260                     else
1261                         tmp = 1;
1262                     s++;
1263                 }
1264             }
1265             break;
1266         case SPACEL:
1267             PL_reg_flags |= RF_tainted;
1268             if (do_utf8) {
1269                 while (s < strend) {
1270                     if (*s == ' ' || isSPACE_LC_utf8((U8*)s)) {
1271                         if (tmp && (norun || regtry(prog, s)))
1272                             goto got_it;
1273                         else
1274                             tmp = doevery;
1275                     }
1276                     else
1277                         tmp = 1;
1278                     s += UTF8SKIP(s);
1279                 }
1280             }
1281             else {
1282                 while (s < strend) {
1283                     if (isSPACE_LC(*s)) {
1284                         if (tmp && (norun || regtry(prog, s)))
1285                             goto got_it;
1286                         else
1287                             tmp = doevery;
1288                     }
1289                     else
1290                         tmp = 1;
1291                     s++;
1292                 }
1293             }
1294             break;
1295         case NSPACE:
1296             if (do_utf8) {
1297                 LOAD_UTF8_CHARCLASS(space," ");
1298                 while (s < strend) {
1299                     if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8))) {
1300                         if (tmp && (norun || regtry(prog, s)))
1301                             goto got_it;
1302                         else
1303                             tmp = doevery;
1304                     }
1305                     else
1306                         tmp = 1;
1307                     s += UTF8SKIP(s);
1308                 }
1309             }
1310             else {
1311                 while (s < strend) {
1312                     if (!isSPACE(*s)) {
1313                         if (tmp && (norun || regtry(prog, s)))
1314                             goto got_it;
1315                         else
1316                             tmp = doevery;
1317                     }
1318                     else
1319                         tmp = 1;
1320                     s++;
1321                 }
1322             }
1323             break;
1324         case NSPACEL:
1325             PL_reg_flags |= RF_tainted;
1326             if (do_utf8) {
1327                 while (s < strend) {
1328                     if (!(*s == ' ' || isSPACE_LC_utf8((U8*)s))) {
1329                         if (tmp && (norun || regtry(prog, s)))
1330                             goto got_it;
1331                         else
1332                             tmp = doevery;
1333                     }
1334                     else
1335                         tmp = 1;
1336                     s += UTF8SKIP(s);
1337                 }
1338             }
1339             else {
1340                 while (s < strend) {
1341                     if (!isSPACE_LC(*s)) {
1342                         if (tmp && (norun || regtry(prog, s)))
1343                             goto got_it;
1344                         else
1345                             tmp = doevery;
1346                     }
1347                     else
1348                         tmp = 1;
1349                     s++;
1350                 }
1351             }
1352             break;
1353         case DIGIT:
1354             if (do_utf8) {
1355                 LOAD_UTF8_CHARCLASS(digit,"0");
1356                 while (s < strend) {
1357                     if (swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1358                         if (tmp && (norun || regtry(prog, s)))
1359                             goto got_it;
1360                         else
1361                             tmp = doevery;
1362                     }
1363                     else
1364                         tmp = 1;
1365                     s += UTF8SKIP(s);
1366                 }
1367             }
1368             else {
1369                 while (s < strend) {
1370                     if (isDIGIT(*s)) {
1371                         if (tmp && (norun || regtry(prog, s)))
1372                             goto got_it;
1373                         else
1374                             tmp = doevery;
1375                     }
1376                     else
1377                         tmp = 1;
1378                     s++;
1379                 }
1380             }
1381             break;
1382         case DIGITL:
1383             PL_reg_flags |= RF_tainted;
1384             if (do_utf8) {
1385                 while (s < strend) {
1386                     if (isDIGIT_LC_utf8((U8*)s)) {
1387                         if (tmp && (norun || regtry(prog, s)))
1388                             goto got_it;
1389                         else
1390                             tmp = doevery;
1391                     }
1392                     else
1393                         tmp = 1;
1394                     s += UTF8SKIP(s);
1395                 }
1396             }
1397             else {
1398                 while (s < strend) {
1399                     if (isDIGIT_LC(*s)) {
1400                         if (tmp && (norun || regtry(prog, s)))
1401                             goto got_it;
1402                         else
1403                             tmp = doevery;
1404                     }
1405                     else
1406                         tmp = 1;
1407                     s++;
1408                 }
1409             }
1410             break;
1411         case NDIGIT:
1412             if (do_utf8) {
1413                 LOAD_UTF8_CHARCLASS(digit,"0");
1414                 while (s < strend) {
1415                     if (!swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1416                         if (tmp && (norun || regtry(prog, s)))
1417                             goto got_it;
1418                         else
1419                             tmp = doevery;
1420                     }
1421                     else
1422                         tmp = 1;
1423                     s += UTF8SKIP(s);
1424                 }
1425             }
1426             else {
1427                 while (s < strend) {
1428                     if (!isDIGIT(*s)) {
1429                         if (tmp && (norun || regtry(prog, s)))
1430                             goto got_it;
1431                         else
1432                             tmp = doevery;
1433                     }
1434                     else
1435                         tmp = 1;
1436                     s++;
1437                 }
1438             }
1439             break;
1440         case NDIGITL:
1441             PL_reg_flags |= RF_tainted;
1442             if (do_utf8) {
1443                 while (s < strend) {
1444                     if (!isDIGIT_LC_utf8((U8*)s)) {
1445                         if (tmp && (norun || regtry(prog, s)))
1446                             goto got_it;
1447                         else
1448                             tmp = doevery;
1449                     }
1450                     else
1451                         tmp = 1;
1452                     s += UTF8SKIP(s);
1453                 }
1454             }
1455             else {
1456                 while (s < strend) {
1457                     if (!isDIGIT_LC(*s)) {
1458                         if (tmp && (norun || regtry(prog, s)))
1459                             goto got_it;
1460                         else
1461                             tmp = doevery;
1462                     }
1463                     else
1464                         tmp = 1;
1465                     s++;
1466                 }
1467             }
1468             break;
1469         default:
1470             Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1471             break;
1472         }
1473         return 0;
1474       got_it:
1475         return s;
1476 }
1477
1478 /*
1479  - regexec_flags - match a regexp against a string
1480  */
1481 I32
1482 Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *strend,
1483               char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1484 /* strend: pointer to null at end of string */
1485 /* strbeg: real beginning of string */
1486 /* minend: end of match must be >=minend after stringarg. */
1487 /* data: May be used for some additional optimizations. */
1488 /* nosave: For optimizations. */
1489 {
1490     register char *s;
1491     register regnode *c;
1492     register char *startpos = stringarg;
1493     I32 minlen;         /* must match at least this many chars */
1494     I32 dontbother = 0; /* how many characters not to try at end */
1495     /* I32 start_shift = 0; */          /* Offset of the start to find
1496                                          constant substr. */            /* CC */
1497     I32 end_shift = 0;                  /* Same for the end. */         /* CC */
1498     I32 scream_pos = -1;                /* Internal iterator of scream. */
1499     char *scream_olds;
1500     SV* oreplsv = GvSV(PL_replgv);
1501     bool do_utf8 = DO_UTF8(sv);
1502 #ifdef DEBUGGING
1503     SV *dsv = PERL_DEBUG_PAD_ZERO(0);
1504 #endif
1505
1506     PL_regcc = 0;
1507
1508     cache_re(prog);
1509 #ifdef DEBUGGING
1510     PL_regnarrate = DEBUG_r_TEST;
1511 #endif
1512
1513     /* Be paranoid... */
1514     if (prog == NULL || startpos == NULL) {
1515         Perl_croak(aTHX_ "NULL regexp parameter");
1516         return 0;
1517     }
1518
1519     minlen = prog->minlen;
1520     if (strend - startpos < minlen) {
1521         DEBUG_r(PerlIO_printf(Perl_debug_log,
1522                               "String too short [regexec_flags]...\n"));
1523         goto phooey;
1524     }
1525
1526     /* Check validity of program. */
1527     if (UCHARAT(prog->program) != REG_MAGIC) {
1528         Perl_croak(aTHX_ "corrupted regexp program");
1529     }
1530
1531     PL_reg_flags = 0;
1532     PL_reg_eval_set = 0;
1533     PL_reg_maxiter = 0;
1534
1535     if (prog->reganch & ROPT_UTF8)
1536         PL_reg_flags |= RF_utf8;
1537
1538     /* Mark beginning of line for ^ and lookbehind. */
1539     PL_regbol = startpos;
1540     PL_bostr  = strbeg;
1541     PL_reg_sv = sv;
1542
1543     /* Mark end of line for $ (and such) */
1544     PL_regeol = strend;
1545
1546     /* see how far we have to get to not match where we matched before */
1547     PL_regtill = startpos+minend;
1548
1549     /* We start without call_cc context.  */
1550     PL_reg_call_cc = 0;
1551
1552     /* If there is a "must appear" string, look for it. */
1553     s = startpos;
1554
1555     if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to have PL_reg_ganch */
1556         MAGIC *mg;
1557
1558         if (flags & REXEC_IGNOREPOS)    /* Means: check only at start */
1559             PL_reg_ganch = startpos;
1560         else if (sv && SvTYPE(sv) >= SVt_PVMG
1561                   && SvMAGIC(sv)
1562                   && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1563                   && mg->mg_len >= 0) {
1564             PL_reg_ganch = strbeg + mg->mg_len; /* Defined pos() */
1565             if (prog->reganch & ROPT_ANCH_GPOS) {
1566                 if (s > PL_reg_ganch)
1567                     goto phooey;
1568                 s = PL_reg_ganch;
1569             }
1570         }
1571         else                            /* pos() not defined */
1572             PL_reg_ganch = strbeg;
1573     }
1574
1575     if (do_utf8 == (UTF!=0) &&
1576         !(flags & REXEC_CHECKED) && prog->check_substr != Nullsv) {
1577         re_scream_pos_data d;
1578
1579         d.scream_olds = &scream_olds;
1580         d.scream_pos = &scream_pos;
1581         s = re_intuit_start(prog, sv, s, strend, flags, &d);
1582         if (!s) {
1583             DEBUG_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1584             goto phooey;        /* not present */
1585         }
1586     }
1587
1588     DEBUG_r({
1589          char *s   = do_utf8 ? sv_uni_display(dsv, sv, 60, 0) : startpos;
1590          int   len = do_utf8 ? strlen(s) : strend - startpos;
1591          if (!PL_colorset)
1592              reginitcolors();
1593          PerlIO_printf(Perl_debug_log,
1594                        "%sMatching REx%s `%s%.60s%s%s' against `%s%.*s%s%s'\n",
1595                        PL_colors[4],PL_colors[5],PL_colors[0],
1596                        prog->precomp,
1597                        PL_colors[1],
1598                        (strlen(prog->precomp) > 60 ? "..." : ""),
1599                        PL_colors[0],
1600                        (int)(len > 60 ? 60 : len),
1601                        s, PL_colors[1],
1602                        (len > 60 ? "..." : "")
1603               );
1604     });
1605
1606     /* Simplest case:  anchored match need be tried only once. */
1607     /*  [unless only anchor is BOL and multiline is set] */
1608     if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
1609         if (s == startpos && regtry(prog, startpos))
1610             goto got_it;
1611         else if (PL_multiline || (prog->reganch & ROPT_IMPLICIT)
1612                  || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
1613         {
1614             char *end;
1615
1616             if (minlen)
1617                 dontbother = minlen - 1;
1618             end = HOP3c(strend, -dontbother, strbeg) - 1;
1619             /* for multiline we only have to try after newlines */
1620             if (prog->check_substr) {
1621                 if (s == startpos)
1622                     goto after_try;
1623                 while (1) {
1624                     if (regtry(prog, s))
1625                         goto got_it;
1626                   after_try:
1627                     if (s >= end)
1628                         goto phooey;
1629                     if (prog->reganch & RE_USE_INTUIT) {
1630                         s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
1631                         if (!s)
1632                             goto phooey;
1633                     }
1634                     else
1635                         s++;
1636                 }
1637             } else {
1638                 if (s > startpos)
1639                     s--;
1640                 while (s < end) {
1641                     if (*s++ == '\n') { /* don't need PL_utf8skip here */
1642                         if (regtry(prog, s))
1643                             goto got_it;
1644                     }
1645                 }
1646             }
1647         }
1648         goto phooey;
1649     } else if (prog->reganch & ROPT_ANCH_GPOS) {
1650         if (regtry(prog, PL_reg_ganch))
1651             goto got_it;
1652         goto phooey;
1653     }
1654
1655     /* Messy cases:  unanchored match. */
1656     if (prog->anchored_substr && prog->reganch & ROPT_SKIP) {
1657         /* we have /x+whatever/ */
1658         /* it must be a one character string (XXXX Except UTF?) */
1659         char ch = SvPVX(prog->anchored_substr)[0];
1660 #ifdef DEBUGGING
1661         int did_match = 0;
1662 #endif
1663
1664         if (do_utf8) {
1665             while (s < strend) {
1666                 if (*s == ch) {
1667                     DEBUG_r( did_match = 1 );
1668                     if (regtry(prog, s)) goto got_it;
1669                     s += UTF8SKIP(s);
1670                     while (s < strend && *s == ch)
1671                         s += UTF8SKIP(s);
1672                 }
1673                 s += UTF8SKIP(s);
1674             }
1675         }
1676         else {
1677             while (s < strend) {
1678                 if (*s == ch) {
1679                     DEBUG_r( did_match = 1 );
1680                     if (regtry(prog, s)) goto got_it;
1681                     s++;
1682                     while (s < strend && *s == ch)
1683                         s++;
1684                 }
1685                 s++;
1686             }
1687         }
1688         DEBUG_r(if (!did_match)
1689                 PerlIO_printf(Perl_debug_log,
1690                                   "Did not find anchored character...\n")
1691                );
1692     }
1693     /*SUPPRESS 560*/
1694     else if (do_utf8 == (UTF!=0) &&
1695              (prog->anchored_substr != Nullsv
1696               || (prog->float_substr != Nullsv
1697                   && prog->float_max_offset < strend - s))) {
1698         SV *must = prog->anchored_substr
1699             ? prog->anchored_substr : prog->float_substr;
1700         I32 back_max =
1701             prog->anchored_substr ? prog->anchored_offset : prog->float_max_offset;
1702         I32 back_min =
1703             prog->anchored_substr ? prog->anchored_offset : prog->float_min_offset;
1704         char *last = HOP3c(strend,      /* Cannot start after this */
1705                           -(I32)(CHR_SVLEN(must)
1706                                  - (SvTAIL(must) != 0) + back_min), strbeg);
1707         char *last1;            /* Last position checked before */
1708 #ifdef DEBUGGING
1709         int did_match = 0;
1710 #endif
1711
1712         if (s > PL_bostr)
1713             last1 = HOPc(s, -1);
1714         else
1715             last1 = s - 1;      /* bogus */
1716
1717         /* XXXX check_substr already used to find `s', can optimize if
1718            check_substr==must. */
1719         scream_pos = -1;
1720         dontbother = end_shift;
1721         strend = HOPc(strend, -dontbother);
1722         while ( (s <= last) &&
1723                 ((flags & REXEC_SCREAM)
1724                  ? (s = screaminstr(sv, must, HOP3c(s, back_min, strend) - strbeg,
1725                                     end_shift, &scream_pos, 0))
1726                  : (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend),
1727                                   (unsigned char*)strend, must,
1728                                   PL_multiline ? FBMrf_MULTILINE : 0))) ) {
1729             DEBUG_r( did_match = 1 );
1730             if (HOPc(s, -back_max) > last1) {
1731                 last1 = HOPc(s, -back_min);
1732                 s = HOPc(s, -back_max);
1733             }
1734             else {
1735                 char *t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
1736
1737                 last1 = HOPc(s, -back_min);
1738                 s = t;
1739             }
1740             if (do_utf8) {
1741                 while (s <= last1) {
1742                     if (regtry(prog, s))
1743                         goto got_it;
1744                     s += UTF8SKIP(s);
1745                 }
1746             }
1747             else {
1748                 while (s <= last1) {
1749                     if (regtry(prog, s))
1750                         goto got_it;
1751                     s++;
1752                 }
1753             }
1754         }
1755         DEBUG_r(if (!did_match)
1756                     PerlIO_printf(Perl_debug_log,
1757                                   "Did not find %s substr `%s%.*s%s'%s...\n",
1758                               ((must == prog->anchored_substr)
1759                                ? "anchored" : "floating"),
1760                               PL_colors[0],
1761                               (int)(SvCUR(must) - (SvTAIL(must)!=0)),
1762                               SvPVX(must),
1763                                   PL_colors[1], (SvTAIL(must) ? "$" : ""))
1764                );
1765         goto phooey;
1766     }
1767     else if ((c = prog->regstclass)) {
1768         if (minlen && PL_regkind[(U8)OP(prog->regstclass)] != EXACT)
1769             /* don't bother with what can't match */
1770             strend = HOPc(strend, -(minlen - 1));
1771         DEBUG_r({
1772             SV *prop = sv_newmortal();
1773             regprop(prop, c);
1774             PerlIO_printf(Perl_debug_log, "Matching stclass `%s' against `%s'\n", SvPVX(prop), UTF ? sv_uni_display(dsv, sv, 60, 0) : s);
1775         });
1776         if (find_byclass(prog, c, s, strend, startpos, 0))
1777             goto got_it;
1778         DEBUG_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n"));
1779     }
1780     else {
1781         dontbother = 0;
1782         if (prog->float_substr != Nullsv) {     /* Trim the end. */
1783             char *last;
1784
1785             if (flags & REXEC_SCREAM) {
1786                 last = screaminstr(sv, prog->float_substr, s - strbeg,
1787                                    end_shift, &scream_pos, 1); /* last one */
1788                 if (!last)
1789                     last = scream_olds; /* Only one occurrence. */
1790             }
1791             else {
1792                 STRLEN len;
1793                 char *little = SvPV(prog->float_substr, len);
1794
1795                 if (SvTAIL(prog->float_substr)) {
1796                     if (memEQ(strend - len + 1, little, len - 1))
1797                         last = strend - len + 1;
1798                     else if (!PL_multiline)
1799                         last = memEQ(strend - len, little, len)
1800                             ? strend - len : Nullch;
1801                     else
1802                         goto find_last;
1803                 } else {
1804                   find_last:
1805                     if (len)
1806                         last = rninstr(s, strend, little, little + len);
1807                     else
1808                         last = strend;  /* matching `$' */
1809                 }
1810             }
1811             if (last == NULL) {
1812                 DEBUG_r(PerlIO_printf(Perl_debug_log,
1813                                       "%sCan't trim the tail, match fails (should not happen)%s\n",
1814                                       PL_colors[4],PL_colors[5]));
1815                 goto phooey; /* Should not happen! */
1816             }
1817             dontbother = strend - last + prog->float_min_offset;
1818         }
1819         if (minlen && (dontbother < minlen))
1820             dontbother = minlen - 1;
1821         strend -= dontbother;              /* this one's always in bytes! */
1822         /* We don't know much -- general case. */
1823         if (do_utf8) {
1824             for (;;) {
1825                 if (regtry(prog, s))
1826                     goto got_it;
1827                 if (s >= strend)
1828                     break;
1829                 s += UTF8SKIP(s);
1830             };
1831         }
1832         else {
1833             do {
1834                 if (regtry(prog, s))
1835                     goto got_it;
1836             } while (s++ < strend);
1837         }
1838     }
1839
1840     /* Failure. */
1841     goto phooey;
1842
1843 got_it:
1844     RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
1845
1846     if (PL_reg_eval_set) {
1847         /* Preserve the current value of $^R */
1848         if (oreplsv != GvSV(PL_replgv))
1849             sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
1850                                                   restored, the value remains
1851                                                   the same. */
1852         restore_pos(aTHX_ 0);
1853     }
1854
1855     /* make sure $`, $&, $', and $digit will work later */
1856     if ( !(flags & REXEC_NOT_FIRST) ) {
1857         if (RX_MATCH_COPIED(prog)) {
1858             Safefree(prog->subbeg);
1859             RX_MATCH_COPIED_off(prog);
1860         }
1861         if (flags & REXEC_COPY_STR) {
1862             I32 i = PL_regeol - startpos + (stringarg - strbeg);
1863
1864             s = savepvn(strbeg, i);
1865             prog->subbeg = s;
1866             prog->sublen = i;
1867             RX_MATCH_COPIED_on(prog);
1868         }
1869         else {
1870             prog->subbeg = strbeg;
1871             prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
1872         }
1873     }
1874
1875     return 1;
1876
1877 phooey:
1878     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
1879                           PL_colors[4],PL_colors[5]));
1880     if (PL_reg_eval_set)
1881         restore_pos(aTHX_ 0);
1882     return 0;
1883 }
1884
1885 /*
1886  - regtry - try match at specific point
1887  */
1888 STATIC I32                      /* 0 failure, 1 success */
1889 S_regtry(pTHX_ regexp *prog, char *startpos)
1890 {
1891     register I32 i;
1892     register I32 *sp;
1893     register I32 *ep;
1894     CHECKPOINT lastcp;
1895
1896 #ifdef DEBUGGING
1897     PL_regindent = 0;   /* XXXX Not good when matches are reenterable... */
1898 #endif
1899     if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
1900         MAGIC *mg;
1901
1902         PL_reg_eval_set = RS_init;
1903         DEBUG_r(DEBUG_s(
1904             PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
1905                           (IV)(PL_stack_sp - PL_stack_base));
1906             ));
1907         SAVEI32(cxstack[cxstack_ix].blk_oldsp);
1908         cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
1909         /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
1910         SAVETMPS;
1911         /* Apparently this is not needed, judging by wantarray. */
1912         /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
1913            cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
1914
1915         if (PL_reg_sv) {
1916             /* Make $_ available to executed code. */
1917             if (PL_reg_sv != DEFSV) {
1918                 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
1919                 SAVESPTR(DEFSV);
1920                 DEFSV = PL_reg_sv;
1921             }
1922
1923             if (!(SvTYPE(PL_reg_sv) >= SVt_PVMG && SvMAGIC(PL_reg_sv)
1924                   && (mg = mg_find(PL_reg_sv, PERL_MAGIC_regex_global)))) {
1925                 /* prepare for quick setting of pos */
1926                 sv_magic(PL_reg_sv, (SV*)0,
1927                         PERL_MAGIC_regex_global, Nullch, 0);
1928                 mg = mg_find(PL_reg_sv, PERL_MAGIC_regex_global);
1929                 mg->mg_len = -1;
1930             }
1931             PL_reg_magic    = mg;
1932             PL_reg_oldpos   = mg->mg_len;
1933             SAVEDESTRUCTOR_X(restore_pos, 0);
1934         }
1935         if (!PL_reg_curpm) {
1936             Newz(22,PL_reg_curpm, 1, PMOP);
1937 #ifdef USE_ITHREADS
1938             {
1939                 SV* repointer = newSViv(0);
1940                 /* so we know which PL_regex_padav element is PL_reg_curpm */
1941                 SvFLAGS(repointer) |= SVf_BREAK;
1942                 av_push(PL_regex_padav,repointer);
1943                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
1944                 PL_regex_pad = AvARRAY(PL_regex_padav);
1945             }
1946 #endif
1947         }
1948         PM_SETRE(PL_reg_curpm, prog);
1949         PL_reg_oldcurpm = PL_curpm;
1950         PL_curpm = PL_reg_curpm;
1951         if (RX_MATCH_COPIED(prog)) {
1952             /*  Here is a serious problem: we cannot rewrite subbeg,
1953                 since it may be needed if this match fails.  Thus
1954                 $` inside (?{}) could fail... */
1955             PL_reg_oldsaved = prog->subbeg;
1956             PL_reg_oldsavedlen = prog->sublen;
1957             RX_MATCH_COPIED_off(prog);
1958         }
1959         else
1960             PL_reg_oldsaved = Nullch;
1961         prog->subbeg = PL_bostr;
1962         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
1963     }
1964     prog->startp[0] = startpos - PL_bostr;
1965     PL_reginput = startpos;
1966     PL_regstartp = prog->startp;
1967     PL_regendp = prog->endp;
1968     PL_reglastparen = &prog->lastparen;
1969     PL_reglastcloseparen = &prog->lastcloseparen;
1970     prog->lastparen = 0;
1971     PL_regsize = 0;
1972     DEBUG_r(PL_reg_starttry = startpos);
1973     if (PL_reg_start_tmpl <= prog->nparens) {
1974         PL_reg_start_tmpl = prog->nparens*3/2 + 3;
1975         if(PL_reg_start_tmp)
1976             Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
1977         else
1978             New(22,PL_reg_start_tmp, PL_reg_start_tmpl, char*);
1979     }
1980
1981 #ifdef DEBUGGING
1982     sv_setpvn(PERL_DEBUG_PAD(0), "", 0);
1983     sv_setpvn(PERL_DEBUG_PAD(1), "", 0);
1984     sv_setpvn(PERL_DEBUG_PAD(2), "", 0);
1985 #endif
1986
1987     /* XXXX What this code is doing here?!!!  There should be no need
1988        to do this again and again, PL_reglastparen should take care of
1989        this!  --ilya*/
1990
1991     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
1992      * Actually, the code in regcppop() (which Ilya may be meaning by
1993      * PL_reglastparen), is not needed at all by the test suite
1994      * (op/regexp, op/pat, op/split), but that code is needed, oddly
1995      * enough, for building DynaLoader, or otherwise this
1996      * "Error: '*' not in typemap in DynaLoader.xs, line 164"
1997      * will happen.  Meanwhile, this code *is* needed for the
1998      * above-mentioned test suite tests to succeed.  The common theme
1999      * on those tests seems to be returning null fields from matches.
2000      * --jhi */
2001 #if 1
2002     sp = prog->startp;
2003     ep = prog->endp;
2004     if (prog->nparens) {
2005         for (i = prog->nparens; i > *PL_reglastparen; i--) {
2006             *++sp = -1;
2007             *++ep = -1;
2008         }
2009     }
2010 #endif
2011     REGCP_SET(lastcp);
2012     if (regmatch(prog->program + 1)) {
2013         prog->endp[0] = PL_reginput - PL_bostr;
2014         return 1;
2015     }
2016     REGCP_UNWIND(lastcp);
2017     return 0;
2018 }
2019
2020 #define RE_UNWIND_BRANCH        1
2021 #define RE_UNWIND_BRANCHJ       2
2022
2023 union re_unwind_t;
2024
2025 typedef struct {                /* XX: makes sense to enlarge it... */
2026     I32 type;
2027     I32 prev;
2028     CHECKPOINT lastcp;
2029 } re_unwind_generic_t;
2030
2031 typedef struct {
2032     I32 type;
2033     I32 prev;
2034     CHECKPOINT lastcp;
2035     I32 lastparen;
2036     regnode *next;
2037     char *locinput;
2038     I32 nextchr;
2039 #ifdef DEBUGGING
2040     int regindent;
2041 #endif
2042 } re_unwind_branch_t;
2043
2044 typedef union re_unwind_t {
2045     I32 type;
2046     re_unwind_generic_t generic;
2047     re_unwind_branch_t branch;
2048 } re_unwind_t;
2049
2050 #define sayYES goto yes
2051 #define sayNO goto no
2052 #define sayYES_FINAL goto yes_final
2053 #define sayYES_LOUD  goto yes_loud
2054 #define sayNO_FINAL  goto no_final
2055 #define sayNO_SILENT goto do_no
2056 #define saySAME(x) if (x) goto yes; else goto no
2057
2058 #define REPORT_CODE_OFF 24
2059
2060 /*
2061  - regmatch - main matching routine
2062  *
2063  * Conceptually the strategy is simple:  check to see whether the current
2064  * node matches, call self recursively to see whether the rest matches,
2065  * and then act accordingly.  In practice we make some effort to avoid
2066  * recursion, in particular by going through "ordinary" nodes (that don't
2067  * need to know whether the rest of the match failed) by a loop instead of
2068  * by recursion.
2069  */
2070 /* [lwall] I've hoisted the register declarations to the outer block in order to
2071  * maybe save a little bit of pushing and popping on the stack.  It also takes
2072  * advantage of machines that use a register save mask on subroutine entry.
2073  */
2074 STATIC I32                      /* 0 failure, 1 success */
2075 S_regmatch(pTHX_ regnode *prog)
2076 {
2077     register regnode *scan;     /* Current node. */
2078     regnode *next;              /* Next node. */
2079     regnode *inner;             /* Next node in internal branch. */
2080     register I32 nextchr;       /* renamed nextchr - nextchar colides with
2081                                    function of same name */
2082     register I32 n;             /* no or next */
2083     register I32 ln = 0;        /* len or last */
2084     register char *s = Nullch;  /* operand or save */
2085     register char *locinput = PL_reginput;
2086     register I32 c1 = 0, c2 = 0, paren; /* case fold search, parenth */
2087     int minmod = 0, sw = 0, logical = 0;
2088     I32 unwind = 0;
2089 #if 0
2090     I32 firstcp = PL_savestack_ix;
2091 #endif
2092     register bool do_utf8 = PL_reg_match_utf8;
2093 #ifdef DEBUGGING
2094     SV *dsv0 = PERL_DEBUG_PAD_ZERO(0);
2095     SV *dsv1 = PERL_DEBUG_PAD_ZERO(1);
2096     SV *dsv2 = PERL_DEBUG_PAD_ZERO(2);
2097 #endif
2098
2099 #ifdef DEBUGGING
2100     PL_regindent++;
2101 #endif
2102
2103     /* Note that nextchr is a byte even in UTF */
2104     nextchr = UCHARAT(locinput);
2105     scan = prog;
2106     while (scan != NULL) {
2107
2108         DEBUG_r( {
2109             SV *prop = sv_newmortal();
2110             int docolor = *PL_colors[0];
2111             int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2112             int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
2113             /* The part of the string before starttry has one color
2114                (pref0_len chars), between starttry and current
2115                position another one (pref_len - pref0_len chars),
2116                after the current position the third one.
2117                We assume that pref0_len <= pref_len, otherwise we
2118                decrease pref0_len.  */
2119             int pref_len = (locinput - PL_bostr) > (5 + taill) - l
2120                 ? (5 + taill) - l : locinput - PL_bostr;
2121             int pref0_len;
2122
2123             while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2124                 pref_len++;
2125             pref0_len = pref_len  - (locinput - PL_reg_starttry);
2126             if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
2127                 l = ( PL_regeol - locinput > (5 + taill) - pref_len
2128                       ? (5 + taill) - pref_len : PL_regeol - locinput);
2129             while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2130                 l--;
2131             if (pref0_len < 0)
2132                 pref0_len = 0;
2133             if (pref0_len > pref_len)
2134                 pref0_len = pref_len;
2135             regprop(prop, scan);
2136             {
2137               char *s0 =
2138                 do_utf8 ?
2139                 pv_uni_display(dsv0, (U8*)(locinput - pref_len),
2140                                pref0_len, 60, 0) :
2141                 locinput - pref_len;
2142               int len0 = do_utf8 ? strlen(s0) : pref0_len;
2143               char *s1 = do_utf8 ?
2144                 pv_uni_display(dsv1, (U8*)(locinput - pref_len + pref0_len),
2145                                pref_len - pref0_len, 60, 0) :
2146                 locinput - pref_len + pref0_len;
2147               int len1 = do_utf8 ? strlen(s1) : pref_len - pref0_len;
2148               char *s2 = do_utf8 ?
2149                 pv_uni_display(dsv2, (U8*)locinput,
2150                                PL_regeol - locinput, 60, 0) :
2151                 locinput;
2152               int len2 = do_utf8 ? strlen(s2) : l;
2153               PerlIO_printf(Perl_debug_log,
2154                             "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n",
2155                             (IV)(locinput - PL_bostr),
2156                             PL_colors[4],
2157                             len0, s0,
2158                             PL_colors[5],
2159                             PL_colors[2],
2160                             len1, s1,
2161                             PL_colors[3],
2162                             (docolor ? "" : "> <"),
2163                             PL_colors[0],
2164                             len2, s2,
2165                             PL_colors[1],
2166                             15 - l - pref_len + 1,
2167                             "",
2168                             (IV)(scan - PL_regprogram), PL_regindent*2, "",
2169                             SvPVX(prop));
2170             }
2171         });
2172
2173         next = scan + NEXT_OFF(scan);
2174         if (next == scan)
2175             next = NULL;
2176
2177         switch (OP(scan)) {
2178         case BOL:
2179             if (locinput == PL_bostr || (PL_multiline &&
2180                 (nextchr || locinput < PL_regeol) && locinput[-1] == '\n') )
2181             {
2182                 /* regtill = regbol; */
2183                 break;
2184             }
2185             sayNO;
2186         case MBOL:
2187             if (locinput == PL_bostr ||
2188                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2189             {
2190                 break;
2191             }
2192             sayNO;
2193         case SBOL:
2194             if (locinput == PL_bostr)
2195                 break;
2196             sayNO;
2197         case GPOS:
2198             if (locinput == PL_reg_ganch)
2199                 break;
2200             sayNO;
2201         case EOL:
2202             if (PL_multiline)
2203                 goto meol;
2204             else
2205                 goto seol;
2206         case MEOL:
2207           meol:
2208             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2209                 sayNO;
2210             break;
2211         case SEOL:
2212           seol:
2213             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2214                 sayNO;
2215             if (PL_regeol - locinput > 1)
2216                 sayNO;
2217             break;
2218         case EOS:
2219             if (PL_regeol != locinput)
2220                 sayNO;
2221             break;
2222         case SANY:
2223             if (!nextchr && locinput >= PL_regeol)
2224                 sayNO;
2225             if (do_utf8) {
2226                 locinput += PL_utf8skip[nextchr];
2227                 if (locinput > PL_regeol)
2228                     sayNO;
2229                 nextchr = UCHARAT(locinput);
2230             }
2231             else
2232                 nextchr = UCHARAT(++locinput);
2233             break;
2234         case CANY:
2235             if (!nextchr && locinput >= PL_regeol)
2236                 sayNO;
2237             nextchr = UCHARAT(++locinput);
2238             break;
2239         case REG_ANY:
2240             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2241                 sayNO;
2242             if (do_utf8) {
2243                 locinput += PL_utf8skip[nextchr];
2244                 if (locinput > PL_regeol)
2245                     sayNO;
2246                 nextchr = UCHARAT(locinput);
2247             }
2248             else
2249                 nextchr = UCHARAT(++locinput);
2250             break;
2251         case EXACT:
2252             s = STRING(scan);
2253             ln = STR_LEN(scan);
2254             if (do_utf8 != (UTF!=0)) {
2255                 /* The target and the pattern have differing utf8ness. */
2256                 char *l = locinput;
2257                 char *e = s + ln;
2258                 STRLEN ulen;
2259
2260                 if (do_utf8) {
2261                     /* The target is utf8, the pattern is not utf8. */
2262                     while (s < e) {
2263                         if (l >= PL_regeol)
2264                              sayNO;
2265                         if (NATIVE_TO_UNI(*(U8*)s) !=
2266                             utf8_to_uvchr((U8*)l, &ulen))
2267                              sayNO;
2268                         l += ulen;
2269                         s ++;
2270                     }
2271                 }
2272                 else {
2273                     /* The target is not utf8, the pattern is utf8. */
2274                     while (s < e) {
2275                         if (l >= PL_regeol)
2276                             sayNO;
2277                         if (NATIVE_TO_UNI(*((U8*)l)) !=
2278                             utf8_to_uvchr((U8*)s, &ulen))
2279                             sayNO;
2280                         s += ulen;
2281                         l ++;
2282                     }
2283                 }
2284                 locinput = l;
2285                 nextchr = UCHARAT(locinput);
2286                 break;
2287             }
2288             /* The target and the pattern have the same utf8ness. */
2289             /* Inline the first character, for speed. */
2290             if (UCHARAT(s) != nextchr)
2291                 sayNO;
2292             if (PL_regeol - locinput < ln)
2293                 sayNO;
2294             if (ln > 1 && memNE(s, locinput, ln))
2295                 sayNO;
2296             locinput += ln;
2297             nextchr = UCHARAT(locinput);
2298             break;
2299         case EXACTFL:
2300             PL_reg_flags |= RF_tainted;
2301             /* FALL THROUGH */
2302         case EXACTF:
2303             s = STRING(scan);
2304             ln = STR_LEN(scan);
2305
2306             {
2307                 char *l = locinput;
2308                 char *e = s + ln;
2309                 U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
2310
2311                 if (do_utf8 != (UTF!=0)) {
2312                      /* The target and the pattern have differing utf8ness. */
2313                      STRLEN ulen1, ulen2;
2314                      UV cs, cl;
2315
2316                      if (do_utf8) {
2317                           /* The target is utf8, the pattern is not utf8. */
2318                           while (s < e) {
2319                                if (l >= PL_regeol)
2320                                     sayNO;
2321
2322                                cs = to_uni_fold(NATIVE_TO_UNI(*(U8*)s),
2323                                                 (U8*)s, &ulen1);
2324                                cl = utf8_to_uvchr((U8*)l, &ulen2);
2325
2326                                if (cs != cl) {
2327                                     cl = to_uni_fold(cl, (U8*)l, &ulen2);
2328                                     if (ulen1 != ulen2 || cs != cl)
2329                                          sayNO;
2330                                }
2331                                l += ulen1;
2332                                s ++;
2333                           }
2334                      }
2335                      else {
2336                           /* The target is not utf8, the pattern is utf8. */
2337                           while (s < e) {
2338                                if (l >= PL_regeol)
2339                                     sayNO;
2340
2341                                cs = utf8_to_uvchr((U8*)s, &ulen1);
2342
2343                                cl = to_uni_fold(NATIVE_TO_UNI(*(U8*)l),
2344                                                 (U8*)l, &ulen2);
2345
2346                                if (cs != cl) {
2347                                     cs = to_uni_fold(cs, (U8*)s, &ulen1);
2348                                     if (ulen1 != ulen2 || cs != cl)
2349                                          sayNO;
2350                                }
2351                                l ++;
2352                                s += ulen1;
2353                           }
2354                      }
2355                      locinput = l;
2356                      nextchr = UCHARAT(locinput);
2357                      break;
2358                 }
2359
2360                 if (do_utf8 && UTF) {
2361                      /* Both the target and the pattern are utf8. */
2362                      STRLEN ulen;
2363
2364                      while (s < e) {
2365                           if (l >= PL_regeol)
2366                                sayNO;
2367                           if (UTF8SKIP(s) != UTF8SKIP(l) ||
2368                               memNE(s, (char*)l, UTF8SKIP(s))) {
2369                                to_utf8_fold((U8*)l, tmpbuf, &ulen);
2370                                if (UTF8SKIP(s) != ulen ||
2371                                    memNE(s, (char*)tmpbuf, ulen))
2372                                     sayNO;
2373                           }
2374                           l += UTF8SKIP(l);
2375                           s += UTF8SKIP(s);
2376                      }
2377                      locinput = l;
2378                      nextchr = UCHARAT(locinput);
2379                      break;
2380                 }
2381             }
2382
2383             /* Neither the target and the pattern are utf8. */
2384
2385             /* Inline the first character, for speed. */
2386             if (UCHARAT(s) != nextchr &&
2387                 UCHARAT(s) != ((OP(scan) == EXACTF)
2388                                ? PL_fold : PL_fold_locale)[nextchr])
2389                 sayNO;
2390             if (PL_regeol - locinput < ln)
2391                 sayNO;
2392             if (ln > 1 && (OP(scan) == EXACTF
2393                            ? ibcmp(s, locinput, ln)
2394                            : ibcmp_locale(s, locinput, ln)))
2395                 sayNO;
2396             locinput += ln;
2397             nextchr = UCHARAT(locinput);
2398             break;
2399         case ANYOF:
2400             if (do_utf8) {
2401                 if (!reginclass(scan, (U8*)locinput, do_utf8))
2402                     sayNO;
2403                 if (locinput >= PL_regeol)
2404                     sayNO;
2405                 locinput += PL_utf8skip[nextchr];
2406                 nextchr = UCHARAT(locinput);
2407             }
2408             else {
2409                 if (nextchr < 0)
2410                     nextchr = UCHARAT(locinput);
2411                 if (!reginclass(scan, (U8*)locinput, do_utf8))
2412                     sayNO;
2413                 if (!nextchr && locinput >= PL_regeol)
2414                     sayNO;
2415                 nextchr = UCHARAT(++locinput);
2416             }
2417             break;
2418         case ALNUML:
2419             PL_reg_flags |= RF_tainted;
2420             /* FALL THROUGH */
2421         case ALNUM:
2422             if (!nextchr)
2423                 sayNO;
2424             if (do_utf8) {
2425                 LOAD_UTF8_CHARCLASS(alnum,"a");
2426                 if (!(OP(scan) == ALNUM
2427                       ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
2428                       : isALNUM_LC_utf8((U8*)locinput)))
2429                 {
2430                     sayNO;
2431                 }
2432                 locinput += PL_utf8skip[nextchr];
2433                 nextchr = UCHARAT(locinput);
2434                 break;
2435             }
2436             if (!(OP(scan) == ALNUM
2437                   ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
2438                 sayNO;
2439             nextchr = UCHARAT(++locinput);
2440             break;
2441         case NALNUML:
2442             PL_reg_flags |= RF_tainted;
2443             /* FALL THROUGH */
2444         case NALNUM:
2445             if (!nextchr && locinput >= PL_regeol)
2446                 sayNO;
2447             if (do_utf8) {
2448                 LOAD_UTF8_CHARCLASS(alnum,"a");
2449                 if (OP(scan) == NALNUM
2450                     ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
2451                     : isALNUM_LC_utf8((U8*)locinput))
2452                 {
2453                     sayNO;
2454                 }
2455                 locinput += PL_utf8skip[nextchr];
2456                 nextchr = UCHARAT(locinput);
2457                 break;
2458             }
2459             if (OP(scan) == NALNUM
2460                 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
2461                 sayNO;
2462             nextchr = UCHARAT(++locinput);
2463             break;
2464         case BOUNDL:
2465         case NBOUNDL:
2466             PL_reg_flags |= RF_tainted;
2467             /* FALL THROUGH */
2468         case BOUND:
2469         case NBOUND:
2470             /* was last char in word? */
2471             if (do_utf8) {
2472                 if (locinput == PL_bostr)
2473                     ln = '\n';
2474                 else {
2475                     U8 *r = reghop((U8*)locinput, -1);
2476
2477                     ln = utf8n_to_uvchr(r, s - (char*)r, 0, 0);
2478                 }
2479                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
2480                     ln = isALNUM_uni(ln);
2481                     LOAD_UTF8_CHARCLASS(alnum,"a");
2482                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
2483                 }
2484                 else {
2485                     ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
2486                     n = isALNUM_LC_utf8((U8*)locinput);
2487                 }
2488             }
2489             else {
2490                 ln = (locinput != PL_bostr) ?
2491                     UCHARAT(locinput - 1) : '\n';
2492                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
2493                     ln = isALNUM(ln);
2494                     n = isALNUM(nextchr);
2495                 }
2496                 else {
2497                     ln = isALNUM_LC(ln);
2498                     n = isALNUM_LC(nextchr);
2499                 }
2500             }
2501             if (((!ln) == (!n)) == (OP(scan) == BOUND ||
2502                                     OP(scan) == BOUNDL))
2503                     sayNO;
2504             break;
2505         case SPACEL:
2506             PL_reg_flags |= RF_tainted;
2507             /* FALL THROUGH */
2508         case SPACE:
2509             if (!nextchr)
2510                 sayNO;
2511             if (do_utf8) {
2512                 if (UTF8_IS_CONTINUED(nextchr)) {
2513                     LOAD_UTF8_CHARCLASS(space," ");
2514                     if (!(OP(scan) == SPACE
2515                           ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
2516                           : isSPACE_LC_utf8((U8*)locinput)))
2517                     {
2518                         sayNO;
2519                     }
2520                     locinput += PL_utf8skip[nextchr];
2521                     nextchr = UCHARAT(locinput);
2522                     break;
2523                 }
2524                 if (!(OP(scan) == SPACE
2525                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
2526                     sayNO;
2527                 nextchr = UCHARAT(++locinput);
2528             }
2529             else {
2530                 if (!(OP(scan) == SPACE
2531                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
2532                     sayNO;
2533                 nextchr = UCHARAT(++locinput);
2534             }
2535             break;
2536         case NSPACEL:
2537             PL_reg_flags |= RF_tainted;
2538             /* FALL THROUGH */
2539         case NSPACE:
2540             if (!nextchr && locinput >= PL_regeol)
2541                 sayNO;
2542             if (do_utf8) {
2543                 LOAD_UTF8_CHARCLASS(space," ");
2544                 if (OP(scan) == NSPACE
2545                     ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
2546                     : isSPACE_LC_utf8((U8*)locinput))
2547                 {
2548                     sayNO;
2549                 }
2550                 locinput += PL_utf8skip[nextchr];
2551                 nextchr = UCHARAT(locinput);
2552                 break;
2553             }
2554             if (OP(scan) == NSPACE
2555                 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
2556                 sayNO;
2557             nextchr = UCHARAT(++locinput);
2558             break;
2559         case DIGITL:
2560             PL_reg_flags |= RF_tainted;
2561             /* FALL THROUGH */
2562         case DIGIT:
2563             if (!nextchr)
2564                 sayNO;
2565             if (do_utf8) {
2566                 LOAD_UTF8_CHARCLASS(digit,"0");
2567                 if (!(OP(scan) == DIGIT
2568                       ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
2569                       : isDIGIT_LC_utf8((U8*)locinput)))
2570                 {
2571                     sayNO;
2572                 }
2573                 locinput += PL_utf8skip[nextchr];
2574                 nextchr = UCHARAT(locinput);
2575                 break;
2576             }
2577             if (!(OP(scan) == DIGIT
2578                   ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
2579                 sayNO;
2580             nextchr = UCHARAT(++locinput);
2581             break;
2582         case NDIGITL:
2583             PL_reg_flags |= RF_tainted;
2584             /* FALL THROUGH */
2585         case NDIGIT:
2586             if (!nextchr && locinput >= PL_regeol)
2587                 sayNO;
2588             if (do_utf8) {
2589                 LOAD_UTF8_CHARCLASS(digit,"0");
2590                 if (OP(scan) == NDIGIT
2591                     ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
2592                     : isDIGIT_LC_utf8((U8*)locinput))
2593                 {
2594                     sayNO;
2595                 }
2596                 locinput += PL_utf8skip[nextchr];
2597                 nextchr = UCHARAT(locinput);
2598                 break;
2599             }
2600             if (OP(scan) == NDIGIT
2601                 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
2602                 sayNO;
2603             nextchr = UCHARAT(++locinput);
2604             break;
2605         case CLUMP:
2606             if (locinput >= PL_regeol)
2607                 sayNO;
2608             if  (do_utf8) {
2609                 LOAD_UTF8_CHARCLASS(mark,"~");
2610                 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
2611                     sayNO;
2612                 locinput += PL_utf8skip[nextchr];
2613                 while (locinput < PL_regeol &&
2614                        swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
2615                     locinput += UTF8SKIP(locinput);
2616                 if (locinput > PL_regeol)
2617                     sayNO;
2618             }
2619             else
2620                locinput++;
2621             nextchr = UCHARAT(locinput);
2622             break;
2623         case REFFL:
2624             PL_reg_flags |= RF_tainted;
2625             /* FALL THROUGH */
2626         case REF:
2627         case REFF:
2628             n = ARG(scan);  /* which paren pair */
2629             ln = PL_regstartp[n];
2630             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
2631             if (*PL_reglastparen < n || ln == -1)
2632                 sayNO;                  /* Do not match unless seen CLOSEn. */
2633             if (ln == PL_regendp[n])
2634                 break;
2635
2636             s = PL_bostr + ln;
2637             if (do_utf8 && OP(scan) != REF) {   /* REF can do byte comparison */
2638                 char *l = locinput;
2639                 char *e = PL_bostr + PL_regendp[n];
2640                 /*
2641                  * Note that we can't do the "other character" lookup trick as
2642                  * in the 8-bit case (no pun intended) because in Unicode we
2643                  * have to map both upper and title case to lower case.
2644                  */
2645                 if (OP(scan) == REFF) {
2646                     STRLEN ulen1, ulen2;
2647                     U8 tmpbuf1[UTF8_MAXLEN_UCLC+1];
2648                     U8 tmpbuf2[UTF8_MAXLEN_UCLC+1];
2649                     while (s < e) {
2650                         if (l >= PL_regeol)
2651                             sayNO;
2652                         toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
2653                         toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
2654                         if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
2655                             sayNO;
2656                         s += ulen1;
2657                         l += ulen2;
2658                     }
2659                 }
2660                 locinput = l;
2661                 nextchr = UCHARAT(locinput);
2662                 break;
2663             }
2664
2665             /* Inline the first character, for speed. */
2666             if (UCHARAT(s) != nextchr &&
2667                 (OP(scan) == REF ||
2668                  (UCHARAT(s) != ((OP(scan) == REFF
2669                                   ? PL_fold : PL_fold_locale)[nextchr]))))
2670                 sayNO;
2671             ln = PL_regendp[n] - ln;
2672             if (locinput + ln > PL_regeol)
2673                 sayNO;
2674             if (ln > 1 && (OP(scan) == REF
2675                            ? memNE(s, locinput, ln)
2676                            : (OP(scan) == REFF
2677                               ? ibcmp(s, locinput, ln)
2678                               : ibcmp_locale(s, locinput, ln))))
2679                 sayNO;
2680             locinput += ln;
2681             nextchr = UCHARAT(locinput);
2682             break;
2683
2684         case NOTHING:
2685         case TAIL:
2686             break;
2687         case BACK:
2688             break;
2689         case EVAL:
2690         {
2691             dSP;
2692             OP_4tree *oop = PL_op;
2693             COP *ocurcop = PL_curcop;
2694             SV **ocurpad = PL_curpad;
2695             SV *ret;
2696
2697             n = ARG(scan);
2698             PL_op = (OP_4tree*)PL_regdata->data[n];
2699             DEBUG_r( PerlIO_printf(Perl_debug_log, "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
2700             PL_curpad = AvARRAY((AV*)PL_regdata->data[n + 2]);
2701             PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
2702
2703             {
2704                 SV **before = SP;
2705                 CALLRUNOPS(aTHX);                       /* Scalar context. */
2706                 SPAGAIN;
2707                 if (SP == before)
2708                     ret = Nullsv;   /* protect against empty (?{}) blocks. */
2709                 else {
2710                     ret = POPs;
2711                     PUTBACK;
2712                 }
2713             }
2714
2715             PL_op = oop;
2716             PL_curpad = ocurpad;
2717             PL_curcop = ocurcop;
2718             if (logical) {
2719                 if (logical == 2) {     /* Postponed subexpression. */
2720                     regexp *re;
2721                     MAGIC *mg = Null(MAGIC*);
2722                     re_cc_state state;
2723                     CHECKPOINT cp, lastcp;
2724
2725                     if(SvROK(ret) || SvRMAGICAL(ret)) {
2726                         SV *sv = SvROK(ret) ? SvRV(ret) : ret;
2727
2728                         if(SvMAGICAL(sv))
2729                             mg = mg_find(sv, PERL_MAGIC_qr);
2730                     }
2731                     if (mg) {
2732                         re = (regexp *)mg->mg_obj;
2733                         (void)ReREFCNT_inc(re);
2734                     }
2735                     else {
2736                         STRLEN len;
2737                         char *t = SvPV(ret, len);
2738                         PMOP pm;
2739                         char *oprecomp = PL_regprecomp;
2740                         I32 osize = PL_regsize;
2741                         I32 onpar = PL_regnpar;
2742
2743                         Zero(&pm, 1, PMOP);
2744                         re = CALLREGCOMP(aTHX_ t, t + len, &pm);
2745                         if (!(SvFLAGS(ret)
2746                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)))
2747                             sv_magic(ret,(SV*)ReREFCNT_inc(re),
2748                                         PERL_MAGIC_qr,0,0);
2749                         PL_regprecomp = oprecomp;
2750                         PL_regsize = osize;
2751                         PL_regnpar = onpar;
2752                     }
2753                     DEBUG_r(
2754                         PerlIO_printf(Perl_debug_log,
2755                                       "Entering embedded `%s%.60s%s%s'\n",
2756                                       PL_colors[0],
2757                                       re->precomp,
2758                                       PL_colors[1],
2759                                       (strlen(re->precomp) > 60 ? "..." : ""))
2760                         );
2761                     state.node = next;
2762                     state.prev = PL_reg_call_cc;
2763                     state.cc = PL_regcc;
2764                     state.re = PL_reg_re;
2765
2766                     PL_regcc = 0;
2767
2768                     cp = regcppush(0);  /* Save *all* the positions. */
2769                     REGCP_SET(lastcp);
2770                     cache_re(re);
2771                     state.ss = PL_savestack_ix;
2772                     *PL_reglastparen = 0;
2773                     *PL_reglastcloseparen = 0;
2774                     PL_reg_call_cc = &state;
2775                     PL_reginput = locinput;
2776
2777                     /* XXXX This is too dramatic a measure... */
2778                     PL_reg_maxiter = 0;
2779
2780                     if (regmatch(re->program + 1)) {
2781                         /* Even though we succeeded, we need to restore
2782                            global variables, since we may be wrapped inside
2783                            SUSPEND, thus the match may be not finished yet. */
2784
2785                         /* XXXX Do this only if SUSPENDed? */
2786                         PL_reg_call_cc = state.prev;
2787                         PL_regcc = state.cc;
2788                         PL_reg_re = state.re;
2789                         cache_re(PL_reg_re);
2790
2791                         /* XXXX This is too dramatic a measure... */
2792                         PL_reg_maxiter = 0;
2793
2794                         /* These are needed even if not SUSPEND. */
2795                         ReREFCNT_dec(re);
2796                         regcpblow(cp);
2797                         sayYES;
2798                     }
2799                     ReREFCNT_dec(re);
2800                     REGCP_UNWIND(lastcp);
2801                     regcppop();
2802                     PL_reg_call_cc = state.prev;
2803                     PL_regcc = state.cc;
2804                     PL_reg_re = state.re;
2805                     cache_re(PL_reg_re);
2806
2807                     /* XXXX This is too dramatic a measure... */
2808                     PL_reg_maxiter = 0;
2809
2810                     logical = 0;
2811                     sayNO;
2812                 }
2813                 sw = SvTRUE(ret);
2814                 logical = 0;
2815             }
2816             else
2817                 sv_setsv(save_scalar(PL_replgv), ret);
2818             break;
2819         }
2820         case OPEN:
2821             n = ARG(scan);  /* which paren pair */
2822             PL_reg_start_tmp[n] = locinput;
2823             if (n > PL_regsize)
2824                 PL_regsize = n;
2825             break;
2826         case CLOSE:
2827             n = ARG(scan);  /* which paren pair */
2828             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
2829             PL_regendp[n] = locinput - PL_bostr;
2830             if (n > *PL_reglastparen)
2831                 *PL_reglastparen = n;
2832             *PL_reglastcloseparen = n;
2833             break;
2834         case GROUPP:
2835             n = ARG(scan);  /* which paren pair */
2836             sw = (*PL_reglastparen >= n && PL_regendp[n] != -1);
2837             break;
2838         case IFTHEN:
2839             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
2840             if (sw)
2841                 next = NEXTOPER(NEXTOPER(scan));
2842             else {
2843                 next = scan + ARG(scan);
2844                 if (OP(next) == IFTHEN) /* Fake one. */
2845                     next = NEXTOPER(NEXTOPER(next));
2846             }
2847             break;
2848         case LOGICAL:
2849             logical = scan->flags;
2850             break;
2851 /*******************************************************************
2852  PL_regcc contains infoblock about the innermost (...)* loop, and
2853  a pointer to the next outer infoblock.
2854
2855  Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
2856
2857    1) After matching X, regnode for CURLYX is processed;
2858
2859    2) This regnode creates infoblock on the stack, and calls
2860       regmatch() recursively with the starting point at WHILEM node;
2861
2862    3) Each hit of WHILEM node tries to match A and Z (in the order
2863       depending on the current iteration, min/max of {min,max} and
2864       greediness).  The information about where are nodes for "A"
2865       and "Z" is read from the infoblock, as is info on how many times "A"
2866       was already matched, and greediness.
2867
2868    4) After A matches, the same WHILEM node is hit again.
2869
2870    5) Each time WHILEM is hit, PL_regcc is the infoblock created by CURLYX
2871       of the same pair.  Thus when WHILEM tries to match Z, it temporarily
2872       resets PL_regcc, since this Y(A)*Z can be a part of some other loop:
2873       as in (Y(A)*Z)*.  If Z matches, the automaton will hit the WHILEM node
2874       of the external loop.
2875
2876  Currently present infoblocks form a tree with a stem formed by PL_curcc
2877  and whatever it mentions via ->next, and additional attached trees
2878  corresponding to temporarily unset infoblocks as in "5" above.
2879
2880  In the following picture infoblocks for outer loop of
2881  (Y(A)*?Z)*?T are denoted O, for inner I.  NULL starting block
2882  is denoted by x.  The matched string is YAAZYAZT.  Temporarily postponed
2883  infoblocks are drawn below the "reset" infoblock.
2884
2885  In fact in the picture below we do not show failed matches for Z and T
2886  by WHILEM blocks.  [We illustrate minimal matches, since for them it is
2887  more obvious *why* one needs to *temporary* unset infoblocks.]
2888
2889   Matched       REx position    InfoBlocks      Comment
2890                 (Y(A)*?Z)*?T    x
2891                 Y(A)*?Z)*?T     x <- O
2892   Y             (A)*?Z)*?T      x <- O
2893   Y             A)*?Z)*?T       x <- O <- I
2894   YA            )*?Z)*?T        x <- O <- I
2895   YA            A)*?Z)*?T       x <- O <- I
2896   YAA           )*?Z)*?T        x <- O <- I
2897   YAA           Z)*?T           x <- O          # Temporary unset I
2898                                      I
2899
2900   YAAZ          Y(A)*?Z)*?T     x <- O
2901                                      I
2902
2903   YAAZY         (A)*?Z)*?T      x <- O
2904                                      I
2905
2906   YAAZY         A)*?Z)*?T       x <- O <- I
2907                                      I
2908
2909   YAAZYA        )*?Z)*?T        x <- O <- I
2910                                      I
2911
2912   YAAZYA        Z)*?T           x <- O          # Temporary unset I
2913                                      I,I
2914
2915   YAAZYAZ       )*?T            x <- O
2916                                      I,I
2917
2918   YAAZYAZ       T               x               # Temporary unset O
2919                                 O
2920                                 I,I
2921
2922   YAAZYAZT                      x
2923                                 O
2924                                 I,I
2925  *******************************************************************/
2926         case CURLYX: {
2927                 CURCUR cc;
2928                 CHECKPOINT cp = PL_savestack_ix;
2929                 /* No need to save/restore up to this paren */
2930                 I32 parenfloor = scan->flags;
2931
2932                 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
2933                     next += ARG(next);
2934                 cc.oldcc = PL_regcc;
2935                 PL_regcc = &cc;
2936                 /* XXXX Probably it is better to teach regpush to support
2937                    parenfloor > PL_regsize... */
2938                 if (parenfloor > *PL_reglastparen)
2939                     parenfloor = *PL_reglastparen; /* Pessimization... */
2940                 cc.parenfloor = parenfloor;
2941                 cc.cur = -1;
2942                 cc.min = ARG1(scan);
2943                 cc.max  = ARG2(scan);
2944                 cc.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
2945                 cc.next = next;
2946                 cc.minmod = minmod;
2947                 cc.lastloc = 0;
2948                 PL_reginput = locinput;
2949                 n = regmatch(PREVOPER(next));   /* start on the WHILEM */
2950                 regcpblow(cp);
2951                 PL_regcc = cc.oldcc;
2952                 saySAME(n);
2953             }
2954             /* NOT REACHED */
2955         case WHILEM: {
2956                 /*
2957                  * This is really hard to understand, because after we match
2958                  * what we're trying to match, we must make sure the rest of
2959                  * the REx is going to match for sure, and to do that we have
2960                  * to go back UP the parse tree by recursing ever deeper.  And
2961                  * if it fails, we have to reset our parent's current state
2962                  * that we can try again after backing off.
2963                  */
2964
2965                 CHECKPOINT cp, lastcp;
2966                 CURCUR* cc = PL_regcc;
2967                 char *lastloc = cc->lastloc; /* Detection of 0-len. */
2968
2969                 n = cc->cur + 1;        /* how many we know we matched */
2970                 PL_reginput = locinput;
2971
2972                 DEBUG_r(
2973                     PerlIO_printf(Perl_debug_log,
2974                                   "%*s  %ld out of %ld..%ld  cc=%lx\n",
2975                                   REPORT_CODE_OFF+PL_regindent*2, "",
2976                                   (long)n, (long)cc->min,
2977                                   (long)cc->max, (long)cc)
2978                     );
2979
2980                 /* If degenerate scan matches "", assume scan done. */
2981
2982                 if (locinput == cc->lastloc && n >= cc->min) {
2983                     PL_regcc = cc->oldcc;
2984                     if (PL_regcc)
2985                         ln = PL_regcc->cur;
2986                     DEBUG_r(
2987                         PerlIO_printf(Perl_debug_log,
2988                            "%*s  empty match detected, try continuation...\n",
2989                            REPORT_CODE_OFF+PL_regindent*2, "")
2990                         );
2991                     if (regmatch(cc->next))
2992                         sayYES;
2993                     if (PL_regcc)
2994                         PL_regcc->cur = ln;
2995                     PL_regcc = cc;
2996                     sayNO;
2997                 }
2998
2999                 /* First just match a string of min scans. */
3000
3001                 if (n < cc->min) {
3002                     cc->cur = n;
3003                     cc->lastloc = locinput;
3004                     if (regmatch(cc->scan))
3005                         sayYES;
3006                     cc->cur = n - 1;
3007                     cc->lastloc = lastloc;
3008                     sayNO;
3009                 }
3010
3011                 if (scan->flags) {
3012                     /* Check whether we already were at this position.
3013                         Postpone detection until we know the match is not
3014                         *that* much linear. */
3015                 if (!PL_reg_maxiter) {
3016                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
3017                     PL_reg_leftiter = PL_reg_maxiter;
3018                 }
3019                 if (PL_reg_leftiter-- == 0) {
3020                     I32 size = (PL_reg_maxiter + 7)/8;
3021                     if (PL_reg_poscache) {
3022                         if (PL_reg_poscache_size < size) {
3023                             Renew(PL_reg_poscache, size, char);
3024                             PL_reg_poscache_size = size;
3025                         }
3026                         Zero(PL_reg_poscache, size, char);
3027                     }
3028                     else {
3029                         PL_reg_poscache_size = size;
3030                         Newz(29, PL_reg_poscache, size, char);
3031                     }
3032                     DEBUG_r(
3033                         PerlIO_printf(Perl_debug_log,
3034               "%sDetected a super-linear match, switching on caching%s...\n",
3035                                       PL_colors[4], PL_colors[5])
3036                         );
3037                 }
3038                 if (PL_reg_leftiter < 0) {
3039                     I32 o = locinput - PL_bostr, b;
3040
3041                     o = (scan->flags & 0xf) - 1 + o * (scan->flags>>4);
3042                     b = o % 8;
3043                     o /= 8;
3044                     if (PL_reg_poscache[o] & (1<<b)) {
3045                     DEBUG_r(
3046                         PerlIO_printf(Perl_debug_log,
3047                                       "%*s  already tried at this position...\n",
3048                                       REPORT_CODE_OFF+PL_regindent*2, "")
3049                         );
3050                         sayNO_SILENT;
3051                     }
3052                     PL_reg_poscache[o] |= (1<<b);
3053                 }
3054                 }
3055
3056                 /* Prefer next over scan for minimal matching. */
3057
3058                 if (cc->minmod) {
3059                     PL_regcc = cc->oldcc;
3060                     if (PL_regcc)
3061                         ln = PL_regcc->cur;
3062                     cp = regcppush(cc->parenfloor);
3063                     REGCP_SET(lastcp);
3064                     if (regmatch(cc->next)) {
3065                         regcpblow(cp);
3066                         sayYES; /* All done. */
3067                     }
3068                     REGCP_UNWIND(lastcp);
3069                     regcppop();
3070                     if (PL_regcc)
3071                         PL_regcc->cur = ln;
3072                     PL_regcc = cc;
3073
3074                     if (n >= cc->max) { /* Maximum greed exceeded? */
3075                         if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3076                             && !(PL_reg_flags & RF_warned)) {
3077                             PL_reg_flags |= RF_warned;
3078                             Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
3079                                  "Complex regular subexpression recursion",
3080                                  REG_INFTY - 1);
3081                         }
3082                         sayNO;
3083                     }
3084
3085                     DEBUG_r(
3086                         PerlIO_printf(Perl_debug_log,
3087                                       "%*s  trying longer...\n",
3088                                       REPORT_CODE_OFF+PL_regindent*2, "")
3089                         );
3090                     /* Try scanning more and see if it helps. */
3091                     PL_reginput = locinput;
3092                     cc->cur = n;
3093                     cc->lastloc = locinput;
3094                     cp = regcppush(cc->parenfloor);
3095                     REGCP_SET(lastcp);
3096                     if (regmatch(cc->scan)) {
3097                         regcpblow(cp);
3098                         sayYES;
3099                     }
3100                     REGCP_UNWIND(lastcp);
3101                     regcppop();
3102                     cc->cur = n - 1;
3103                     cc->lastloc = lastloc;
3104                     sayNO;
3105                 }
3106
3107                 /* Prefer scan over next for maximal matching. */
3108
3109                 if (n < cc->max) {      /* More greed allowed? */
3110                     cp = regcppush(cc->parenfloor);
3111                     cc->cur = n;
3112                     cc->lastloc = locinput;
3113                     REGCP_SET(lastcp);
3114                     if (regmatch(cc->scan)) {
3115                         regcpblow(cp);
3116                         sayYES;
3117                     }
3118                     REGCP_UNWIND(lastcp);
3119                     regcppop();         /* Restore some previous $<digit>s? */
3120                     PL_reginput = locinput;
3121                     DEBUG_r(
3122                         PerlIO_printf(Perl_debug_log,
3123                                       "%*s  failed, try continuation...\n",
3124                                       REPORT_CODE_OFF+PL_regindent*2, "")
3125                         );
3126                 }
3127                 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3128                         && !(PL_reg_flags & RF_warned)) {
3129                     PL_reg_flags |= RF_warned;
3130                     Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
3131                          "Complex regular subexpression recursion",
3132                          REG_INFTY - 1);
3133                 }
3134
3135                 /* Failed deeper matches of scan, so see if this one works. */
3136                 PL_regcc = cc->oldcc;
3137                 if (PL_regcc)
3138                     ln = PL_regcc->cur;
3139                 if (regmatch(cc->next))
3140                     sayYES;
3141                 if (PL_regcc)
3142                     PL_regcc->cur = ln;
3143                 PL_regcc = cc;
3144                 cc->cur = n - 1;
3145                 cc->lastloc = lastloc;
3146                 sayNO;
3147             }
3148             /* NOT REACHED */
3149         case BRANCHJ:
3150             next = scan + ARG(scan);
3151             if (next == scan)
3152                 next = NULL;
3153             inner = NEXTOPER(NEXTOPER(scan));
3154             goto do_branch;
3155         case BRANCH:
3156             inner = NEXTOPER(scan);
3157           do_branch:
3158             {
3159                 c1 = OP(scan);
3160                 if (OP(next) != c1)     /* No choice. */
3161                     next = inner;       /* Avoid recursion. */
3162                 else {
3163                     I32 lastparen = *PL_reglastparen;
3164                     I32 unwind1;
3165                     re_unwind_branch_t *uw;
3166
3167                     /* Put unwinding data on stack */
3168                     unwind1 = SSNEWt(1,re_unwind_branch_t);
3169                     uw = SSPTRt(unwind1,re_unwind_branch_t);
3170                     uw->prev = unwind;
3171                     unwind = unwind1;
3172                     uw->type = ((c1 == BRANCH)
3173                                 ? RE_UNWIND_BRANCH
3174                                 : RE_UNWIND_BRANCHJ);
3175                     uw->lastparen = lastparen;
3176                     uw->next = next;
3177                     uw->locinput = locinput;
3178                     uw->nextchr = nextchr;
3179 #ifdef DEBUGGING
3180                     uw->regindent = ++PL_regindent;
3181 #endif
3182
3183                     REGCP_SET(uw->lastcp);
3184
3185                     /* Now go into the first branch */
3186                     next = inner;
3187                 }
3188             }
3189             break;
3190         case MINMOD:
3191             minmod = 1;
3192             break;
3193         case CURLYM:
3194         {
3195             I32 l = 0;
3196             CHECKPOINT lastcp;
3197
3198             /* We suppose that the next guy does not need
3199                backtracking: in particular, it is of constant length,
3200                and has no parenths to influence future backrefs. */
3201             ln = ARG1(scan);  /* min to match */
3202             n  = ARG2(scan);  /* max to match */
3203             paren = scan->flags;
3204             if (paren) {
3205                 if (paren > PL_regsize)
3206                     PL_regsize = paren;
3207                 if (paren > *PL_reglastparen)
3208                     *PL_reglastparen = paren;
3209             }
3210             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3211             if (paren)
3212                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
3213             PL_reginput = locinput;
3214             if (minmod) {
3215                 minmod = 0;
3216                 if (ln && regrepeat_hard(scan, ln, &l) < ln)
3217                     sayNO;
3218                 /* if we matched something zero-length we don't need to
3219                    backtrack - capturing parens are already defined, so
3220                    the caveat in the maximal case doesn't apply
3221
3222                    XXXX if ln == 0, we can redo this check first time
3223                    through the following loop
3224                 */
3225                 if (ln && l == 0)
3226                     n = ln;     /* don't backtrack */
3227                 locinput = PL_reginput;
3228                 if (HAS_TEXT(next) || JUMPABLE(next)) {
3229                     regnode *text_node = next;
3230
3231                     if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
3232
3233                     if (! HAS_TEXT(text_node)) c1 = c2 = -1000;
3234                     else {
3235                         if (PL_regkind[(U8)OP(text_node)] == REF) {
3236                             I32 n, ln;
3237                             n = ARG(text_node);  /* which paren pair */
3238                             ln = PL_regstartp[n];
3239                             /* assume yes if we haven't seen CLOSEn */
3240                             if (
3241                                 *PL_reglastparen < n ||
3242                                 ln == -1 ||
3243                                 ln == PL_regendp[n]
3244                             ) {
3245                                 c1 = c2 = -1000;
3246                                 goto assume_ok_MM;
3247                             }
3248                             c1 = *(PL_bostr + ln);
3249                         }
3250                         else { c1 = (U8)*STRING(text_node); }
3251                         if (OP(text_node) == EXACTF || OP(text_node) == REFF)
3252                             c2 = PL_fold[c1];
3253                         else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
3254                             c2 = PL_fold_locale[c1];
3255                         else
3256                             c2 = c1;
3257                     }
3258                 }
3259                 else
3260                     c1 = c2 = -1000;
3261             assume_ok_MM:
3262                 REGCP_SET(lastcp);
3263                 /* This may be improved if l == 0.  */
3264                 while (n >= ln || (n == REG_INFTY && ln > 0 && l)) { /* ln overflow ? */
3265                     /* If it could work, try it. */
3266                     if (c1 == -1000 ||
3267                         UCHARAT(PL_reginput) == c1 ||
3268                         UCHARAT(PL_reginput) == c2)
3269                     {
3270                         if (paren) {
3271                             if (ln) {
3272                                 PL_regstartp[paren] =
3273                                     HOPc(PL_reginput, -l) - PL_bostr;
3274                                 PL_regendp[paren] = PL_reginput - PL_bostr;
3275                             }
3276                             else
3277                                 PL_regendp[paren] = -1;
3278                         }
3279                         if (regmatch(next))
3280                             sayYES;
3281                         REGCP_UNWIND(lastcp);
3282                     }
3283                     /* Couldn't or didn't -- move forward. */
3284                     PL_reginput = locinput;
3285                     if (regrepeat_hard(scan, 1, &l)) {
3286                         ln++;
3287                         locinput = PL_reginput;
3288                     }
3289                     else
3290                         sayNO;
3291                 }
3292             }
3293             else {
3294                 n = regrepeat_hard(scan, n, &l);
3295                 /* if we matched something zero-length we don't need to
3296                    backtrack, unless the minimum count is zero and we
3297                    are capturing the result - in that case the capture
3298                    being defined or not may affect later execution
3299                 */
3300                 if (n != 0 && l == 0 && !(paren && ln == 0))
3301                     ln = n;     /* don't backtrack */
3302                 locinput = PL_reginput;
3303                 DEBUG_r(
3304                     PerlIO_printf(Perl_debug_log,
3305                                   "%*s  matched %"IVdf" times, len=%"IVdf"...\n",
3306                                   (int)(REPORT_CODE_OFF+PL_regindent*2), "",
3307                                   (IV) n, (IV)l)
3308                     );
3309                 if (n >= ln) {
3310                     if (HAS_TEXT(next) || JUMPABLE(next)) {
3311                         regnode *text_node = next;
3312
3313                         if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
3314
3315                         if (! HAS_TEXT(text_node)) c1 = c2 = -1000;
3316                         else {
3317                             if (PL_regkind[(U8)OP(text_node)] == REF) {
3318                                 I32 n, ln;
3319                                 n = ARG(text_node);  /* which paren pair */
3320                                 ln = PL_regstartp[n];
3321                                 /* assume yes if we haven't seen CLOSEn */
3322                                 if (
3323                                     *PL_reglastparen < n ||
3324                                     ln == -1 ||
3325                                     ln == PL_regendp[n]
3326                                 ) {
3327                                     c1 = c2 = -1000;
3328                                     goto assume_ok_REG;
3329                                 }
3330                                 c1 = *(PL_bostr + ln);
3331                             }
3332                             else { c1 = (U8)*STRING(text_node); }
3333
3334                             if (OP(text_node) == EXACTF || OP(text_node) == REFF)
3335                                 c2 = PL_fold[c1];
3336                             else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
3337                                 c2 = PL_fold_locale[c1];
3338                             else
3339                                 c2 = c1;
3340                         }
3341                     }
3342                     else
3343                         c1 = c2 = -1000;
3344                 }
3345             assume_ok_REG:
3346                 REGCP_SET(lastcp);
3347                 while (n >= ln) {
3348                     /* If it could work, try it. */
3349                     if (c1 == -1000 ||
3350                         UCHARAT(PL_reginput) == c1 ||
3351                         UCHARAT(PL_reginput) == c2)
3352                     {
3353                         DEBUG_r(
3354                                 PerlIO_printf(Perl_debug_log,
3355                                               "%*s  trying tail with n=%"IVdf"...\n",
3356                                               (int)(REPORT_CODE_OFF+PL_regindent*2), "", (IV)n)
3357                             );
3358                         if (paren) {
3359                             if (n) {
3360                                 PL_regstartp[paren] = HOPc(PL_reginput, -l) - PL_bostr;
3361                                 PL_regendp[paren] = PL_reginput - PL_bostr;
3362                             }
3363                             else
3364                                 PL_regendp[paren] = -1;
3365                         }
3366                         if (regmatch(next))
3367                             sayYES;
3368                         REGCP_UNWIND(lastcp);
3369                     }
3370                     /* Couldn't or didn't -- back up. */
3371                     n--;
3372                     locinput = HOPc(locinput, -l);
3373                     PL_reginput = locinput;
3374                 }
3375             }
3376             sayNO;
3377             break;
3378         }
3379         case CURLYN:
3380             paren = scan->flags;        /* Which paren to set */
3381             if (paren > PL_regsize)
3382                 PL_regsize = paren;
3383             if (paren > *PL_reglastparen)
3384                 *PL_reglastparen = paren;
3385             ln = ARG1(scan);  /* min to match */
3386             n  = ARG2(scan);  /* max to match */
3387             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
3388             goto repeat;
3389         case CURLY:
3390             paren = 0;
3391             ln = ARG1(scan);  /* min to match */
3392             n  = ARG2(scan);  /* max to match */
3393             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3394             goto repeat;
3395         case STAR:
3396             ln = 0;
3397             n = REG_INFTY;
3398             scan = NEXTOPER(scan);
3399             paren = 0;
3400             goto repeat;
3401         case PLUS:
3402             ln = 1;
3403             n = REG_INFTY;
3404             scan = NEXTOPER(scan);
3405             paren = 0;
3406           repeat:
3407             /*
3408             * Lookahead to avoid useless match attempts
3409             * when we know what character comes next.
3410             */
3411
3412             /*
3413             * Used to only do .*x and .*?x, but now it allows
3414             * for )'s, ('s and (?{ ... })'s to be in the way
3415             * of the quantifier and the EXACT-like node.  -- japhy
3416             */
3417
3418             if (HAS_TEXT(next) || JUMPABLE(next)) {
3419                 U8 *s;
3420                 regnode *text_node = next;
3421
3422                 if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
3423
3424                 if (! HAS_TEXT(text_node)) c1 = c2 = -1000;
3425                 else {
3426                     if (PL_regkind[(U8)OP(text_node)] == REF) {
3427                         I32 n, ln;
3428                         n = ARG(text_node);  /* which paren pair */
3429                         ln = PL_regstartp[n];
3430                         /* assume yes if we haven't seen CLOSEn */
3431                         if (
3432                             *PL_reglastparen < n ||
3433                             ln == -1 ||
3434                             ln == PL_regendp[n]
3435                         ) {
3436                             c1 = c2 = -1000;
3437                             goto assume_ok_easy;
3438                         }
3439                         s = (U8*)PL_bostr + ln;
3440                     }
3441                     else { s = (U8*)STRING(text_node); }
3442
3443                     if (!UTF) {
3444                         c2 = c1 = *s;
3445                         if (OP(text_node) == EXACTF || OP(text_node) == REFF)
3446                             c2 = PL_fold[c1];
3447                         else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
3448                             c2 = PL_fold_locale[c1];
3449                     }
3450                     else { /* UTF */
3451                         if (OP(text_node) == EXACTF || OP(text_node) == REFF) {
3452                              STRLEN ulen1, ulen2;
3453                              U8 tmpbuf1[UTF8_MAXLEN_UCLC+1];
3454                              U8 tmpbuf2[UTF8_MAXLEN_UCLC+1];
3455
3456                              to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
3457                              to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
3458
3459                              c1 = utf8_to_uvuni(tmpbuf1, 0);
3460                              c2 = utf8_to_uvuni(tmpbuf2, 0);
3461                         }
3462                         else {
3463                             c2 = c1 = utf8_to_uvchr(s, NULL);
3464                         }
3465                     }
3466                 }
3467             }
3468             else
3469                 c1 = c2 = -1000;
3470         assume_ok_easy:
3471             PL_reginput = locinput;
3472             if (minmod) {
3473                 CHECKPOINT lastcp;
3474                 minmod = 0;
3475                 if (ln && regrepeat(scan, ln) < ln)
3476                     sayNO;
3477                 locinput = PL_reginput;
3478                 REGCP_SET(lastcp);
3479                 if (c1 != -1000) {
3480                     char *e; /* Should not check after this */
3481                     char *old = locinput;
3482
3483                     if  (n == REG_INFTY) {
3484                         e = PL_regeol - 1;
3485                         if (do_utf8)
3486                             while (UTF8_IS_CONTINUATION(*(U8*)e))
3487                                 e--;
3488                     }
3489                     else if (do_utf8) {
3490                         int m = n - ln;
3491                         for (e = locinput;
3492                              m >0 && e + UTF8SKIP(e) <= PL_regeol; m--)
3493                             e += UTF8SKIP(e);
3494                     }
3495                     else {
3496                         e = locinput + n - ln;
3497                         if (e >= PL_regeol)
3498                             e = PL_regeol - 1;
3499                     }
3500                     while (1) {
3501                         int count;
3502                         /* Find place 'next' could work */
3503                         if (!do_utf8) {
3504                             if (c1 == c2) {
3505                                 while (locinput <= e &&
3506                                        UCHARAT(locinput) != c1)
3507                                     locinput++;
3508                             } else {
3509                                 while (locinput <= e
3510                                        && UCHARAT(locinput) != c1
3511                                        && UCHARAT(locinput) != c2)
3512                                     locinput++;
3513                             }
3514                             count = locinput - old;
3515                         }
3516                         else {
3517                             STRLEN len;
3518                             if (c1 == c2) {
3519                                 for (count = 0;
3520                                      locinput <= e &&
3521                                          utf8_to_uvchr((U8*)locinput, &len) != c1;
3522                                      count++)
3523                                     locinput += len;
3524
3525                             } else {
3526                                 for (count = 0; locinput <= e; count++) {
3527                                     UV c = utf8_to_uvchr((U8*)locinput, &len);
3528                                     if (c == c1 || c == c2)
3529                                         break;
3530                                     locinput += len;
3531                                 }
3532                             }
3533                         }
3534                         if (locinput > e)
3535                             sayNO;
3536                         /* PL_reginput == old now */
3537                         if (locinput != old) {
3538                             ln = 1;     /* Did some */
3539                             if (regrepeat(scan, count) < count)
3540                                 sayNO;
3541                         }
3542                         /* PL_reginput == locinput now */
3543                         TRYPAREN(paren, ln, locinput);
3544                         PL_reginput = locinput; /* Could be reset... */
3545                         REGCP_UNWIND(lastcp);
3546                         /* Couldn't or didn't -- move forward. */
3547                         old = locinput;
3548                         if (do_utf8)
3549                             locinput += UTF8SKIP(locinput);
3550                         else
3551                             locinput++;
3552                     }
3553                 }
3554                 else
3555                 while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */
3556                     UV c;
3557                     if (c1 != -1000) {
3558                         if (do_utf8)
3559                             c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3560                         else
3561                             c = UCHARAT(PL_reginput);
3562                         /* If it could work, try it. */
3563                         if (c == c1 || c == c2)
3564                         {
3565                             TRYPAREN(paren, n, PL_reginput);
3566                             REGCP_UNWIND(lastcp);
3567                         }
3568                     }
3569                     /* If it could work, try it. */
3570                     else if (c1 == -1000)
3571                     {
3572                         TRYPAREN(paren, n, PL_reginput);
3573                         REGCP_UNWIND(lastcp);
3574                     }
3575                     /* Couldn't or didn't -- move forward. */
3576                     PL_reginput = locinput;
3577                     if (regrepeat(scan, 1)) {
3578                         ln++;
3579                         locinput = PL_reginput;
3580                     }
3581                     else
3582                         sayNO;
3583                 }
3584             }
3585             else {
3586                 CHECKPOINT lastcp;
3587                 n = regrepeat(scan, n);
3588                 locinput = PL_reginput;
3589                 if (ln < n && PL_regkind[(U8)OP(next)] == EOL &&
3590                     (!PL_multiline  || OP(next) == SEOL || OP(next) == EOS)) {
3591                     ln = n;                     /* why back off? */
3592                     /* ...because $ and \Z can match before *and* after
3593                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
3594                        We should back off by one in this case. */
3595                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
3596                         ln--;
3597                 }
3598                 REGCP_SET(lastcp);
3599                 if (paren) {
3600                     UV c = 0;
3601                     while (n >= ln) {
3602                         if (c1 != -1000) {
3603                             if (do_utf8)
3604                                 c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3605                             else
3606                                 c = UCHARAT(PL_reginput);
3607                         }
3608                         /* If it could work, try it. */
3609                         if (c1 == -1000 || c == c1 || c == c2)
3610                             {
3611                                 TRYPAREN(paren, n, PL_reginput);
3612                                 REGCP_UNWIND(lastcp);
3613                             }
3614                         /* Couldn't or didn't -- back up. */
3615                         n--;
3616                         PL_reginput = locinput = HOPc(locinput, -1);
3617                     }
3618                 }
3619                 else {
3620                     UV c = 0;
3621                     while (n >= ln) {
3622                         if (c1 != -1000) {
3623                             if (do_utf8)
3624                                 c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3625                             else
3626                                 c = UCHARAT(PL_reginput);
3627                         }
3628                         /* If it could work, try it. */
3629                         if (c1 == -1000 || c == c1 || c == c2)
3630                             {
3631                                 TRYPAREN(paren, n, PL_reginput);
3632                                 REGCP_UNWIND(lastcp);
3633                             }
3634                         /* Couldn't or didn't -- back up. */
3635                         n--;
3636                         PL_reginput = locinput = HOPc(locinput, -1);
3637                     }
3638                 }
3639             }
3640             sayNO;
3641             break;
3642         case END:
3643             if (PL_reg_call_cc) {
3644                 re_cc_state *cur_call_cc = PL_reg_call_cc;
3645                 CURCUR *cctmp = PL_regcc;
3646                 regexp *re = PL_reg_re;
3647                 CHECKPOINT cp, lastcp;
3648
3649                 cp = regcppush(0);      /* Save *all* the positions. */
3650                 REGCP_SET(lastcp);
3651                 regcp_set_to(PL_reg_call_cc->ss); /* Restore parens of
3652                                                     the caller. */
3653                 PL_reginput = locinput; /* Make position available to
3654                                            the callcc. */
3655                 cache_re(PL_reg_call_cc->re);
3656                 PL_regcc = PL_reg_call_cc->cc;
3657                 PL_reg_call_cc = PL_reg_call_cc->prev;
3658                 if (regmatch(cur_call_cc->node)) {
3659                     PL_reg_call_cc = cur_call_cc;
3660                     regcpblow(cp);
3661                     sayYES;
3662                 }
3663                 REGCP_UNWIND(lastcp);
3664                 regcppop();
3665                 PL_reg_call_cc = cur_call_cc;
3666                 PL_regcc = cctmp;
3667                 PL_reg_re = re;
3668                 cache_re(re);
3669
3670                 DEBUG_r(
3671                     PerlIO_printf(Perl_debug_log,
3672                                   "%*s  continuation failed...\n",
3673                                   REPORT_CODE_OFF+PL_regindent*2, "")
3674                     );
3675                 sayNO_SILENT;
3676             }
3677             if (locinput < PL_regtill) {
3678                 DEBUG_r(PerlIO_printf(Perl_debug_log,
3679                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
3680                                       PL_colors[4],
3681                                       (long)(locinput - PL_reg_starttry),
3682                                       (long)(PL_regtill - PL_reg_starttry),
3683                                       PL_colors[5]));
3684                 sayNO_FINAL;            /* Cannot match: too short. */
3685             }
3686             PL_reginput = locinput;     /* put where regtry can find it */
3687             sayYES_FINAL;               /* Success! */
3688         case SUCCEED:
3689             PL_reginput = locinput;     /* put where regtry can find it */
3690             sayYES_LOUD;                /* Success! */
3691         case SUSPEND:
3692             n = 1;
3693             PL_reginput = locinput;
3694             goto do_ifmatch;
3695         case UNLESSM:
3696             n = 0;
3697             if (scan->flags) {
3698                 s = HOPBACKc(locinput, scan->flags);
3699                 if (!s)
3700                     goto say_yes;
3701                 PL_reginput = s;
3702             }
3703             else
3704                 PL_reginput = locinput;
3705             goto do_ifmatch;
3706         case IFMATCH:
3707             n = 1;
3708             if (scan->flags) {
3709                 s = HOPBACKc(locinput, scan->flags);
3710                 if (!s)
3711                     goto say_no;
3712                 PL_reginput = s;
3713             }
3714             else
3715                 PL_reginput = locinput;
3716
3717           do_ifmatch:
3718             inner = NEXTOPER(NEXTOPER(scan));
3719             if (regmatch(inner) != n) {
3720               say_no:
3721                 if (logical) {
3722                     logical = 0;
3723                     sw = 0;
3724                     goto do_longjump;
3725                 }
3726                 else
3727                     sayNO;
3728             }
3729           say_yes:
3730             if (logical) {
3731                 logical = 0;
3732                 sw = 1;
3733             }
3734             if (OP(scan) == SUSPEND) {
3735                 locinput = PL_reginput;
3736                 nextchr = UCHARAT(locinput);
3737             }
3738             /* FALL THROUGH. */
3739         case LONGJMP:
3740           do_longjump:
3741             next = scan + ARG(scan);
3742             if (next == scan)
3743                 next = NULL;
3744             break;
3745         default:
3746             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
3747                           PTR2UV(scan), OP(scan));
3748             Perl_croak(aTHX_ "regexp memory corruption");
3749         }
3750       reenter:
3751         scan = next;
3752     }
3753
3754     /*
3755     * We get here only if there's trouble -- normally "case END" is
3756     * the terminating point.
3757     */
3758     Perl_croak(aTHX_ "corrupted regexp pointers");
3759     /*NOTREACHED*/
3760     sayNO;
3761
3762 yes_loud:
3763     DEBUG_r(
3764         PerlIO_printf(Perl_debug_log,
3765                       "%*s  %scould match...%s\n",
3766                       REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],PL_colors[5])
3767         );
3768     goto yes;
3769 yes_final:
3770     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
3771                           PL_colors[4],PL_colors[5]));
3772 yes:
3773 #ifdef DEBUGGING
3774     PL_regindent--;
3775 #endif
3776
3777 #if 0                                   /* Breaks $^R */
3778     if (unwind)
3779         regcpblow(firstcp);
3780 #endif
3781     return 1;
3782
3783 no:
3784     DEBUG_r(
3785         PerlIO_printf(Perl_debug_log,
3786                       "%*s  %sfailed...%s\n",
3787                       REPORT_CODE_OFF+PL_regindent*2, "",PL_colors[4],PL_colors[5])
3788         );
3789     goto do_no;
3790 no_final:
3791 do_no:
3792     if (unwind) {
3793         re_unwind_t *uw = SSPTRt(unwind,re_unwind_t);
3794
3795         switch (uw->type) {
3796         case RE_UNWIND_BRANCH:
3797         case RE_UNWIND_BRANCHJ:
3798         {
3799             re_unwind_branch_t *uwb = &(uw->branch);
3800             I32 lastparen = uwb->lastparen;
3801
3802             REGCP_UNWIND(uwb->lastcp);
3803             for (n = *PL_reglastparen; n > lastparen; n--)
3804                 PL_regendp[n] = -1;
3805             *PL_reglastparen = n;
3806             scan = next = uwb->next;
3807             if ( !scan ||
3808                  OP(scan) != (uwb->type == RE_UNWIND_BRANCH
3809                               ? BRANCH : BRANCHJ) ) {           /* Failure */
3810                 unwind = uwb->prev;
3811 #ifdef DEBUGGING
3812                 PL_regindent--;
3813 #endif
3814                 goto do_no;
3815             }
3816             /* Have more choice yet.  Reuse the same uwb.  */
3817             /*SUPPRESS 560*/
3818             if ((n = (uwb->type == RE_UNWIND_BRANCH
3819                       ? NEXT_OFF(next) : ARG(next))))
3820                 next += n;
3821             else
3822                 next = NULL;    /* XXXX Needn't unwinding in this case... */
3823             uwb->next = next;
3824             next = NEXTOPER(scan);
3825             if (uwb->type == RE_UNWIND_BRANCHJ)
3826                 next = NEXTOPER(next);
3827             locinput = uwb->locinput;
3828             nextchr = uwb->nextchr;
3829 #ifdef DEBUGGING
3830             PL_regindent = uwb->regindent;
3831 #endif
3832
3833             goto reenter;
3834         }
3835         /* NOT REACHED */
3836         default:
3837             Perl_croak(aTHX_ "regexp unwind memory corruption");
3838         }
3839         /* NOT REACHED */
3840     }
3841 #ifdef DEBUGGING
3842     PL_regindent--;
3843 #endif
3844     return 0;
3845 }
3846
3847 /*
3848  - regrepeat - repeatedly match something simple, report how many
3849  */
3850 /*
3851  * [This routine now assumes that it will only match on things of length 1.
3852  * That was true before, but now we assume scan - reginput is the count,
3853  * rather than incrementing count on every character.  [Er, except utf8.]]
3854  */
3855 STATIC I32
3856 S_regrepeat(pTHX_ regnode *p, I32 max)
3857 {
3858     register char *scan;
3859     register I32 c;
3860     register char *loceol = PL_regeol;
3861     register I32 hardcount = 0;
3862     register bool do_utf8 = PL_reg_match_utf8;
3863
3864     scan = PL_reginput;
3865     if (max != REG_INFTY && max < loceol - scan)
3866       loceol = scan + max;
3867     switch (OP(p)) {
3868     case REG_ANY:
3869         if (do_utf8) {
3870             loceol = PL_regeol;
3871             while (scan < loceol && hardcount < max && *scan != '\n') {
3872                 scan += UTF8SKIP(scan);
3873                 hardcount++;
3874             }
3875         } else {
3876             while (scan < loceol && *scan != '\n')
3877                 scan++;
3878         }
3879         break;
3880     case SANY:
3881         scan = loceol;
3882         break;
3883     case CANY:
3884         scan = loceol;
3885         break;
3886     case EXACT:         /* length of string is 1 */
3887         c = (U8)*STRING(p);
3888         while (scan < loceol && UCHARAT(scan) == c)
3889             scan++;
3890         break;
3891     case EXACTF:        /* length of string is 1 */
3892         c = (U8)*STRING(p);
3893         while (scan < loceol &&
3894                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
3895             scan++;
3896         break;
3897     case EXACTFL:       /* length of string is 1 */
3898         PL_reg_flags |= RF_tainted;
3899         c = (U8)*STRING(p);
3900         while (scan < loceol &&
3901                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
3902             scan++;
3903         break;
3904     case ANYOF:
3905         if (do_utf8) {
3906             loceol = PL_regeol;
3907             while (hardcount < max && scan < loceol &&
3908                    reginclass(p, (U8*)scan, do_utf8)) {
3909                 scan += UTF8SKIP(scan);
3910                 hardcount++;
3911             }
3912         } else {
3913             while (scan < loceol && reginclass(p, (U8*)scan, do_utf8))
3914                 scan++;
3915         }
3916         break;
3917     case ALNUM:
3918         if (do_utf8) {
3919             loceol = PL_regeol;
3920             LOAD_UTF8_CHARCLASS(alnum,"a");
3921             while (hardcount < max && scan < loceol &&
3922                    swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
3923                 scan += UTF8SKIP(scan);
3924                 hardcount++;
3925             }
3926         } else {
3927             while (scan < loceol && isALNUM(*scan))
3928                 scan++;
3929         }
3930         break;
3931     case ALNUML:
3932         PL_reg_flags |= RF_tainted;
3933         if (do_utf8) {
3934             loceol = PL_regeol;
3935             while (hardcount < max && scan < loceol &&
3936                    isALNUM_LC_utf8((U8*)scan)) {
3937                 scan += UTF8SKIP(scan);
3938                 hardcount++;
3939             }
3940         } else {
3941             while (scan < loceol && isALNUM_LC(*scan))
3942                 scan++;
3943         }
3944         break;
3945     case NALNUM:
3946         if (do_utf8) {
3947             loceol = PL_regeol;
3948             LOAD_UTF8_CHARCLASS(alnum,"a");
3949             while (hardcount < max && scan < loceol &&
3950                    !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
3951                 scan += UTF8SKIP(scan);
3952                 hardcount++;
3953             }
3954         } else {
3955             while (scan < loceol && !isALNUM(*scan))
3956                 scan++;
3957         }
3958         break;
3959     case NALNUML:
3960         PL_reg_flags |= RF_tainted;
3961         if (do_utf8) {
3962             loceol = PL_regeol;
3963             while (hardcount < max && scan < loceol &&
3964                    !isALNUM_LC_utf8((U8*)scan)) {
3965                 scan += UTF8SKIP(scan);
3966                 hardcount++;
3967             }
3968         } else {
3969             while (scan < loceol && !isALNUM_LC(*scan))
3970                 scan++;
3971         }
3972         break;
3973     case SPACE:
3974         if (do_utf8) {
3975             loceol = PL_regeol;
3976             LOAD_UTF8_CHARCLASS(space," ");
3977             while (hardcount < max && scan < loceol &&
3978                    (*scan == ' ' ||
3979                     swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
3980                 scan += UTF8SKIP(scan);
3981                 hardcount++;
3982             }
3983         } else {
3984             while (scan < loceol && isSPACE(*scan))
3985                 scan++;
3986         }
3987         break;
3988     case SPACEL:
3989         PL_reg_flags |= RF_tainted;
3990         if (do_utf8) {
3991             loceol = PL_regeol;
3992             while (hardcount < max && scan < loceol &&
3993                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
3994                 scan += UTF8SKIP(scan);
3995                 hardcount++;
3996             }
3997         } else {
3998             while (scan < loceol && isSPACE_LC(*scan))
3999                 scan++;
4000         }
4001         break;
4002     case NSPACE:
4003         if (do_utf8) {
4004             loceol = PL_regeol;
4005             LOAD_UTF8_CHARCLASS(space," ");
4006             while (hardcount < max && scan < loceol &&
4007                    !(*scan == ' ' ||
4008                      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
4009                 scan += UTF8SKIP(scan);
4010                 hardcount++;
4011             }
4012         } else {
4013             while (scan < loceol && !isSPACE(*scan))
4014                 scan++;
4015             break;
4016         }
4017     case NSPACEL:
4018         PL_reg_flags |= RF_tainted;
4019         if (do_utf8) {
4020             loceol = PL_regeol;
4021             while (hardcount < max && scan < loceol &&
4022                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
4023                 scan += UTF8SKIP(scan);
4024                 hardcount++;
4025             }
4026         } else {
4027             while (scan < loceol && !isSPACE_LC(*scan))
4028                 scan++;
4029         }
4030         break;
4031     case DIGIT:
4032         if (do_utf8) {
4033             loceol = PL_regeol;
4034             LOAD_UTF8_CHARCLASS(digit,"0");
4035             while (hardcount < max && scan < loceol &&
4036                    swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
4037                 scan += UTF8SKIP(scan);
4038                 hardcount++;
4039             }
4040         } else {
4041             while (scan < loceol && isDIGIT(*scan))
4042                 scan++;
4043         }
4044         break;
4045     case NDIGIT:
4046         if (do_utf8) {
4047             loceol = PL_regeol;
4048             LOAD_UTF8_CHARCLASS(digit,"0");
4049             while (hardcount < max && scan < loceol &&
4050                    !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
4051                 scan += UTF8SKIP(scan);
4052                 hardcount++;
4053             }
4054         } else {
4055             while (scan < loceol && !isDIGIT(*scan))
4056                 scan++;
4057         }
4058         break;
4059     default:            /* Called on something of 0 width. */
4060         break;          /* So match right here or not at all. */
4061     }
4062
4063     if (hardcount)
4064         c = hardcount;
4065     else
4066         c = scan - PL_reginput;
4067     PL_reginput = scan;
4068
4069     DEBUG_r(
4070         {
4071                 SV *prop = sv_newmortal();
4072
4073                 regprop(prop, p);
4074                 PerlIO_printf(Perl_debug_log,
4075                               "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
4076                               REPORT_CODE_OFF+1, "", SvPVX(prop),(IV)c,(IV)max);
4077         });
4078
4079     return(c);
4080 }
4081
4082 /*
4083  - regrepeat_hard - repeatedly match something, report total lenth and length
4084  *
4085  * The repeater is supposed to have constant length.
4086  */
4087
4088 STATIC I32
4089 S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
4090 {
4091     register char *scan = Nullch;
4092     register char *start;
4093     register char *loceol = PL_regeol;
4094     I32 l = 0;
4095     I32 count = 0, res = 1;
4096
4097     if (!max)
4098         return 0;
4099
4100     start = PL_reginput;
4101     if (PL_reg_match_utf8) {
4102         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
4103             if (!count++) {
4104                 l = 0;
4105                 while (start < PL_reginput) {
4106                     l++;
4107                     start += UTF8SKIP(start);
4108                 }
4109                 *lp = l;
4110                 if (l == 0)
4111                     return max;
4112             }
4113             if (count == max)
4114                 return count;
4115         }
4116     }
4117     else {
4118         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
4119             if (!count++) {
4120                 *lp = l = PL_reginput - start;
4121                 if (max != REG_INFTY && l*max < loceol - scan)
4122                     loceol = scan + l*max;
4123                 if (l == 0)
4124                     return max;
4125             }
4126         }
4127     }
4128     if (!res)
4129         PL_reginput = scan;
4130
4131     return count;
4132 }
4133
4134 /*
4135 - regclass_swash - prepare the utf8 swash
4136 */
4137
4138 SV *
4139 Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** initsvp)
4140 {
4141     SV *sw = NULL;
4142     SV *si = NULL;
4143
4144     if (PL_regdata && PL_regdata->count) {
4145         U32 n = ARG(node);
4146
4147         if (PL_regdata->what[n] == 's') {
4148             SV *rv = (SV*)PL_regdata->data[n];
4149             AV *av = (AV*)SvRV((SV*)rv);
4150             SV **a;
4151
4152             si = *av_fetch(av, 0, FALSE);
4153             a  =  av_fetch(av, 1, FALSE);
4154
4155             if (a)
4156                 sw = *a;
4157             else if (si && doinit) {
4158                 sw = swash_init("utf8", "", si, 1, 0);
4159                 (void)av_store(av, 1, sw);
4160             }
4161         }
4162     }
4163
4164     if (initsvp)
4165         *initsvp = si;
4166
4167     return sw;
4168 }
4169
4170 /*
4171  - reginclass - determine if a character falls into a character class
4172  */
4173
4174 STATIC bool
4175 S_reginclass(pTHX_ register regnode *n, register U8* p, register bool do_utf8)
4176 {
4177     char flags = ANYOF_FLAGS(n);
4178     bool match = FALSE;
4179     UV c;
4180     STRLEN len = 0;
4181
4182     c = do_utf8 ? utf8_to_uvchr(p, &len) : *p;
4183
4184     if (do_utf8 || (flags & ANYOF_UNICODE)) {
4185         if (do_utf8 && !ANYOF_RUNTIME(n)) {
4186             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
4187                 match = TRUE;
4188         }
4189         if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
4190             match = TRUE;
4191         if (!match) {
4192             SV *sw = regclass_swash(n, TRUE, 0);
4193
4194             if (sw) {
4195                 if (swash_fetch(sw, p, do_utf8))
4196                     match = TRUE;
4197                 else if (flags & ANYOF_FOLD) {
4198                     STRLEN ulen;
4199                     U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
4200
4201                     to_utf8_fold(p, tmpbuf, &ulen);
4202                     if (swash_fetch(sw, tmpbuf, do_utf8))
4203                         match = TRUE;
4204                     to_utf8_upper(p, tmpbuf, &ulen);
4205                     if (swash_fetch(sw, tmpbuf, do_utf8))
4206                         match = TRUE;
4207                 }
4208             }
4209         }
4210     }
4211     if (!match && c < 256) {
4212         if (ANYOF_BITMAP_TEST(n, c))
4213             match = TRUE;
4214         else if (flags & ANYOF_FOLD) {
4215           I32 f;
4216
4217             if (flags & ANYOF_LOCALE) {
4218                 PL_reg_flags |= RF_tainted;
4219                 f = PL_fold_locale[c];
4220             }
4221             else
4222                 f = PL_fold[c];
4223             if (f != c && ANYOF_BITMAP_TEST(n, f))
4224                 match = TRUE;
4225         }
4226
4227         if (!match && (flags & ANYOF_CLASS)) {
4228             PL_reg_flags |= RF_tainted;
4229             if (
4230                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
4231                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
4232                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
4233                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
4234                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
4235                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
4236                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
4237                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
4238                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
4239                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
4240                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
4241                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
4242                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
4243                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
4244                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
4245                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
4246                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
4247                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
4248                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
4249                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
4250                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
4251                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
4252                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
4253                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
4254                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
4255                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
4256                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
4257                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
4258                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
4259                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
4260                 ) /* How's that for a conditional? */
4261             {
4262                 match = TRUE;
4263             }
4264         }
4265     }
4266
4267     return (flags & ANYOF_INVERT) ? !match : match;
4268 }
4269
4270 STATIC U8 *
4271 S_reghop(pTHX_ U8 *s, I32 off)
4272 {
4273     return S_reghop3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
4274 }
4275
4276 STATIC U8 *
4277 S_reghop3(pTHX_ U8 *s, I32 off, U8* lim)
4278 {
4279     if (off >= 0) {
4280         while (off-- && s < lim) {
4281             /* XXX could check well-formedness here */
4282             s += UTF8SKIP(s);
4283         }
4284     }
4285     else {
4286         while (off++) {
4287             if (s > lim) {
4288                 s--;
4289                 if (UTF8_IS_CONTINUED(*s)) {
4290                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
4291                         s--;
4292                 }
4293                 /* XXX could check well-formedness here */
4294             }
4295         }
4296     }
4297     return s;
4298 }
4299
4300 STATIC U8 *
4301 S_reghopmaybe(pTHX_ U8 *s, I32 off)
4302 {
4303     return S_reghopmaybe3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
4304 }
4305
4306 STATIC U8 *
4307 S_reghopmaybe3(pTHX_ U8* s, I32 off, U8* lim)
4308 {
4309     if (off >= 0) {
4310         while (off-- && s < lim) {
4311             /* XXX could check well-formedness here */
4312             s += UTF8SKIP(s);
4313         }
4314         if (off >= 0)
4315             return 0;
4316     }
4317     else {
4318         while (off++) {
4319             if (s > lim) {
4320                 s--;
4321                 if (UTF8_IS_CONTINUED(*s)) {
4322                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
4323                         s--;
4324                 }
4325                 /* XXX could check well-formedness here */
4326             }
4327             else
4328                 break;
4329         }
4330         if (off <= 0)
4331             return 0;
4332     }
4333     return s;
4334 }
4335
4336 static void
4337 restore_pos(pTHX_ void *arg)
4338 {
4339     if (PL_reg_eval_set) {
4340         if (PL_reg_oldsaved) {
4341             PL_reg_re->subbeg = PL_reg_oldsaved;
4342             PL_reg_re->sublen = PL_reg_oldsavedlen;
4343             RX_MATCH_COPIED_on(PL_reg_re);
4344         }
4345         PL_reg_magic->mg_len = PL_reg_oldpos;
4346         PL_reg_eval_set = 0;
4347         PL_curpm = PL_reg_oldcurpm;
4348     }
4349 }