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