regexec.c

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