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