regexec.c

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