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