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                 /* No need to save/restore up to this paren */
2600                 I32 parenfloor = scan->flags;
2601
2602                 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
2603                     next += ARG(next);
2604                 cc.oldcc = PL_regcc;
2605                 PL_regcc = &cc;
2606                 /* XXXX Probably it is better to teach regpush to support
2607                    parenfloor > PL_regsize... */
2608                 if (parenfloor > *PL_reglastparen)
2609                     parenfloor = *PL_reglastparen; /* Pessimization... */
2610                 cc.parenfloor = parenfloor;
2611                 cc.cur = -1;
2612                 cc.min = ARG1(scan);
2613                 cc.max  = ARG2(scan);
2614                 cc.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
2615                 cc.next = next;
2616                 cc.minmod = minmod;
2617                 cc.lastloc = 0;
2618                 PL_reginput = locinput;
2619                 n = regmatch(PREVOPER(next));   /* start on the WHILEM */
2620                 regcpblow(cp);
2621                 PL_regcc = cc.oldcc;
2622                 saySAME(n);
2623             }
2624             /* NOT REACHED */
2625         case WHILEM: {
2626                 /*
2627                  * This is really hard to understand, because after we match
2628                  * what we're trying to match, we must make sure the rest of
2629                  * the REx is going to match for sure, and to do that we have
2630                  * to go back UP the parse tree by recursing ever deeper.  And
2631                  * if it fails, we have to reset our parent's current state
2632                  * that we can try again after backing off.
2633                  */
2634
2635                 CHECKPOINT cp, lastcp;
2636                 CURCUR* cc = PL_regcc;
2637                 char *lastloc = cc->lastloc; /* Detection of 0-len. */
2638
2639                 n = cc->cur + 1;        /* how many we know we matched */
2640                 PL_reginput = locinput;
2641
2642                 DEBUG_r(
2643                     PerlIO_printf(Perl_debug_log,
2644                                   "%*s  %ld out of %ld..%ld  cc=%lx\n",
2645                                   REPORT_CODE_OFF+PL_regindent*2, "",
2646                                   (long)n, (long)cc->min,
2647                                   (long)cc->max, (long)cc)
2648                     );
2649
2650                 /* If degenerate scan matches "", assume scan done. */
2651
2652                 if (locinput == cc->lastloc && n >= cc->min) {
2653                     PL_regcc = cc->oldcc;
2654                     if (PL_regcc)
2655                         ln = PL_regcc->cur;
2656                     DEBUG_r(
2657                         PerlIO_printf(Perl_debug_log,
2658                            "%*s  empty match detected, try continuation...\n",
2659                            REPORT_CODE_OFF+PL_regindent*2, "")
2660                         );
2661                     if (regmatch(cc->next))
2662                         sayYES;
2663                     if (PL_regcc)
2664                         PL_regcc->cur = ln;
2665                     PL_regcc = cc;
2666                     sayNO;
2667                 }
2668
2669                 /* First just match a string of min scans. */
2670
2671                 if (n < cc->min) {
2672                     cc->cur = n;
2673                     cc->lastloc = locinput;
2674                     if (regmatch(cc->scan))
2675                         sayYES;
2676                     cc->cur = n - 1;
2677                     cc->lastloc = lastloc;
2678                     sayNO;
2679                 }
2680
2681                 if (scan->flags) {
2682                     /* Check whether we already were at this position.
2683                         Postpone detection until we know the match is not
2684                         *that* much linear. */
2685                 if (!PL_reg_maxiter) {
2686                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
2687                     PL_reg_leftiter = PL_reg_maxiter;
2688                 }
2689                 if (PL_reg_leftiter-- == 0) {
2690                     I32 size = (PL_reg_maxiter + 7)/8;
2691                     if (PL_reg_poscache) {
2692                         if (PL_reg_poscache_size < size) {
2693                             Renew(PL_reg_poscache, size, char);
2694                             PL_reg_poscache_size = size;
2695                         }
2696                         Zero(PL_reg_poscache, size, char);
2697                     }
2698                     else {
2699                         PL_reg_poscache_size = size;
2700                         Newz(29, PL_reg_poscache, size, char);
2701                     }
2702                     DEBUG_r(
2703                         PerlIO_printf(Perl_debug_log,
2704               "%sDetected a super-linear match, switching on caching%s...\n",
2705                                       PL_colors[4], PL_colors[5])
2706                         );
2707                 }
2708                 if (PL_reg_leftiter < 0) {
2709                     I32 o = locinput - PL_bostr, b;
2710
2711                     o = (scan->flags & 0xf) - 1 + o * (scan->flags>>4);
2712                     b = o % 8;
2713                     o /= 8;
2714                     if (PL_reg_poscache[o] & (1<<b)) {
2715                     DEBUG_r(
2716                         PerlIO_printf(Perl_debug_log,
2717                                       "%*s  already tried at this position...\n",
2718                                       REPORT_CODE_OFF+PL_regindent*2, "")
2719                         );
2720                         sayNO_SILENT;
2721                     }
2722                     PL_reg_poscache[o] |= (1<<b);
2723                 }
2724                 }
2725
2726                 /* Prefer next over scan for minimal matching. */
2727
2728                 if (cc->minmod) {
2729                     PL_regcc = cc->oldcc;
2730                     if (PL_regcc)
2731                         ln = PL_regcc->cur;
2732                     cp = regcppush(cc->parenfloor);
2733                     REGCP_SET;
2734                     if (regmatch(cc->next)) {
2735                         regcpblow(cp);
2736                         sayYES; /* All done. */
2737                     }
2738                     REGCP_UNWIND;
2739                     regcppop();
2740                     if (PL_regcc)
2741                         PL_regcc->cur = ln;
2742                     PL_regcc = cc;
2743
2744                     if (n >= cc->max) { /* Maximum greed exceeded? */
2745                         if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
2746                             && !(PL_reg_flags & RF_warned)) {
2747                             PL_reg_flags |= RF_warned;
2748                             Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
2749                                  "Complex regular subexpression recursion",
2750                                  REG_INFTY - 1);
2751                         }
2752                         sayNO;
2753                     }
2754
2755                     DEBUG_r(
2756                         PerlIO_printf(Perl_debug_log,
2757                                       "%*s  trying longer...\n",
2758                                       REPORT_CODE_OFF+PL_regindent*2, "")
2759                         );
2760                     /* Try scanning more and see if it helps. */
2761                     PL_reginput = locinput;
2762                     cc->cur = n;
2763                     cc->lastloc = locinput;
2764                     cp = regcppush(cc->parenfloor);
2765                     REGCP_SET;
2766                     if (regmatch(cc->scan)) {
2767                         regcpblow(cp);
2768                         sayYES;
2769                     }
2770                     REGCP_UNWIND;
2771                     regcppop();
2772                     cc->cur = n - 1;
2773                     cc->lastloc = lastloc;
2774                     sayNO;
2775                 }
2776
2777                 /* Prefer scan over next for maximal matching. */
2778
2779                 if (n < cc->max) {      /* More greed allowed? */
2780                     cp = regcppush(cc->parenfloor);
2781                     cc->cur = n;
2782                     cc->lastloc = locinput;
2783                     REGCP_SET;
2784                     if (regmatch(cc->scan)) {
2785                         regcpblow(cp);
2786                         sayYES;
2787                     }
2788                     REGCP_UNWIND;
2789                     regcppop();         /* Restore some previous $<digit>s? */
2790                     PL_reginput = locinput;
2791                     DEBUG_r(
2792                         PerlIO_printf(Perl_debug_log,
2793                                       "%*s  failed, try continuation...\n",
2794                                       REPORT_CODE_OFF+PL_regindent*2, "")
2795                         );
2796                 }
2797                 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
2798                         && !(PL_reg_flags & RF_warned)) {
2799                     PL_reg_flags |= RF_warned;
2800                     Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
2801                          "Complex regular subexpression recursion",
2802                          REG_INFTY - 1);
2803                 }
2804
2805                 /* Failed deeper matches of scan, so see if this one works. */
2806                 PL_regcc = cc->oldcc;
2807                 if (PL_regcc)
2808                     ln = PL_regcc->cur;
2809                 if (regmatch(cc->next))
2810                     sayYES;
2811                 if (PL_regcc)
2812                     PL_regcc->cur = ln;
2813                 PL_regcc = cc;
2814                 cc->cur = n - 1;
2815                 cc->lastloc = lastloc;
2816                 sayNO;
2817             }
2818             /* NOT REACHED */
2819         case BRANCHJ:
2820             next = scan + ARG(scan);
2821             if (next == scan)
2822                 next = NULL;
2823             inner = NEXTOPER(NEXTOPER(scan));
2824             goto do_branch;
2825         case BRANCH:
2826             inner = NEXTOPER(scan);
2827           do_branch:
2828             {
2829                 CHECKPOINT lastcp;
2830                 c1 = OP(scan);
2831                 if (OP(next) != c1)     /* No choice. */
2832                     next = inner;       /* Avoid recursion. */
2833                 else {
2834                     int lastparen = *PL_reglastparen;
2835
2836                     REGCP_SET;
2837                     do {
2838                         PL_reginput = locinput;
2839                         if (regmatch(inner))
2840                             sayYES;
2841                         REGCP_UNWIND;
2842                         for (n = *PL_reglastparen; n > lastparen; n--)
2843                             PL_regendp[n] = -1;
2844                         *PL_reglastparen = n;
2845                         scan = next;
2846                         /*SUPPRESS 560*/
2847                         if ((n = (c1 == BRANCH ? NEXT_OFF(next) : ARG(next))))
2848                             next += n;
2849                         else
2850                             next = NULL;
2851                         inner = NEXTOPER(scan);
2852                         if (c1 == BRANCHJ) {
2853                             inner = NEXTOPER(inner);
2854                         }
2855                     } while (scan != NULL && OP(scan) == c1);
2856                     sayNO;
2857                     /* NOTREACHED */
2858                 }
2859             }
2860             break;
2861         case MINMOD:
2862             minmod = 1;
2863             break;
2864         case CURLYM:
2865         {
2866             I32 l = 0;
2867             CHECKPOINT lastcp;
2868
2869             /* We suppose that the next guy does not need
2870                backtracking: in particular, it is of constant length,
2871                and has no parenths to influence future backrefs. */
2872             ln = ARG1(scan);  /* min to match */
2873             n  = ARG2(scan);  /* max to match */
2874             paren = scan->flags;
2875             if (paren) {
2876                 if (paren > PL_regsize)
2877                     PL_regsize = paren;
2878                 if (paren > *PL_reglastparen)
2879                     *PL_reglastparen = paren;
2880             }
2881             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
2882             if (paren)
2883                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
2884             PL_reginput = locinput;
2885             if (minmod) {
2886                 minmod = 0;
2887                 if (ln && regrepeat_hard(scan, ln, &l) < ln)
2888                     sayNO;
2889                 if (ln && l == 0 && n >= ln
2890                     /* In fact, this is tricky.  If paren, then the
2891                        fact that we did/didnot match may influence
2892                        future execution. */
2893                     && !(paren && ln == 0))
2894                     ln = n;
2895                 locinput = PL_reginput;
2896                 if (PL_regkind[(U8)OP(next)] == EXACT) {
2897                     c1 = (U8)*STRING(next);
2898                     if (OP(next) == EXACTF)
2899                         c2 = PL_fold[c1];
2900                     else if (OP(next) == EXACTFL)
2901                         c2 = PL_fold_locale[c1];
2902                     else
2903                         c2 = c1;
2904                 }
2905                 else
2906                     c1 = c2 = -1000;
2907                 REGCP_SET;
2908                 /* This may be improved if l == 0.  */
2909                 while (n >= ln || (n == REG_INFTY && ln > 0 && l)) { /* ln overflow ? */
2910                     /* If it could work, try it. */
2911                     if (c1 == -1000 ||
2912                         UCHARAT(PL_reginput) == c1 ||
2913                         UCHARAT(PL_reginput) == c2)
2914                     {
2915                         if (paren) {
2916                             if (n) {
2917                                 PL_regstartp[paren] =
2918                                     HOPc(PL_reginput, -l) - PL_bostr;
2919                                 PL_regendp[paren] = PL_reginput - PL_bostr;
2920                             }
2921                             else
2922                                 PL_regendp[paren] = -1;
2923                         }
2924                         if (regmatch(next))
2925                             sayYES;
2926                         REGCP_UNWIND;
2927                     }
2928                     /* Couldn't or didn't -- move forward. */
2929                     PL_reginput = locinput;
2930                     if (regrepeat_hard(scan, 1, &l)) {
2931                         ln++;
2932                         locinput = PL_reginput;
2933                     }
2934                     else
2935                         sayNO;
2936                 }
2937             }
2938             else {
2939                 n = regrepeat_hard(scan, n, &l);
2940                 if (n != 0 && l == 0
2941                     /* In fact, this is tricky.  If paren, then the
2942                        fact that we did/didnot match may influence
2943                        future execution. */
2944                     && !(paren && ln == 0))
2945                     ln = n;
2946                 locinput = PL_reginput;
2947                 DEBUG_r(
2948                     PerlIO_printf(Perl_debug_log,
2949                                   "%*s  matched %"IVdf" times, len=%"IVdf"...\n",
2950                                   (int)(REPORT_CODE_OFF+PL_regindent*2), "",
2951                                   (IV) n, (IV)l)
2952                     );
2953                 if (n >= ln) {
2954                     if (PL_regkind[(U8)OP(next)] == EXACT) {
2955                         c1 = (U8)*STRING(next);
2956                         if (OP(next) == EXACTF)
2957                             c2 = PL_fold[c1];
2958                         else if (OP(next) == EXACTFL)
2959                             c2 = PL_fold_locale[c1];
2960                         else
2961                             c2 = c1;
2962                     }
2963                     else
2964                         c1 = c2 = -1000;
2965                 }
2966                 REGCP_SET;
2967                 while (n >= ln) {
2968                     /* If it could work, try it. */
2969                     if (c1 == -1000 ||
2970                         UCHARAT(PL_reginput) == c1 ||
2971                         UCHARAT(PL_reginput) == c2)
2972                     {
2973                         DEBUG_r(
2974                                 PerlIO_printf(Perl_debug_log,
2975                                               "%*s  trying tail with n=%"IVdf"...\n",
2976                                               (int)(REPORT_CODE_OFF+PL_regindent*2), "", (IV)n)
2977                             );
2978                         if (paren) {
2979                             if (n) {
2980                                 PL_regstartp[paren] = HOPc(PL_reginput, -l) - PL_bostr;
2981                                 PL_regendp[paren] = PL_reginput - PL_bostr;
2982                             }
2983                             else
2984                                 PL_regendp[paren] = -1;
2985                         }
2986                         if (regmatch(next))
2987                             sayYES;
2988                         REGCP_UNWIND;
2989                     }
2990                     /* Couldn't or didn't -- back up. */
2991                     n--;
2992                     locinput = HOPc(locinput, -l);
2993                     PL_reginput = locinput;
2994                 }
2995             }
2996             sayNO;
2997             break;
2998         }
2999         case CURLYN:
3000             paren = scan->flags;        /* Which paren to set */
3001             if (paren > PL_regsize)
3002                 PL_regsize = paren;
3003             if (paren > *PL_reglastparen)
3004                 *PL_reglastparen = paren;
3005             ln = ARG1(scan);  /* min to match */
3006             n  = ARG2(scan);  /* max to match */
3007             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
3008             goto repeat;
3009         case CURLY:
3010             paren = 0;
3011             ln = ARG1(scan);  /* min to match */
3012             n  = ARG2(scan);  /* max to match */
3013             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3014             goto repeat;
3015         case STAR:
3016             ln = 0;
3017             n = REG_INFTY;
3018             scan = NEXTOPER(scan);
3019             paren = 0;
3020             goto repeat;
3021         case PLUS:
3022             ln = 1;
3023             n = REG_INFTY;
3024             scan = NEXTOPER(scan);
3025             paren = 0;
3026           repeat:
3027             /*
3028             * Lookahead to avoid useless match attempts
3029             * when we know what character comes next.
3030             */
3031             if (PL_regkind[(U8)OP(next)] == EXACT) {
3032                 c1 = (U8)*STRING(next);
3033                 if (OP(next) == EXACTF)
3034                     c2 = PL_fold[c1];
3035                 else if (OP(next) == EXACTFL)
3036                     c2 = PL_fold_locale[c1];
3037                 else
3038                     c2 = c1;
3039             }
3040             else
3041                 c1 = c2 = -1000;
3042             PL_reginput = locinput;
3043             if (minmod) {
3044                 CHECKPOINT lastcp;
3045                 minmod = 0;
3046                 if (ln && regrepeat(scan, ln) < ln)
3047                     sayNO;
3048                 locinput = PL_reginput;
3049                 REGCP_SET;
3050                 if (c1 != -1000) {
3051                     char *e = locinput + n - ln; /* Should not check after this */
3052                     char *old = locinput;
3053
3054                     if (e >= PL_regeol || (n == REG_INFTY))
3055                         e = PL_regeol - 1;
3056                     while (1) {
3057                         /* Find place 'next' could work */
3058                         if (c1 == c2) {
3059                             while (locinput <= e && *locinput != c1)
3060                                 locinput++;
3061                         } else {
3062                             while (locinput <= e
3063                                    && *locinput != c1
3064                                    && *locinput != c2)
3065                                 locinput++;
3066                         }
3067                         if (locinput > e)
3068                             sayNO;
3069                         /* PL_reginput == old now */
3070                         if (locinput != old) {
3071                             ln = 1;     /* Did some */
3072                             if (regrepeat(scan, locinput - old) <
3073                                  locinput - old)
3074                                 sayNO;
3075                         }
3076                         /* PL_reginput == locinput now */
3077                         TRYPAREN(paren, ln, locinput);
3078                         PL_reginput = locinput; /* Could be reset... */
3079                         REGCP_UNWIND;
3080                         /* Couldn't or didn't -- move forward. */
3081                         old = locinput++;
3082                     }
3083                 }
3084                 else
3085                 while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */
3086                     /* If it could work, try it. */
3087                     if (c1 == -1000 ||
3088                         UCHARAT(PL_reginput) == c1 ||
3089                         UCHARAT(PL_reginput) == c2)
3090                     {
3091                         TRYPAREN(paren, n, PL_reginput);
3092                         REGCP_UNWIND;
3093                     }
3094                     /* Couldn't or didn't -- move forward. */
3095                     PL_reginput = locinput;
3096                     if (regrepeat(scan, 1)) {
3097                         ln++;
3098                         locinput = PL_reginput;
3099                     }
3100                     else
3101                         sayNO;
3102                 }
3103             }
3104             else {
3105                 CHECKPOINT lastcp;
3106                 n = regrepeat(scan, n);
3107                 locinput = PL_reginput;
3108                 if (ln < n && PL_regkind[(U8)OP(next)] == EOL &&
3109                     (!PL_multiline  || OP(next) == SEOL || OP(next) == EOS)) {
3110                     ln = n;                     /* why back off? */
3111                     /* ...because $ and \Z can match before *and* after
3112                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
3113                        We should back off by one in this case. */
3114                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
3115                         ln--;
3116                 }
3117                 REGCP_SET;
3118                 if (paren) {
3119                     while (n >= ln) {
3120                         /* If it could work, try it. */
3121                         if (c1 == -1000 ||
3122                             UCHARAT(PL_reginput) == c1 ||
3123                             UCHARAT(PL_reginput) == c2)
3124                             {
3125                                 TRYPAREN(paren, n, PL_reginput);
3126                                 REGCP_UNWIND;
3127                             }
3128                         /* Couldn't or didn't -- back up. */
3129                         n--;
3130                         PL_reginput = locinput = HOPc(locinput, -1);
3131                     }
3132                 }
3133                 else {
3134                     while (n >= ln) {
3135                         /* If it could work, try it. */
3136                         if (c1 == -1000 ||
3137                             UCHARAT(PL_reginput) == c1 ||
3138                             UCHARAT(PL_reginput) == c2)
3139                             {
3140                                 TRYPAREN(paren, n, PL_reginput);
3141                                 REGCP_UNWIND;
3142                             }
3143                         /* Couldn't or didn't -- back up. */
3144                         n--;
3145                         PL_reginput = locinput = HOPc(locinput, -1);
3146                     }
3147                 }
3148             }
3149             sayNO;
3150             break;
3151         case END:
3152             if (PL_reg_call_cc) {
3153                 re_cc_state *cur_call_cc = PL_reg_call_cc;
3154                 CURCUR *cctmp = PL_regcc;
3155                 regexp *re = PL_reg_re;
3156                 CHECKPOINT cp, lastcp;
3157
3158                 cp = regcppush(0);      /* Save *all* the positions. */
3159                 REGCP_SET;
3160                 regcp_set_to(PL_reg_call_cc->ss); /* Restore parens of
3161                                                     the caller. */
3162                 PL_reginput = locinput; /* Make position available to
3163                                            the callcc. */
3164                 cache_re(PL_reg_call_cc->re);
3165                 PL_regcc = PL_reg_call_cc->cc;
3166                 PL_reg_call_cc = PL_reg_call_cc->prev;
3167                 if (regmatch(cur_call_cc->node)) {
3168                     PL_reg_call_cc = cur_call_cc;
3169                     regcpblow(cp);
3170                     sayYES;
3171                 }
3172                 REGCP_UNWIND;
3173                 regcppop();
3174                 PL_reg_call_cc = cur_call_cc;
3175                 PL_regcc = cctmp;
3176                 PL_reg_re = re;
3177                 cache_re(re);
3178
3179                 DEBUG_r(
3180                     PerlIO_printf(Perl_debug_log,
3181                                   "%*s  continuation failed...\n",
3182                                   REPORT_CODE_OFF+PL_regindent*2, "")
3183                     );
3184                 sayNO_SILENT;
3185             }
3186             if (locinput < PL_regtill) {
3187                 DEBUG_r(PerlIO_printf(Perl_debug_log,
3188                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
3189                                       PL_colors[4],
3190                                       (long)(locinput - PL_reg_starttry),
3191                                       (long)(PL_regtill - PL_reg_starttry),
3192                                       PL_colors[5]));
3193                 sayNO_FINAL;            /* Cannot match: too short. */
3194             }
3195             PL_reginput = locinput;     /* put where regtry can find it */
3196             sayYES_FINAL;               /* Success! */
3197         case SUCCEED:
3198             PL_reginput = locinput;     /* put where regtry can find it */
3199             sayYES_LOUD;                /* Success! */
3200         case SUSPEND:
3201             n = 1;
3202             PL_reginput = locinput;
3203             goto do_ifmatch;
3204         case UNLESSM:
3205             n = 0;
3206             if (scan->flags) {
3207                 if (UTF) {              /* XXXX This is absolutely
3208                                            broken, we read before
3209                                            start of string. */
3210                     s = HOPMAYBEc(locinput, -scan->flags);
3211                     if (!s)
3212                         goto say_yes;
3213                     PL_reginput = s;
3214                 }
3215                 else {
3216                     if (locinput < PL_bostr + scan->flags)
3217                         goto say_yes;
3218                     PL_reginput = locinput - scan->flags;
3219                     goto do_ifmatch;
3220                 }
3221             }
3222             else
3223                 PL_reginput = locinput;
3224             goto do_ifmatch;
3225         case IFMATCH:
3226             n = 1;
3227             if (scan->flags) {
3228                 if (UTF) {              /* XXXX This is absolutely
3229                                            broken, we read before
3230                                            start of string. */
3231                     s = HOPMAYBEc(locinput, -scan->flags);
3232                     if (!s || s < PL_bostr)
3233                         goto say_no;
3234                     PL_reginput = s;
3235                 }
3236                 else {
3237                     if (locinput < PL_bostr + scan->flags)
3238                         goto say_no;
3239                     PL_reginput = locinput - scan->flags;
3240                     goto do_ifmatch;
3241                 }
3242             }
3243             else
3244                 PL_reginput = locinput;
3245
3246           do_ifmatch:
3247             inner = NEXTOPER(NEXTOPER(scan));
3248             if (regmatch(inner) != n) {
3249               say_no:
3250                 if (logical) {
3251                     logical = 0;
3252                     sw = 0;
3253                     goto do_longjump;
3254                 }
3255                 else
3256                     sayNO;
3257             }
3258           say_yes:
3259             if (logical) {
3260                 logical = 0;
3261                 sw = 1;
3262             }
3263             if (OP(scan) == SUSPEND) {
3264                 locinput = PL_reginput;
3265                 nextchr = UCHARAT(locinput);
3266             }
3267             /* FALL THROUGH. */
3268         case LONGJMP:
3269           do_longjump:
3270             next = scan + ARG(scan);
3271             if (next == scan)
3272                 next = NULL;
3273             break;
3274         default:
3275             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
3276                           PTR2UV(scan), OP(scan));
3277             Perl_croak(aTHX_ "regexp memory corruption");
3278         }
3279         scan = next;
3280     }
3281
3282     /*
3283     * We get here only if there's trouble -- normally "case END" is
3284     * the terminating point.
3285     */
3286     Perl_croak(aTHX_ "corrupted regexp pointers");
3287     /*NOTREACHED*/
3288     sayNO;
3289
3290 yes_loud:
3291     DEBUG_r(
3292         PerlIO_printf(Perl_debug_log,
3293                       "%*s  %scould match...%s\n",
3294                       REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],PL_colors[5])
3295         );
3296     goto yes;
3297 yes_final:
3298     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
3299                           PL_colors[4],PL_colors[5]));
3300 yes:
3301 #ifdef DEBUGGING
3302     PL_regindent--;
3303 #endif
3304     return 1;
3305
3306 no:
3307     DEBUG_r(
3308         PerlIO_printf(Perl_debug_log,
3309                       "%*s  %sfailed...%s\n",
3310                       REPORT_CODE_OFF+PL_regindent*2, "",PL_colors[4],PL_colors[5])
3311         );
3312     goto do_no;
3313 no_final:
3314 do_no:
3315 #ifdef DEBUGGING
3316     PL_regindent--;
3317 #endif
3318     return 0;
3319 }
3320
3321 /*
3322  - regrepeat - repeatedly match something simple, report how many
3323  */
3324 /*
3325  * [This routine now assumes that it will only match on things of length 1.
3326  * That was true before, but now we assume scan - reginput is the count,
3327  * rather than incrementing count on every character.  [Er, except utf8.]]
3328  */
3329 STATIC I32
3330 S_regrepeat(pTHX_ regnode *p, I32 max)
3331 {
3332     dTHR;
3333     register char *scan;
3334     register I32 c;
3335     register char *loceol = PL_regeol;
3336     register I32 hardcount = 0;
3337
3338     scan = PL_reginput;
3339     if (max != REG_INFTY && max < loceol - scan)
3340       loceol = scan + max;
3341     switch (OP(p)) {
3342     case REG_ANY:
3343         while (scan < loceol && *scan != '\n')
3344             scan++;
3345         break;
3346     case SANY:
3347         scan = loceol;
3348         break;
3349     case ANYUTF8:
3350         loceol = PL_regeol;
3351         while (scan < loceol && *scan != '\n') {
3352             scan += UTF8SKIP(scan);
3353             hardcount++;
3354         }
3355         break;
3356     case SANYUTF8:
3357         loceol = PL_regeol;
3358         while (scan < loceol) {
3359             scan += UTF8SKIP(scan);
3360             hardcount++;
3361         }
3362         break;
3363     case EXACT:         /* length of string is 1 */
3364         c = (U8)*STRING(p);
3365         while (scan < loceol && UCHARAT(scan) == c)
3366             scan++;
3367         break;
3368     case EXACTF:        /* length of string is 1 */
3369         c = (U8)*STRING(p);
3370         while (scan < loceol &&
3371                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
3372             scan++;
3373         break;
3374     case EXACTFL:       /* length of string is 1 */
3375         PL_reg_flags |= RF_tainted;
3376         c = (U8)*STRING(p);
3377         while (scan < loceol &&
3378                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
3379             scan++;
3380         break;
3381     case ANYOFUTF8:
3382         loceol = PL_regeol;
3383         while (scan < loceol && REGINCLASSUTF8(p, (U8*)scan)) {
3384             scan += UTF8SKIP(scan);
3385             hardcount++;
3386         }
3387         break;
3388     case ANYOF:
3389         while (scan < loceol && REGINCLASS(p, *scan))
3390             scan++;
3391         break;
3392     case ALNUM:
3393         while (scan < loceol && isALNUM(*scan))
3394             scan++;
3395         break;
3396     case ALNUMUTF8:
3397         loceol = PL_regeol;
3398         while (scan < loceol && swash_fetch(PL_utf8_alnum, (U8*)scan)) {
3399             scan += UTF8SKIP(scan);
3400             hardcount++;
3401         }
3402         break;
3403     case ALNUML:
3404         PL_reg_flags |= RF_tainted;
3405         while (scan < loceol && isALNUM_LC(*scan))
3406             scan++;
3407         break;
3408     case ALNUMLUTF8:
3409         PL_reg_flags |= RF_tainted;
3410         loceol = PL_regeol;
3411         while (scan < loceol && isALNUM_LC_utf8((U8*)scan)) {
3412             scan += UTF8SKIP(scan);
3413             hardcount++;
3414         }
3415         break;
3416         break;
3417     case NALNUM:
3418         while (scan < loceol && !isALNUM(*scan))
3419             scan++;
3420         break;
3421     case NALNUMUTF8:
3422         loceol = PL_regeol;
3423         while (scan < loceol && !swash_fetch(PL_utf8_alnum, (U8*)scan)) {
3424             scan += UTF8SKIP(scan);
3425             hardcount++;
3426         }
3427         break;
3428     case NALNUML:
3429         PL_reg_flags |= RF_tainted;
3430         while (scan < loceol && !isALNUM_LC(*scan))
3431             scan++;
3432         break;
3433     case NALNUMLUTF8:
3434         PL_reg_flags |= RF_tainted;
3435         loceol = PL_regeol;
3436         while (scan < loceol && !isALNUM_LC_utf8((U8*)scan)) {
3437             scan += UTF8SKIP(scan);
3438             hardcount++;
3439         }
3440         break;
3441     case SPACE:
3442         while (scan < loceol && isSPACE(*scan))
3443             scan++;
3444         break;
3445     case SPACEUTF8:
3446         loceol = PL_regeol;
3447         while (scan < loceol && (*scan == ' ' || swash_fetch(PL_utf8_space,(U8*)scan))) {
3448             scan += UTF8SKIP(scan);
3449             hardcount++;
3450         }
3451         break;
3452     case SPACEL:
3453         PL_reg_flags |= RF_tainted;
3454         while (scan < loceol && isSPACE_LC(*scan))
3455             scan++;
3456         break;
3457     case SPACELUTF8:
3458         PL_reg_flags |= RF_tainted;
3459         loceol = PL_regeol;
3460         while (scan < loceol && (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
3461             scan += UTF8SKIP(scan);
3462             hardcount++;
3463         }
3464         break;
3465     case NSPACE:
3466         while (scan < loceol && !isSPACE(*scan))
3467             scan++;
3468         break;
3469     case NSPACEUTF8:
3470         loceol = PL_regeol;
3471         while (scan < loceol && !(*scan == ' ' || swash_fetch(PL_utf8_space,(U8*)scan))) {
3472             scan += UTF8SKIP(scan);
3473             hardcount++;
3474         }
3475         break;
3476     case NSPACEL:
3477         PL_reg_flags |= RF_tainted;
3478         while (scan < loceol && !isSPACE_LC(*scan))
3479             scan++;
3480         break;
3481     case NSPACELUTF8:
3482         PL_reg_flags |= RF_tainted;
3483         loceol = PL_regeol;
3484         while (scan < loceol && !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
3485             scan += UTF8SKIP(scan);
3486             hardcount++;
3487         }
3488         break;
3489     case DIGIT:
3490         while (scan < loceol && isDIGIT(*scan))
3491             scan++;
3492         break;
3493     case DIGITUTF8:
3494         loceol = PL_regeol;
3495         while (scan < loceol && swash_fetch(PL_utf8_digit,(U8*)scan)) {
3496             scan += UTF8SKIP(scan);
3497             hardcount++;
3498         }
3499         break;
3500         break;
3501     case NDIGIT:
3502         while (scan < loceol && !isDIGIT(*scan))
3503             scan++;
3504         break;
3505     case NDIGITUTF8:
3506         loceol = PL_regeol;
3507         while (scan < loceol && !swash_fetch(PL_utf8_digit,(U8*)scan)) {
3508             scan += UTF8SKIP(scan);
3509             hardcount++;
3510         }
3511         break;
3512     default:            /* Called on something of 0 width. */
3513         break;          /* So match right here or not at all. */
3514     }
3515
3516     if (hardcount)
3517         c = hardcount;
3518     else
3519         c = scan - PL_reginput;
3520     PL_reginput = scan;
3521
3522     DEBUG_r(
3523         {
3524                 SV *prop = sv_newmortal();
3525
3526                 regprop(prop, p);
3527                 PerlIO_printf(Perl_debug_log,
3528                               "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
3529                               REPORT_CODE_OFF+1, "", SvPVX(prop),(IV)c,(IV)max);
3530         });
3531
3532     return(c);
3533 }
3534
3535 /*
3536  - regrepeat_hard - repeatedly match something, report total lenth and length
3537  *
3538  * The repeater is supposed to have constant length.
3539  */
3540
3541 STATIC I32
3542 S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
3543 {
3544     dTHR;
3545     register char *scan;
3546     register char *start;
3547     register char *loceol = PL_regeol;
3548     I32 l = 0;
3549     I32 count = 0, res = 1;
3550
3551     if (!max)
3552         return 0;
3553
3554     start = PL_reginput;
3555     if (UTF) {
3556         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
3557             if (!count++) {
3558                 l = 0;
3559                 while (start < PL_reginput) {
3560                     l++;
3561                     start += UTF8SKIP(start);
3562                 }
3563                 *lp = l;
3564                 if (l == 0)
3565                     return max;
3566             }
3567             if (count == max)
3568                 return count;
3569         }
3570     }
3571     else {
3572         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
3573             if (!count++) {
3574                 *lp = l = PL_reginput - start;
3575                 if (max != REG_INFTY && l*max < loceol - scan)
3576                     loceol = scan + l*max;
3577                 if (l == 0)
3578                     return max;
3579             }
3580         }
3581     }
3582     if (!res)
3583         PL_reginput = scan;
3584
3585     return count;
3586 }
3587
3588 /*
3589  - reginclass - determine if a character falls into a character class
3590  */
3591
3592 STATIC bool
3593 S_reginclass(pTHX_ register regnode *p, register I32 c)
3594 {
3595     dTHR;
3596     char flags = ANYOF_FLAGS(p);
3597     bool match = FALSE;
3598
3599     c &= 0xFF;
3600     if (ANYOF_BITMAP_TEST(p, c))
3601         match = TRUE;
3602     else if (flags & ANYOF_FOLD) {
3603         I32 cf;
3604         if (flags & ANYOF_LOCALE) {
3605             PL_reg_flags |= RF_tainted;
3606             cf = PL_fold_locale[c];
3607         }
3608         else
3609             cf = PL_fold[c];
3610         if (ANYOF_BITMAP_TEST(p, cf))
3611             match = TRUE;
3612     }
3613
3614     if (!match && (flags & ANYOF_CLASS)) {
3615         PL_reg_flags |= RF_tainted;
3616         if (
3617             (ANYOF_CLASS_TEST(p, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
3618             (ANYOF_CLASS_TEST(p, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
3619             (ANYOF_CLASS_TEST(p, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
3620             (ANYOF_CLASS_TEST(p, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
3621             (ANYOF_CLASS_TEST(p, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
3622             (ANYOF_CLASS_TEST(p, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
3623             (ANYOF_CLASS_TEST(p, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
3624             (ANYOF_CLASS_TEST(p, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
3625             (ANYOF_CLASS_TEST(p, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
3626             (ANYOF_CLASS_TEST(p, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
3627             (ANYOF_CLASS_TEST(p, ANYOF_ASCII)   &&  isASCII(c))     ||
3628             (ANYOF_CLASS_TEST(p, ANYOF_NASCII)  && !isASCII(c))     ||
3629             (ANYOF_CLASS_TEST(p, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
3630             (ANYOF_CLASS_TEST(p, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
3631             (ANYOF_CLASS_TEST(p, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
3632             (ANYOF_CLASS_TEST(p, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
3633             (ANYOF_CLASS_TEST(p, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
3634             (ANYOF_CLASS_TEST(p, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
3635             (ANYOF_CLASS_TEST(p, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
3636             (ANYOF_CLASS_TEST(p, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
3637             (ANYOF_CLASS_TEST(p, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
3638             (ANYOF_CLASS_TEST(p, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
3639             (ANYOF_CLASS_TEST(p, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
3640             (ANYOF_CLASS_TEST(p, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
3641             (ANYOF_CLASS_TEST(p, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
3642             (ANYOF_CLASS_TEST(p, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
3643             (ANYOF_CLASS_TEST(p, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
3644             (ANYOF_CLASS_TEST(p, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
3645             (ANYOF_CLASS_TEST(p, ANYOF_BLANK)   &&  isBLANK(c))    ||
3646             (ANYOF_CLASS_TEST(p, ANYOF_NBLANK)  && !isBLANK(c))
3647             ) /* How's that for a conditional? */
3648         {
3649             match = TRUE;
3650         }
3651     }
3652
3653     return (flags & ANYOF_INVERT) ? !match : match;
3654 }
3655
3656 STATIC bool
3657 S_reginclassutf8(pTHX_ regnode *f, U8 *p)
3658 {
3659     dTHR;
3660     char flags = ARG1(f);
3661     bool match = FALSE;
3662     SV *sv = (SV*)PL_regdata->data[ARG2(f)];
3663
3664     if (swash_fetch(sv, p))
3665         match = TRUE;
3666     else if (flags & ANYOF_FOLD) {
3667         U8 tmpbuf[UTF8_MAXLEN];
3668         if (flags & ANYOF_LOCALE) {
3669             PL_reg_flags |= RF_tainted;
3670             uv_to_utf8(tmpbuf, toLOWER_LC_utf8(p));
3671         }
3672         else
3673             uv_to_utf8(tmpbuf, toLOWER_utf8(p));
3674         if (swash_fetch(sv, tmpbuf))
3675             match = TRUE;
3676     }
3677
3678     /* UTF8 combined with ANYOF_CLASS is ill-defined. */
3679
3680     return (flags & ANYOF_INVERT) ? !match : match;
3681 }
3682
3683 STATIC U8 *
3684 S_reghop(pTHX_ U8 *s, I32 off)
3685 {
3686     dTHR;
3687     if (off >= 0) {
3688         while (off-- && s < (U8*)PL_regeol)
3689             s += UTF8SKIP(s);
3690     }
3691     else {
3692         while (off++) {
3693             if (s > (U8*)PL_bostr) {
3694                 s--;
3695                 if (*s & 0x80) {
3696                     while (s > (U8*)PL_bostr && (*s & 0xc0) == 0x80)
3697                         s--;
3698                 }               /* XXX could check well-formedness here */
3699             }
3700         }
3701     }
3702     return s;
3703 }
3704
3705 STATIC U8 *
3706 S_reghopmaybe(pTHX_ U8* s, I32 off)
3707 {
3708     dTHR;
3709     if (off >= 0) {
3710         while (off-- && s < (U8*)PL_regeol)
3711             s += UTF8SKIP(s);
3712         if (off >= 0)
3713             return 0;
3714     }
3715     else {
3716         while (off++) {
3717             if (s > (U8*)PL_bostr) {
3718                 s--;
3719                 if (*s & 0x80) {
3720                     while (s > (U8*)PL_bostr && (*s & 0xc0) == 0x80)
3721                         s--;
3722                 }               /* XXX could check well-formedness here */
3723             }
3724             else
3725                 break;
3726         }
3727         if (off <= 0)
3728             return 0;
3729     }
3730     return s;
3731 }
3732
3733 #ifdef PERL_OBJECT
3734 #include "XSUB.h"
3735 #endif
3736
3737 static void
3738 restore_pos(pTHXo_ void *arg)
3739 {
3740     dTHR;
3741     if (PL_reg_eval_set) {
3742         if (PL_reg_oldsaved) {
3743             PL_reg_re->subbeg = PL_reg_oldsaved;
3744             PL_reg_re->sublen = PL_reg_oldsavedlen;
3745             RX_MATCH_COPIED_on(PL_reg_re);
3746         }
3747         PL_reg_magic->mg_len = PL_reg_oldpos;
3748         PL_reg_eval_set = 0;
3749         PL_curpm = PL_reg_oldcurpm;
3750     }
3751 }