regexec.c

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