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