This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add Regexp::Keep \K functionality to regex engine as well as add \v and \V, cleanup...
[perl5.git] / regexec.c
1 /*    regexec.c
2  */
3
4 /*
5  * "One Ring to rule them all, One Ring to find them..."
6  */
7
8 /* This file contains functions for executing a regular expression.  See
9  * also regcomp.c which funnily enough, contains functions for compiling
10  * a regular expression.
11  *
12  * This file is also copied at build time to ext/re/re_exec.c, where
13  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
14  * This causes the main functions to be compiled under new names and with
15  * debugging support added, which makes "use re 'debug'" work.
16  */
17
18 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
19  * confused with the original package (see point 3 below).  Thanks, Henry!
20  */
21
22 /* Additional note: this code is very heavily munged from Henry's version
23  * in places.  In some spots I've traded clarity for efficiency, so don't
24  * blame Henry for some of the lack of readability.
25  */
26
27 /* The names of the functions have been changed from regcomp and
28  * regexec to  pregcomp and pregexec in order to avoid conflicts
29  * with the POSIX routines of the same names.
30 */
31
32 #ifdef PERL_EXT_RE_BUILD
33 #include "re_top.h"
34 #endif
35
36 /*
37  * pregcomp and pregexec -- regsub and regerror are not used in perl
38  *
39  *      Copyright (c) 1986 by University of Toronto.
40  *      Written by Henry Spencer.  Not derived from licensed software.
41  *
42  *      Permission is granted to anyone to use this software for any
43  *      purpose on any computer system, and to redistribute it freely,
44  *      subject to the following restrictions:
45  *
46  *      1. The author is not responsible for the consequences of use of
47  *              this software, no matter how awful, even if they arise
48  *              from defects in it.
49  *
50  *      2. The origin of this software must not be misrepresented, either
51  *              by explicit claim or by omission.
52  *
53  *      3. Altered versions must be plainly marked as such, and must not
54  *              be misrepresented as being the original software.
55  *
56  ****    Alterations to Henry's code are...
57  ****
58  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
59  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
60  ****
61  ****    You may distribute under the terms of either the GNU General Public
62  ****    License or the Artistic License, as specified in the README file.
63  *
64  * Beware that some of this code is subtly aware of the way operator
65  * precedence is structured in regular expressions.  Serious changes in
66  * regular-expression syntax might require a total rethink.
67  */
68 #include "EXTERN.h"
69 #define PERL_IN_REGEXEC_C
70 #include "perl.h"
71
72 #ifdef PERL_IN_XSUB_RE
73 #  include "re_comp.h"
74 #else
75 #  include "regcomp.h"
76 #endif
77
78 #define RF_tainted      1               /* tainted information used? */
79 #define RF_warned       2               /* warned about big count? */
80
81 #define RF_utf8         8               /* Pattern contains multibyte chars? */
82
83 #define UTF ((PL_reg_flags & RF_utf8) != 0)
84
85 #define RS_init         1               /* eval environment created */
86 #define RS_set          2               /* replsv value is set */
87
88 #ifndef STATIC
89 #define STATIC  static
90 #endif
91
92 #define REGINCLASS(prog,p,c)  (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0,0) : ANYOF_BITMAP_TEST(p,*(c)))
93
94 /*
95  * Forwards.
96  */
97
98 #define CHR_SVLEN(sv) (do_utf8 ? sv_len_utf8(sv) : SvCUR(sv))
99 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
100
101 #define HOPc(pos,off) \
102         (char *)(PL_reg_match_utf8 \
103             ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
104             : (U8*)(pos + off))
105 #define HOPBACKc(pos, off) \
106         (char*)(PL_reg_match_utf8\
107             ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
108             : (pos - off >= PL_bostr)           \
109                 ? (U8*)pos - off                \
110                 : NULL)
111
112 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
113 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
114
115 #define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
116     if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)str); assert(ok); LEAVE; } } STMT_END
117 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
118 #define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
119 #define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
120 #define LOAD_UTF8_CHARCLASS_MARK()  LOAD_UTF8_CHARCLASS(mark, "\xcd\x86")
121
122 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
123
124 /* for use after a quantifier and before an EXACT-like node -- japhy */
125 #define JUMPABLE(rn) ( \
126     OP(rn) == OPEN || OP(rn) == CLOSE || OP(rn) == EVAL || \
127     OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
128     OP(rn) == PLUS || OP(rn) == MINMOD || \
129     OP(rn) == KEEPS || (PL_regkind[OP(rn)] == VERB) || \
130     (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
131 )
132 #define IS_EXACT(rn) (PL_regkind[OP(rn)] == EXACT)
133
134 #define HAS_TEXT(rn) ( IS_EXACT(rn) || PL_regkind[OP(rn)] == REF )
135
136 #if 0 
137 /* Currently these are only used when PL_regkind[OP(rn)] == EXACT so
138    we don't need this definition. */
139 #define IS_TEXT(rn)   ( OP(rn)==EXACT   || OP(rn)==REF   || OP(rn)==NREF   )
140 #define IS_TEXTF(rn)  ( OP(rn)==EXACTF  || OP(rn)==REFF  || OP(rn)==NREFF  )
141 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL || OP(rn)==REFFL || OP(rn)==NREFFL )
142
143 #else
144 /* ... so we use this as its faster. */
145 #define IS_TEXT(rn)   ( OP(rn)==EXACT   )
146 #define IS_TEXTF(rn)  ( OP(rn)==EXACTF  )
147 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL )
148
149 #endif
150
151 /*
152   Search for mandatory following text node; for lookahead, the text must
153   follow but for lookbehind (rn->flags != 0) we skip to the next step.
154 */
155 #define FIND_NEXT_IMPT(rn) STMT_START { \
156     while (JUMPABLE(rn)) { \
157         const OPCODE type = OP(rn); \
158         if (type == SUSPEND || PL_regkind[type] == CURLY) \
159             rn = NEXTOPER(NEXTOPER(rn)); \
160         else if (type == PLUS) \
161             rn = NEXTOPER(rn); \
162         else if (type == IFMATCH) \
163             rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
164         else rn += NEXT_OFF(rn); \
165     } \
166 } STMT_END 
167
168
169 static void restore_pos(pTHX_ void *arg);
170
171 STATIC CHECKPOINT
172 S_regcppush(pTHX_ I32 parenfloor)
173 {
174     dVAR;
175     const int retval = PL_savestack_ix;
176 #define REGCP_PAREN_ELEMS 4
177     const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
178     int p;
179     GET_RE_DEBUG_FLAGS_DECL;
180
181     if (paren_elems_to_push < 0)
182         Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
183
184 #define REGCP_OTHER_ELEMS 8
185     SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS);
186     
187     for (p = PL_regsize; p > parenfloor; p--) {
188 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
189         SSPUSHINT(PL_regendp[p]);
190         SSPUSHINT(PL_regstartp[p]);
191         SSPUSHPTR(PL_reg_start_tmp[p]);
192         SSPUSHINT(p);
193         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
194           "     saving \\%"UVuf" %"IVdf"(%"IVdf")..%"IVdf"\n",
195                       (UV)p, (IV)PL_regstartp[p],
196                       (IV)(PL_reg_start_tmp[p] - PL_bostr),
197                       (IV)PL_regendp[p]
198         ));
199     }
200 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
201     SSPUSHPTR(PL_regstartp);
202     SSPUSHPTR(PL_regendp);
203     SSPUSHINT(PL_regsize);
204     SSPUSHINT(*PL_reglastparen);
205     SSPUSHINT(*PL_reglastcloseparen);
206     SSPUSHPTR(PL_reginput);
207 #define REGCP_FRAME_ELEMS 2
208 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
209  * are needed for the regexp context stack bookkeeping. */
210     SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
211     SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
212
213     return retval;
214 }
215
216 /* These are needed since we do not localize EVAL nodes: */
217 #define REGCP_SET(cp)                                           \
218     DEBUG_STATE_r(                                              \
219             PerlIO_printf(Perl_debug_log,                       \
220                 "  Setting an EVAL scope, savestack=%"IVdf"\n", \
221                 (IV)PL_savestack_ix));                          \
222     cp = PL_savestack_ix
223
224 #define REGCP_UNWIND(cp)                                        \
225     DEBUG_STATE_r(                                              \
226         if (cp != PL_savestack_ix)                              \
227             PerlIO_printf(Perl_debug_log,                       \
228                 "  Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
229                 (IV)(cp), (IV)PL_savestack_ix));                \
230     regcpblow(cp)
231
232 STATIC char *
233 S_regcppop(pTHX_ const regexp *rex)
234 {
235     dVAR;
236     U32 i;
237     char *input;
238
239     GET_RE_DEBUG_FLAGS_DECL;
240
241     /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
242     i = SSPOPINT;
243     assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
244     i = SSPOPINT; /* Parentheses elements to pop. */
245     input = (char *) SSPOPPTR;
246     *PL_reglastcloseparen = SSPOPINT;
247     *PL_reglastparen = SSPOPINT;
248     PL_regsize = SSPOPINT;
249     PL_regendp=(I32 *) SSPOPPTR;
250     PL_regstartp=(I32 *) SSPOPPTR;
251
252     
253     /* Now restore the parentheses context. */
254     for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
255          i > 0; i -= REGCP_PAREN_ELEMS) {
256         I32 tmps;
257         U32 paren = (U32)SSPOPINT;
258         PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
259         PL_regstartp[paren] = SSPOPINT;
260         tmps = SSPOPINT;
261         if (paren <= *PL_reglastparen)
262             PL_regendp[paren] = tmps;
263         DEBUG_EXECUTE_r(
264             PerlIO_printf(Perl_debug_log,
265                           "     restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
266                           (UV)paren, (IV)PL_regstartp[paren],
267                           (IV)(PL_reg_start_tmp[paren] - PL_bostr),
268                           (IV)PL_regendp[paren],
269                           (paren > *PL_reglastparen ? "(no)" : ""));
270         );
271     }
272     DEBUG_EXECUTE_r(
273         if (*PL_reglastparen + 1 <= rex->nparens) {
274             PerlIO_printf(Perl_debug_log,
275                           "     restoring \\%"IVdf"..\\%"IVdf" to undef\n",
276                           (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
277         }
278     );
279 #if 1
280     /* It would seem that the similar code in regtry()
281      * already takes care of this, and in fact it is in
282      * a better location to since this code can #if 0-ed out
283      * but the code in regtry() is needed or otherwise tests
284      * requiring null fields (pat.t#187 and split.t#{13,14}
285      * (as of patchlevel 7877)  will fail.  Then again,
286      * this code seems to be necessary or otherwise
287      * building DynaLoader will fail:
288      * "Error: '*' not in typemap in DynaLoader.xs, line 164"
289      * --jhi */
290     for (i = *PL_reglastparen + 1; i <= rex->nparens; i++) {
291         if (i > PL_regsize)
292             PL_regstartp[i] = -1;
293         PL_regendp[i] = -1;
294     }
295 #endif
296     return input;
297 }
298
299 #define regcpblow(cp) LEAVE_SCOPE(cp)   /* Ignores regcppush()ed data. */
300
301 /*
302  * pregexec and friends
303  */
304
305 #ifndef PERL_IN_XSUB_RE
306 /*
307  - pregexec - match a regexp against a string
308  */
309 I32
310 Perl_pregexec(pTHX_ register regexp *prog, char *stringarg, register char *strend,
311          char *strbeg, I32 minend, SV *screamer, U32 nosave)
312 /* strend: pointer to null at end of string */
313 /* strbeg: real beginning of string */
314 /* minend: end of match must be >=minend after stringarg. */
315 /* nosave: For optimizations. */
316 {
317     return
318         regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
319                       nosave ? 0 : REXEC_COPY_STR);
320 }
321 #endif
322
323 /*
324  * Need to implement the following flags for reg_anch:
325  *
326  * USE_INTUIT_NOML              - Useful to call re_intuit_start() first
327  * USE_INTUIT_ML
328  * INTUIT_AUTORITATIVE_NOML     - Can trust a positive answer
329  * INTUIT_AUTORITATIVE_ML
330  * INTUIT_ONCE_NOML             - Intuit can match in one location only.
331  * INTUIT_ONCE_ML
332  *
333  * Another flag for this function: SECOND_TIME (so that float substrs
334  * with giant delta may be not rechecked).
335  */
336
337 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
338
339 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
340    Otherwise, only SvCUR(sv) is used to get strbeg. */
341
342 /* XXXX We assume that strpos is strbeg unless sv. */
343
344 /* XXXX Some places assume that there is a fixed substring.
345         An update may be needed if optimizer marks as "INTUITable"
346         RExen without fixed substrings.  Similarly, it is assumed that
347         lengths of all the strings are no more than minlen, thus they
348         cannot come from lookahead.
349         (Or minlen should take into account lookahead.) 
350   NOTE: Some of this comment is not correct. minlen does now take account
351   of lookahead/behind. Further research is required. -- demerphq
352
353 */
354
355 /* A failure to find a constant substring means that there is no need to make
356    an expensive call to REx engine, thus we celebrate a failure.  Similarly,
357    finding a substring too deep into the string means that less calls to
358    regtry() should be needed.
359
360    REx compiler's optimizer found 4 possible hints:
361         a) Anchored substring;
362         b) Fixed substring;
363         c) Whether we are anchored (beginning-of-line or \G);
364         d) First node (of those at offset 0) which may distingush positions;
365    We use a)b)d) and multiline-part of c), and try to find a position in the
366    string which does not contradict any of them.
367  */
368
369 /* Most of decisions we do here should have been done at compile time.
370    The nodes of the REx which we used for the search should have been
371    deleted from the finite automaton. */
372
373 char *
374 Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
375                      char *strend, U32 flags, re_scream_pos_data *data)
376 {
377     dVAR;
378     register I32 start_shift = 0;
379     /* Should be nonnegative! */
380     register I32 end_shift   = 0;
381     register char *s;
382     register SV *check;
383     char *strbeg;
384     char *t;
385     const bool do_utf8 = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
386     I32 ml_anch;
387     register char *other_last = NULL;   /* other substr checked before this */
388     char *check_at = NULL;              /* check substr found at this pos */
389     const I32 multiline = prog->extflags & RXf_PMf_MULTILINE;
390     RXi_GET_DECL(prog,progi);
391 #ifdef DEBUGGING
392     const char * const i_strpos = strpos;
393 #endif
394
395     GET_RE_DEBUG_FLAGS_DECL;
396
397     RX_MATCH_UTF8_set(prog,do_utf8);
398
399     if (prog->extflags & RXf_UTF8) {
400         PL_reg_flags |= RF_utf8;
401     }
402     DEBUG_EXECUTE_r( 
403         debug_start_match(prog, do_utf8, strpos, strend, 
404             sv ? "Guessing start of match in sv for"
405                : "Guessing start of match in string for");
406               );
407
408     /* CHR_DIST() would be more correct here but it makes things slow. */
409     if (prog->minlen > strend - strpos) {
410         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
411                               "String too short... [re_intuit_start]\n"));
412         goto fail;
413     }
414                 
415     strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
416     PL_regeol = strend;
417     if (do_utf8) {
418         if (!prog->check_utf8 && prog->check_substr)
419             to_utf8_substr(prog);
420         check = prog->check_utf8;
421     } else {
422         if (!prog->check_substr && prog->check_utf8)
423             to_byte_substr(prog);
424         check = prog->check_substr;
425     }
426     if (check == &PL_sv_undef) {
427         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
428                 "Non-utf8 string cannot match utf8 check string\n"));
429         goto fail;
430     }
431     if (prog->extflags & RXf_ANCH) {    /* Match at beg-of-str or after \n */
432         ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE)
433                      || ( (prog->extflags & RXf_ANCH_BOL)
434                           && !multiline ) );    /* Check after \n? */
435
436         if (!ml_anch) {
437           if ( !(prog->extflags & RXf_ANCH_GPOS) /* Checked by the caller */
438                 && !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */
439                /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
440                && sv && !SvROK(sv)
441                && (strpos != strbeg)) {
442               DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
443               goto fail;
444           }
445           if (prog->check_offset_min == prog->check_offset_max &&
446               !(prog->extflags & RXf_CANY_SEEN)) {
447             /* Substring at constant offset from beg-of-str... */
448             I32 slen;
449
450             s = HOP3c(strpos, prog->check_offset_min, strend);
451             
452             if (SvTAIL(check)) {
453                 slen = SvCUR(check);    /* >= 1 */
454
455                 if ( strend - s > slen || strend - s < slen - 1
456                      || (strend - s == slen && strend[-1] != '\n')) {
457                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
458                     goto fail_finish;
459                 }
460                 /* Now should match s[0..slen-2] */
461                 slen--;
462                 if (slen && (*SvPVX_const(check) != *s
463                              || (slen > 1
464                                  && memNE(SvPVX_const(check), s, slen)))) {
465                   report_neq:
466                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
467                     goto fail_finish;
468                 }
469             }
470             else if (*SvPVX_const(check) != *s
471                      || ((slen = SvCUR(check)) > 1
472                          && memNE(SvPVX_const(check), s, slen)))
473                 goto report_neq;
474             check_at = s;
475             goto success_at_start;
476           }
477         }
478         /* Match is anchored, but substr is not anchored wrt beg-of-str. */
479         s = strpos;
480         start_shift = prog->check_offset_min; /* okay to underestimate on CC */
481         end_shift = prog->check_end_shift;
482         
483         if (!ml_anch) {
484             const I32 end = prog->check_offset_max + CHR_SVLEN(check)
485                                          - (SvTAIL(check) != 0);
486             const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
487
488             if (end_shift < eshift)
489                 end_shift = eshift;
490         }
491     }
492     else {                              /* Can match at random position */
493         ml_anch = 0;
494         s = strpos;
495         start_shift = prog->check_offset_min;  /* okay to underestimate on CC */
496         end_shift = prog->check_end_shift;
497         
498         /* end shift should be non negative here */
499     }
500
501 #ifdef DEBUGGING        /* 7/99: reports of failure (with the older version) */
502     if (end_shift < 0)
503         Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
504                    (IV)end_shift, prog->precomp);
505 #endif
506
507   restart:
508     /* Find a possible match in the region s..strend by looking for
509        the "check" substring in the region corrected by start/end_shift. */
510     
511     {
512         I32 srch_start_shift = start_shift;
513         I32 srch_end_shift = end_shift;
514         if (srch_start_shift < 0 && strbeg - s > srch_start_shift) {
515             srch_end_shift -= ((strbeg - s) - srch_start_shift); 
516             srch_start_shift = strbeg - s;
517         }
518     DEBUG_OPTIMISE_MORE_r({
519         PerlIO_printf(Perl_debug_log, "Check offset min: %"IVdf" Start shift: %"IVdf" End shift %"IVdf" Real End Shift: %"IVdf"\n",
520             (IV)prog->check_offset_min,
521             (IV)srch_start_shift,
522             (IV)srch_end_shift, 
523             (IV)prog->check_end_shift);
524     });       
525         
526     if (flags & REXEC_SCREAM) {
527         I32 p = -1;                     /* Internal iterator of scream. */
528         I32 * const pp = data ? data->scream_pos : &p;
529
530         if (PL_screamfirst[BmRARE(check)] >= 0
531             || ( BmRARE(check) == '\n'
532                  && (BmPREVIOUS(check) == SvCUR(check) - 1)
533                  && SvTAIL(check) ))
534             s = screaminstr(sv, check,
535                             srch_start_shift + (s - strbeg), srch_end_shift, pp, 0);
536         else
537             goto fail_finish;
538         /* we may be pointing at the wrong string */
539         if (s && RX_MATCH_COPIED(prog))
540             s = strbeg + (s - SvPVX_const(sv));
541         if (data)
542             *data->scream_olds = s;
543     }
544     else {
545         U8* start_point;
546         U8* end_point;
547         if (prog->extflags & RXf_CANY_SEEN) {
548             start_point= (U8*)(s + srch_start_shift);
549             end_point= (U8*)(strend - srch_end_shift);
550         } else {
551             start_point= HOP3(s, srch_start_shift, srch_start_shift < 0 ? strbeg : strend);
552             end_point= HOP3(strend, -srch_end_shift, strbeg);
553         }
554         DEBUG_OPTIMISE_MORE_r({
555             PerlIO_printf(Perl_debug_log, "fbm_instr len=%d str=<%.*s>\n", 
556                 (int)(end_point - start_point),
557                 (int)(end_point - start_point) > 20 ? 20 : (int)(end_point - start_point), 
558                 start_point);
559         });
560
561         s = fbm_instr( start_point, end_point,
562                       check, multiline ? FBMrf_MULTILINE : 0);
563     }
564     }
565     /* Update the count-of-usability, remove useless subpatterns,
566         unshift s.  */
567
568     DEBUG_EXECUTE_r({
569         RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0), 
570             SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
571         PerlIO_printf(Perl_debug_log, "%s %s substr %s%s%s",
572                           (s ? "Found" : "Did not find"),
573             (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) 
574                 ? "anchored" : "floating"),
575             quoted,
576             RE_SV_TAIL(check),
577             (s ? " at offset " : "...\n") ); 
578     });
579
580     if (!s)
581         goto fail_finish;
582     /* Finish the diagnostic message */
583     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
584
585     /* XXX dmq: first branch is for positive lookbehind...
586        Our check string is offset from the beginning of the pattern.
587        So we need to do any stclass tests offset forward from that 
588        point. I think. :-(
589      */
590     
591         
592     
593     check_at=s;
594      
595
596     /* Got a candidate.  Check MBOL anchoring, and the *other* substr.
597        Start with the other substr.
598        XXXX no SCREAM optimization yet - and a very coarse implementation
599        XXXX /ttx+/ results in anchored="ttx", floating="x".  floating will
600                 *always* match.  Probably should be marked during compile...
601        Probably it is right to do no SCREAM here...
602      */
603
604     if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8) 
605                 : (prog->float_substr && prog->anchored_substr)) 
606     {
607         /* Take into account the "other" substring. */
608         /* XXXX May be hopelessly wrong for UTF... */
609         if (!other_last)
610             other_last = strpos;
611         if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
612           do_other_anchored:
613             {
614                 char * const last = HOP3c(s, -start_shift, strbeg);
615                 char *last1, *last2;
616                 char * const saved_s = s;
617                 SV* must;
618
619                 t = s - prog->check_offset_max;
620                 if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
621                     && (!do_utf8
622                         || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
623                             && t > strpos)))
624                     NOOP;
625                 else
626                     t = strpos;
627                 t = HOP3c(t, prog->anchored_offset, strend);
628                 if (t < other_last)     /* These positions already checked */
629                     t = other_last;
630                 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
631                 if (last < last1)
632                     last1 = last;
633                 /* XXXX It is not documented what units *_offsets are in.  
634                    We assume bytes, but this is clearly wrong. 
635                    Meaning this code needs to be carefully reviewed for errors.
636                    dmq.
637                   */
638  
639                 /* On end-of-str: see comment below. */
640                 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
641                 if (must == &PL_sv_undef) {
642                     s = (char*)NULL;
643                     DEBUG_r(must = prog->anchored_utf8);        /* for debug */
644                 }
645                 else
646                     s = fbm_instr(
647                         (unsigned char*)t,
648                         HOP3(HOP3(last1, prog->anchored_offset, strend)
649                                 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
650                         must,
651                         multiline ? FBMrf_MULTILINE : 0
652                     );
653                 DEBUG_EXECUTE_r({
654                     RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0), 
655                         SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
656                     PerlIO_printf(Perl_debug_log, "%s anchored substr %s%s",
657                         (s ? "Found" : "Contradicts"),
658                         quoted, RE_SV_TAIL(must));
659                 });                 
660                 
661                             
662                 if (!s) {
663                     if (last1 >= last2) {
664                         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
665                                                 ", giving up...\n"));
666                         goto fail_finish;
667                     }
668                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
669                         ", trying floating at offset %ld...\n",
670                         (long)(HOP3c(saved_s, 1, strend) - i_strpos)));
671                     other_last = HOP3c(last1, prog->anchored_offset+1, strend);
672                     s = HOP3c(last, 1, strend);
673                     goto restart;
674                 }
675                 else {
676                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
677                           (long)(s - i_strpos)));
678                     t = HOP3c(s, -prog->anchored_offset, strbeg);
679                     other_last = HOP3c(s, 1, strend);
680                     s = saved_s;
681                     if (t == strpos)
682                         goto try_at_start;
683                     goto try_at_offset;
684                 }
685             }
686         }
687         else {          /* Take into account the floating substring. */
688             char *last, *last1;
689             char * const saved_s = s;
690             SV* must;
691
692             t = HOP3c(s, -start_shift, strbeg);
693             last1 = last =
694                 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
695             if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
696                 last = HOP3c(t, prog->float_max_offset, strend);
697             s = HOP3c(t, prog->float_min_offset, strend);
698             if (s < other_last)
699                 s = other_last;
700  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
701             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
702             /* fbm_instr() takes into account exact value of end-of-str
703                if the check is SvTAIL(ed).  Since false positives are OK,
704                and end-of-str is not later than strend we are OK. */
705             if (must == &PL_sv_undef) {
706                 s = (char*)NULL;
707                 DEBUG_r(must = prog->float_utf8);       /* for debug message */
708             }
709             else
710                 s = fbm_instr((unsigned char*)s,
711                               (unsigned char*)last + SvCUR(must)
712                                   - (SvTAIL(must)!=0),
713                               must, multiline ? FBMrf_MULTILINE : 0);
714             DEBUG_EXECUTE_r({
715                 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0), 
716                     SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
717                 PerlIO_printf(Perl_debug_log, "%s floating substr %s%s",
718                     (s ? "Found" : "Contradicts"),
719                     quoted, RE_SV_TAIL(must));
720             });
721             if (!s) {
722                 if (last1 == last) {
723                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
724                                             ", giving up...\n"));
725                     goto fail_finish;
726                 }
727                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
728                     ", trying anchored starting at offset %ld...\n",
729                     (long)(saved_s + 1 - i_strpos)));
730                 other_last = last;
731                 s = HOP3c(t, 1, strend);
732                 goto restart;
733             }
734             else {
735                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
736                       (long)(s - i_strpos)));
737                 other_last = s; /* Fix this later. --Hugo */
738                 s = saved_s;
739                 if (t == strpos)
740                     goto try_at_start;
741                 goto try_at_offset;
742             }
743         }
744     }
745
746     
747     t= (char*)HOP3( s, -prog->check_offset_max, (prog->check_offset_max<0) ? strend : strpos);
748         
749     DEBUG_OPTIMISE_MORE_r(
750         PerlIO_printf(Perl_debug_log, 
751             "Check offset min:%"IVdf" max:%"IVdf" S:%"IVdf" t:%"IVdf" D:%"IVdf" end:%"IVdf"\n",
752             (IV)prog->check_offset_min,
753             (IV)prog->check_offset_max,
754             (IV)(s-strpos),
755             (IV)(t-strpos),
756             (IV)(t-s),
757             (IV)(strend-strpos)
758         )
759     );
760
761     if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
762         && (!do_utf8
763             || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*) ((prog->check_offset_max<0) ? strend : strpos)))
764                  && t > strpos))) 
765     {
766         /* Fixed substring is found far enough so that the match
767            cannot start at strpos. */
768       try_at_offset:
769         if (ml_anch && t[-1] != '\n') {
770             /* Eventually fbm_*() should handle this, but often
771                anchored_offset is not 0, so this check will not be wasted. */
772             /* XXXX In the code below we prefer to look for "^" even in
773                presence of anchored substrings.  And we search even
774                beyond the found float position.  These pessimizations
775                are historical artefacts only.  */
776           find_anchor:
777             while (t < strend - prog->minlen) {
778                 if (*t == '\n') {
779                     if (t < check_at - prog->check_offset_min) {
780                         if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
781                             /* Since we moved from the found position,
782                                we definitely contradict the found anchored
783                                substr.  Due to the above check we do not
784                                contradict "check" substr.
785                                Thus we can arrive here only if check substr
786                                is float.  Redo checking for "other"=="fixed".
787                              */
788                             strpos = t + 1;                     
789                             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
790                                 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
791                             goto do_other_anchored;
792                         }
793                         /* We don't contradict the found floating substring. */
794                         /* XXXX Why not check for STCLASS? */
795                         s = t + 1;
796                         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
797                             PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
798                         goto set_useful;
799                     }
800                     /* Position contradicts check-string */
801                     /* XXXX probably better to look for check-string
802                        than for "\n", so one should lower the limit for t? */
803                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
804                         PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
805                     other_last = strpos = s = t + 1;
806                     goto restart;
807                 }
808                 t++;
809             }
810             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
811                         PL_colors[0], PL_colors[1]));
812             goto fail_finish;
813         }
814         else {
815             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
816                         PL_colors[0], PL_colors[1]));
817         }
818         s = t;
819       set_useful:
820         ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr);    /* hooray/5 */
821     }
822     else {
823         /* The found string does not prohibit matching at strpos,
824            - no optimization of calling REx engine can be performed,
825            unless it was an MBOL and we are not after MBOL,
826            or a future STCLASS check will fail this. */
827       try_at_start:
828         /* Even in this situation we may use MBOL flag if strpos is offset
829            wrt the start of the string. */
830         if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
831             && (strpos != strbeg) && strpos[-1] != '\n'
832             /* May be due to an implicit anchor of m{.*foo}  */
833             && !(prog->intflags & PREGf_IMPLICIT))
834         {
835             t = strpos;
836             goto find_anchor;
837         }
838         DEBUG_EXECUTE_r( if (ml_anch)
839             PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
840                           (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
841         );
842       success_at_start:
843         if (!(prog->intflags & PREGf_NAUGHTY)   /* XXXX If strpos moved? */
844             && (do_utf8 ? (
845                 prog->check_utf8                /* Could be deleted already */
846                 && --BmUSEFUL(prog->check_utf8) < 0
847                 && (prog->check_utf8 == prog->float_utf8)
848             ) : (
849                 prog->check_substr              /* Could be deleted already */
850                 && --BmUSEFUL(prog->check_substr) < 0
851                 && (prog->check_substr == prog->float_substr)
852             )))
853         {
854             /* If flags & SOMETHING - do not do it many times on the same match */
855             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
856             SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
857             if (do_utf8 ? prog->check_substr : prog->check_utf8)
858                 SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
859             prog->check_substr = prog->check_utf8 = NULL;       /* disable */
860             prog->float_substr = prog->float_utf8 = NULL;       /* clear */
861             check = NULL;                       /* abort */
862             s = strpos;
863             /* XXXX This is a remnant of the old implementation.  It
864                     looks wasteful, since now INTUIT can use many
865                     other heuristics. */
866             prog->extflags &= ~RXf_USE_INTUIT;
867         }
868         else
869             s = strpos;
870     }
871
872     /* Last resort... */
873     /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
874     /* trie stclasses are too expensive to use here, we are better off to
875        leave it to regmatch itself */
876     if (progi->regstclass && PL_regkind[OP(progi->regstclass)]!=TRIE) {
877         /* minlen == 0 is possible if regstclass is \b or \B,
878            and the fixed substr is ''$.
879            Since minlen is already taken into account, s+1 is before strend;
880            accidentally, minlen >= 1 guaranties no false positives at s + 1
881            even for \b or \B.  But (minlen? 1 : 0) below assumes that
882            regstclass does not come from lookahead...  */
883         /* If regstclass takes bytelength more than 1: If charlength==1, OK.
884            This leaves EXACTF only, which is dealt with in find_byclass().  */
885         const U8* const str = (U8*)STRING(progi->regstclass);
886         const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
887                     ? CHR_DIST(str+STR_LEN(progi->regstclass), str)
888                     : 1);
889         char * endpos;
890         if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
891             endpos= HOP3c(s, (prog->minlen ? cl_l : 0), strend);
892         else if (prog->float_substr || prog->float_utf8)
893             endpos= HOP3c(HOP3c(check_at, -start_shift, strbeg), cl_l, strend);
894         else 
895             endpos= strend;
896                     
897         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" s: %"IVdf" endpos: %"IVdf"\n",
898                                       (IV)start_shift, (IV)(check_at - strbeg), (IV)(s - strbeg), (IV)(endpos - strbeg)));
899         
900         t = s;
901         s = find_byclass(prog, progi->regstclass, s, endpos, NULL);
902         if (!s) {
903 #ifdef DEBUGGING
904             const char *what = NULL;
905 #endif
906             if (endpos == strend) {
907                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
908                                 "Could not match STCLASS...\n") );
909                 goto fail;
910             }
911             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
912                                    "This position contradicts STCLASS...\n") );
913             if ((prog->extflags & RXf_ANCH) && !ml_anch)
914                 goto fail;
915             /* Contradict one of substrings */
916             if (prog->anchored_substr || prog->anchored_utf8) {
917                 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
918                     DEBUG_EXECUTE_r( what = "anchored" );
919                   hop_and_restart:
920                     s = HOP3c(t, 1, strend);
921                     if (s + start_shift + end_shift > strend) {
922                         /* XXXX Should be taken into account earlier? */
923                         DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
924                                                "Could not match STCLASS...\n") );
925                         goto fail;
926                     }
927                     if (!check)
928                         goto giveup;
929                     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
930                                 "Looking for %s substr starting at offset %ld...\n",
931                                  what, (long)(s + start_shift - i_strpos)) );
932                     goto restart;
933                 }
934                 /* Have both, check_string is floating */
935                 if (t + start_shift >= check_at) /* Contradicts floating=check */
936                     goto retry_floating_check;
937                 /* Recheck anchored substring, but not floating... */
938                 s = check_at;
939                 if (!check)
940                     goto giveup;
941                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
942                           "Looking for anchored substr starting at offset %ld...\n",
943                           (long)(other_last - i_strpos)) );
944                 goto do_other_anchored;
945             }
946             /* Another way we could have checked stclass at the
947                current position only: */
948             if (ml_anch) {
949                 s = t = t + 1;
950                 if (!check)
951                     goto giveup;
952                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
953                           "Looking for /%s^%s/m starting at offset %ld...\n",
954                           PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
955                 goto try_at_offset;
956             }
957             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))     /* Could have been deleted */
958                 goto fail;
959             /* Check is floating subtring. */
960           retry_floating_check:
961             t = check_at - start_shift;
962             DEBUG_EXECUTE_r( what = "floating" );
963             goto hop_and_restart;
964         }
965         if (t != s) {
966             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
967                         "By STCLASS: moving %ld --> %ld\n",
968                                   (long)(t - i_strpos), (long)(s - i_strpos))
969                    );
970         }
971         else {
972             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
973                                   "Does not contradict STCLASS...\n"); 
974                    );
975         }
976     }
977   giveup:
978     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
979                           PL_colors[4], (check ? "Guessed" : "Giving up"),
980                           PL_colors[5], (long)(s - i_strpos)) );
981     return s;
982
983   fail_finish:                          /* Substring not found */
984     if (prog->check_substr || prog->check_utf8)         /* could be removed already */
985         BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
986   fail:
987     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
988                           PL_colors[4], PL_colors[5]));
989     return NULL;
990 }
991
992
993
994 #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len,  \
995 uvc, charid, foldlen, foldbuf, uniflags) STMT_START {                       \
996     switch (trie_type) {                                                    \
997     case trie_utf8_fold:                                                    \
998         if ( foldlen>0 ) {                                                  \
999             uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );     \
1000             foldlen -= len;                                                 \
1001             uscan += len;                                                   \
1002             len=0;                                                          \
1003         } else {                                                            \
1004             uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );   \
1005             uvc = to_uni_fold( uvc, foldbuf, &foldlen );                    \
1006             foldlen -= UNISKIP( uvc );                                      \
1007             uscan = foldbuf + UNISKIP( uvc );                               \
1008         }                                                                   \
1009         break;                                                              \
1010     case trie_utf8:                                                         \
1011         uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );       \
1012         break;                                                              \
1013     case trie_plain:                                                        \
1014         uvc = (UV)*uc;                                                      \
1015         len = 1;                                                            \
1016     }                                                                       \
1017                                                                             \
1018     if (uvc < 256) {                                                        \
1019         charid = trie->charmap[ uvc ];                                      \
1020     }                                                                       \
1021     else {                                                                  \
1022         charid = 0;                                                         \
1023         if (widecharmap) {                                                  \
1024             SV** const svpp = hv_fetch(widecharmap,                         \
1025                         (char*)&uvc, sizeof(UV), 0);                        \
1026             if (svpp)                                                       \
1027                 charid = (U16)SvIV(*svpp);                                  \
1028         }                                                                   \
1029     }                                                                       \
1030 } STMT_END
1031
1032 #define REXEC_FBC_EXACTISH_CHECK(CoNd)                  \
1033     if ( (CoNd)                                        \
1034          && (ln == len ||                              \
1035              ibcmp_utf8(s, NULL, 0,  do_utf8,          \
1036                         m, NULL, ln, (bool)UTF))       \
1037          && (!reginfo || regtry(reginfo, &s)) )         \
1038         goto got_it;                                   \
1039     else {                                             \
1040          U8 foldbuf[UTF8_MAXBYTES_CASE+1];             \
1041          uvchr_to_utf8(tmpbuf, c);                     \
1042          f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);  \
1043          if ( f != c                                   \
1044               && (f == c1 || f == c2)                  \
1045               && (ln == foldlen ||                     \
1046                   !ibcmp_utf8((char *) foldbuf,        \
1047                               NULL, foldlen, do_utf8,  \
1048                               m,                       \
1049                               NULL, ln, (bool)UTF))    \
1050               && (!reginfo || regtry(reginfo, &s)) )    \
1051               goto got_it;                             \
1052     }                                                  \
1053     s += len
1054
1055 #define REXEC_FBC_EXACTISH_SCAN(CoNd)                     \
1056 STMT_START {                                              \
1057     while (s <= e) {                                      \
1058         if ( (CoNd)                                       \
1059              && (ln == 1 || !(OP(c) == EXACTF             \
1060                               ? ibcmp(s, m, ln)           \
1061                               : ibcmp_locale(s, m, ln)))  \
1062              && (!reginfo || regtry(reginfo, &s)) )        \
1063             goto got_it;                                  \
1064         s++;                                              \
1065     }                                                     \
1066 } STMT_END
1067
1068 #define REXEC_FBC_UTF8_SCAN(CoDe)                     \
1069 STMT_START {                                          \
1070     while (s + (uskip = UTF8SKIP(s)) <= strend) {     \
1071         CoDe                                          \
1072         s += uskip;                                   \
1073     }                                                 \
1074 } STMT_END
1075
1076 #define REXEC_FBC_SCAN(CoDe)                          \
1077 STMT_START {                                          \
1078     while (s < strend) {                              \
1079         CoDe                                          \
1080         s++;                                          \
1081     }                                                 \
1082 } STMT_END
1083
1084 #define REXEC_FBC_UTF8_CLASS_SCAN(CoNd)               \
1085 REXEC_FBC_UTF8_SCAN(                                  \
1086     if (CoNd) {                                       \
1087         if (tmp && (!reginfo || regtry(reginfo, &s)))  \
1088             goto got_it;                              \
1089         else                                          \
1090             tmp = doevery;                            \
1091     }                                                 \
1092     else                                              \
1093         tmp = 1;                                      \
1094 )
1095
1096 #define REXEC_FBC_CLASS_SCAN(CoNd)                    \
1097 REXEC_FBC_SCAN(                                       \
1098     if (CoNd) {                                       \
1099         if (tmp && (!reginfo || regtry(reginfo, &s)))  \
1100             goto got_it;                              \
1101         else                                          \
1102             tmp = doevery;                            \
1103     }                                                 \
1104     else                                              \
1105         tmp = 1;                                      \
1106 )
1107
1108 #define REXEC_FBC_TRYIT               \
1109 if ((!reginfo || regtry(reginfo, &s))) \
1110     goto got_it
1111
1112 #define REXEC_FBC_CSCAN_PRELOAD(UtFpReLoAd,CoNdUtF8,CoNd)      \
1113     if (do_utf8) {                                             \
1114         UtFpReLoAd;                                            \
1115         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1116     }                                                          \
1117     else {                                                     \
1118         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1119     }                                                          \
1120     break
1121
1122 #define REXEC_FBC_CSCAN_TAINT(CoNdUtF8,CoNd)                   \
1123     PL_reg_flags |= RF_tainted;                                \
1124     if (do_utf8) {                                             \
1125         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1126     }                                                          \
1127     else {                                                     \
1128         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1129     }                                                          \
1130     break
1131
1132 #define DUMP_EXEC_POS(li,s,doutf8) \
1133     dump_exec_pos(li,s,(PL_regeol),(PL_bostr),(PL_reg_starttry),doutf8)
1134
1135 /* We know what class REx starts with.  Try to find this position... */
1136 /* if reginfo is NULL, its a dryrun */
1137 /* annoyingly all the vars in this routine have different names from their counterparts
1138    in regmatch. /grrr */
1139
1140 STATIC char *
1141 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, 
1142     const char *strend, regmatch_info *reginfo)
1143 {
1144         dVAR;
1145         const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
1146         char *m;
1147         STRLEN ln;
1148         STRLEN lnc;
1149         register STRLEN uskip;
1150         unsigned int c1;
1151         unsigned int c2;
1152         char *e;
1153         register I32 tmp = 1;   /* Scratch variable? */
1154         register const bool do_utf8 = PL_reg_match_utf8;
1155         RXi_GET_DECL(prog,progi);
1156         
1157         /* We know what class it must start with. */
1158         switch (OP(c)) {
1159         case ANYOF:
1160             if (do_utf8) {
1161                  REXEC_FBC_UTF8_CLASS_SCAN((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
1162                           !UTF8_IS_INVARIANT((U8)s[0]) ?
1163                           reginclass(prog, c, (U8*)s, 0, do_utf8) :
1164                           REGINCLASS(prog, c, (U8*)s));
1165             }
1166             else {
1167                  while (s < strend) {
1168                       STRLEN skip = 1;
1169
1170                       if (REGINCLASS(prog, c, (U8*)s) ||
1171                           (ANYOF_FOLD_SHARP_S(c, s, strend) &&
1172                            /* The assignment of 2 is intentional:
1173                             * for the folded sharp s, the skip is 2. */
1174                            (skip = SHARP_S_SKIP))) {
1175                            if (tmp && (!reginfo || regtry(reginfo, &s)))
1176                                 goto got_it;
1177                            else
1178                                 tmp = doevery;
1179                       }
1180                       else 
1181                            tmp = 1;
1182                       s += skip;
1183                  }
1184             }
1185             break;
1186         case CANY:
1187             REXEC_FBC_SCAN(
1188                 if (tmp && (!reginfo || regtry(reginfo, &s)))
1189                     goto got_it;
1190                 else
1191                     tmp = doevery;
1192             );
1193             break;
1194         case EXACTF:
1195             m   = STRING(c);
1196             ln  = STR_LEN(c);   /* length to match in octets/bytes */
1197             lnc = (I32) ln;     /* length to match in characters */
1198             if (UTF) {
1199                 STRLEN ulen1, ulen2;
1200                 U8 *sm = (U8 *) m;
1201                 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
1202                 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
1203                 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1204
1205                 to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1206                 to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1207
1208                 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE, 
1209                                     0, uniflags);
1210                 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
1211                                     0, uniflags);
1212                 lnc = 0;
1213                 while (sm < ((U8 *) m + ln)) {
1214                     lnc++;
1215                     sm += UTF8SKIP(sm);
1216                 }
1217             }
1218             else {
1219                 c1 = *(U8*)m;
1220                 c2 = PL_fold[c1];
1221             }
1222             goto do_exactf;
1223         case EXACTFL:
1224             m   = STRING(c);
1225             ln  = STR_LEN(c);
1226             lnc = (I32) ln;
1227             c1 = *(U8*)m;
1228             c2 = PL_fold_locale[c1];
1229           do_exactf:
1230             e = HOP3c(strend, -((I32)lnc), s);
1231
1232             if (!reginfo && e < s)
1233                 e = s;                  /* Due to minlen logic of intuit() */
1234
1235             /* The idea in the EXACTF* cases is to first find the
1236              * first character of the EXACTF* node and then, if
1237              * necessary, case-insensitively compare the full
1238              * text of the node.  The c1 and c2 are the first
1239              * characters (though in Unicode it gets a bit
1240              * more complicated because there are more cases
1241              * than just upper and lower: one needs to use
1242              * the so-called folding case for case-insensitive
1243              * matching (called "loose matching" in Unicode).
1244              * ibcmp_utf8() will do just that. */
1245
1246             if (do_utf8) {
1247                 UV c, f;
1248                 U8 tmpbuf [UTF8_MAXBYTES+1];
1249                 STRLEN len, foldlen;
1250                 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1251                 if (c1 == c2) {
1252                     /* Upper and lower of 1st char are equal -
1253                      * probably not a "letter". */
1254                     while (s <= e) {
1255                         c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1256                                            uniflags);
1257                         REXEC_FBC_EXACTISH_CHECK(c == c1);
1258                     }
1259                 }
1260                 else {
1261                     while (s <= e) {
1262                       c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1263                                            uniflags);
1264
1265                         /* Handle some of the three Greek sigmas cases.
1266                          * Note that not all the possible combinations
1267                          * are handled here: some of them are handled
1268                          * by the standard folding rules, and some of
1269                          * them (the character class or ANYOF cases)
1270                          * are handled during compiletime in
1271                          * regexec.c:S_regclass(). */
1272                         if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1273                             c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1274                             c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1275
1276                         REXEC_FBC_EXACTISH_CHECK(c == c1 || c == c2);
1277                     }
1278                 }
1279             }
1280             else {
1281                 if (c1 == c2)
1282                     REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1283                 else
1284                     REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1285             }
1286             break;
1287         case BOUNDL:
1288             PL_reg_flags |= RF_tainted;
1289             /* FALL THROUGH */
1290         case BOUND:
1291             if (do_utf8) {
1292                 if (s == PL_bostr)
1293                     tmp = '\n';
1294                 else {
1295                     U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1296                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1297                 }
1298                 tmp = ((OP(c) == BOUND ?
1299                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1300                 LOAD_UTF8_CHARCLASS_ALNUM();
1301                 REXEC_FBC_UTF8_SCAN(
1302                     if (tmp == !(OP(c) == BOUND ?
1303                                  (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1304                                  isALNUM_LC_utf8((U8*)s)))
1305                     {
1306                         tmp = !tmp;
1307                         REXEC_FBC_TRYIT;
1308                 }
1309                 );
1310             }
1311             else {
1312                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1313                 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1314                 REXEC_FBC_SCAN(
1315                     if (tmp ==
1316                         !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1317                         tmp = !tmp;
1318                         REXEC_FBC_TRYIT;
1319                 }
1320                 );
1321             }
1322             if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, &s)))
1323                 goto got_it;
1324             break;
1325         case NBOUNDL:
1326             PL_reg_flags |= RF_tainted;
1327             /* FALL THROUGH */
1328         case NBOUND:
1329             if (do_utf8) {
1330                 if (s == PL_bostr)
1331                     tmp = '\n';
1332                 else {
1333                     U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1334                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1335                 }
1336                 tmp = ((OP(c) == NBOUND ?
1337                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1338                 LOAD_UTF8_CHARCLASS_ALNUM();
1339                 REXEC_FBC_UTF8_SCAN(
1340                     if (tmp == !(OP(c) == NBOUND ?
1341                                  (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1342                                  isALNUM_LC_utf8((U8*)s)))
1343                         tmp = !tmp;
1344                     else REXEC_FBC_TRYIT;
1345                 );
1346             }
1347             else {
1348                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1349                 tmp = ((OP(c) == NBOUND ?
1350                         isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1351                 REXEC_FBC_SCAN(
1352                     if (tmp ==
1353                         !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1354                         tmp = !tmp;
1355                     else REXEC_FBC_TRYIT;
1356                 );
1357             }
1358             if ((!prog->minlen && !tmp) && (!reginfo || regtry(reginfo, &s)))
1359                 goto got_it;
1360             break;
1361         case ALNUM:
1362             REXEC_FBC_CSCAN_PRELOAD(
1363                 LOAD_UTF8_CHARCLASS_ALNUM(),
1364                 swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8),
1365                 isALNUM(*s)
1366             );
1367         case ALNUML:
1368             REXEC_FBC_CSCAN_TAINT(
1369                 isALNUM_LC_utf8((U8*)s),
1370                 isALNUM_LC(*s)
1371             );
1372         case NALNUM:
1373             REXEC_FBC_CSCAN_PRELOAD(
1374                 LOAD_UTF8_CHARCLASS_ALNUM(),
1375                 !swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8),
1376                 !isALNUM(*s)
1377             );
1378         case NALNUML:
1379             REXEC_FBC_CSCAN_TAINT(
1380                 !isALNUM_LC_utf8((U8*)s),
1381                 !isALNUM_LC(*s)
1382             );
1383         case SPACE:
1384             REXEC_FBC_CSCAN_PRELOAD(
1385                 LOAD_UTF8_CHARCLASS_SPACE(),
1386                 *s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8),
1387                 isSPACE(*s)
1388             );
1389         case SPACEL:
1390             REXEC_FBC_CSCAN_TAINT(
1391                 *s == ' ' || isSPACE_LC_utf8((U8*)s),
1392                 isSPACE_LC(*s)
1393             );
1394         case NSPACE:
1395             REXEC_FBC_CSCAN_PRELOAD(
1396                 LOAD_UTF8_CHARCLASS_SPACE(),
1397                 !(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)),
1398                 !isSPACE(*s)
1399             );
1400         case NSPACEL:
1401             REXEC_FBC_CSCAN_TAINT(
1402                 !(*s == ' ' || isSPACE_LC_utf8((U8*)s)),
1403                 !isSPACE_LC(*s)
1404             );
1405         case DIGIT:
1406             REXEC_FBC_CSCAN_PRELOAD(
1407                 LOAD_UTF8_CHARCLASS_DIGIT(),
1408                 swash_fetch(PL_utf8_digit,(U8*)s, do_utf8),
1409                 isDIGIT(*s)
1410             );
1411         case DIGITL:
1412             REXEC_FBC_CSCAN_TAINT(
1413                 isDIGIT_LC_utf8((U8*)s),
1414                 isDIGIT_LC(*s)
1415             );
1416         case NDIGIT:
1417             REXEC_FBC_CSCAN_PRELOAD(
1418                 LOAD_UTF8_CHARCLASS_DIGIT(),
1419                 !swash_fetch(PL_utf8_digit,(U8*)s, do_utf8),
1420                 !isDIGIT(*s)
1421             );
1422         case NDIGITL:
1423             REXEC_FBC_CSCAN_TAINT(
1424                 !isDIGIT_LC_utf8((U8*)s),
1425                 !isDIGIT_LC(*s)
1426             );
1427         case AHOCORASICKC:
1428         case AHOCORASICK: 
1429             {
1430                 const enum { trie_plain, trie_utf8, trie_utf8_fold }
1431                     trie_type = do_utf8 ?
1432                           (c->flags == EXACT ? trie_utf8 : trie_utf8_fold)
1433                         : trie_plain;
1434                 /* what trie are we using right now */
1435                 reg_ac_data *aho
1436                     = (reg_ac_data*)progi->data->data[ ARG( c ) ];
1437                 reg_trie_data *trie
1438                     = (reg_trie_data*)progi->data->data[ aho->trie ];
1439                 HV *widecharmap = (HV*) progi->data->data[ aho->trie + 1 ];
1440
1441                 const char *last_start = strend - trie->minlen;
1442 #ifdef DEBUGGING
1443                 const char *real_start = s;
1444 #endif
1445                 STRLEN maxlen = trie->maxlen;
1446                 SV *sv_points;
1447                 U8 **points; /* map of where we were in the input string
1448                                 when reading a given char. For ASCII this
1449                                 is unnecessary overhead as the relationship
1450                                 is always 1:1, but for unicode, especially
1451                                 case folded unicode this is not true. */
1452                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1453                 U8 *bitmap=NULL;
1454
1455
1456                 GET_RE_DEBUG_FLAGS_DECL;
1457
1458                 /* We can't just allocate points here. We need to wrap it in
1459                  * an SV so it gets freed properly if there is a croak while
1460                  * running the match */
1461                 ENTER;
1462                 SAVETMPS;
1463                 sv_points=newSV(maxlen * sizeof(U8 *));
1464                 SvCUR_set(sv_points,
1465                     maxlen * sizeof(U8 *));
1466                 SvPOK_on(sv_points);
1467                 sv_2mortal(sv_points);
1468                 points=(U8**)SvPV_nolen(sv_points );
1469                 if ( trie_type != trie_utf8_fold 
1470                      && (trie->bitmap || OP(c)==AHOCORASICKC) ) 
1471                 {
1472                     if (trie->bitmap) 
1473                         bitmap=(U8*)trie->bitmap;
1474                     else
1475                         bitmap=(U8*)ANYOF_BITMAP(c);
1476                 }
1477                 /* this is the Aho-Corasick algorithm modified a touch
1478                    to include special handling for long "unknown char" 
1479                    sequences. The basic idea being that we use AC as long
1480                    as we are dealing with a possible matching char, when
1481                    we encounter an unknown char (and we have not encountered
1482                    an accepting state) we scan forward until we find a legal 
1483                    starting char. 
1484                    AC matching is basically that of trie matching, except
1485                    that when we encounter a failing transition, we fall back
1486                    to the current states "fail state", and try the current char 
1487                    again, a process we repeat until we reach the root state, 
1488                    state 1, or a legal transition. If we fail on the root state 
1489                    then we can either terminate if we have reached an accepting 
1490                    state previously, or restart the entire process from the beginning 
1491                    if we have not.
1492
1493                  */
1494                 while (s <= last_start) {
1495                     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1496                     U8 *uc = (U8*)s;
1497                     U16 charid = 0;
1498                     U32 base = 1;
1499                     U32 state = 1;
1500                     UV uvc = 0;
1501                     STRLEN len = 0;
1502                     STRLEN foldlen = 0;
1503                     U8 *uscan = (U8*)NULL;
1504                     U8 *leftmost = NULL;
1505 #ifdef DEBUGGING                    
1506                     U32 accepted_word= 0;
1507 #endif
1508                     U32 pointpos = 0;
1509
1510                     while ( state && uc <= (U8*)strend ) {
1511                         int failed=0;
1512                         U32 word = aho->states[ state ].wordnum;
1513
1514                         if( state==1 ) {
1515                             if ( bitmap ) {
1516                                 DEBUG_TRIE_EXECUTE_r(
1517                                     if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1518                                         dump_exec_pos( (char *)uc, c, strend, real_start, 
1519                                             (char *)uc, do_utf8 );
1520                                         PerlIO_printf( Perl_debug_log,
1521                                             " Scanning for legal start char...\n");
1522                                     }
1523                                 );            
1524                                 while ( uc <= (U8*)last_start  && !BITMAP_TEST(bitmap,*uc) ) {
1525                                     uc++;
1526                                 }
1527                                 s= (char *)uc;
1528                             }
1529                             if (uc >(U8*)last_start) break;
1530                         }
1531                                             
1532                         if ( word ) {
1533                             U8 *lpos= points[ (pointpos - trie->wordlen[word-1] ) % maxlen ];
1534                             if (!leftmost || lpos < leftmost) {
1535                                 DEBUG_r(accepted_word=word);
1536                                 leftmost= lpos;
1537                             }
1538                             if (base==0) break;
1539                             
1540                         }
1541                         points[pointpos++ % maxlen]= uc;
1542                         REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
1543                                              uscan, len, uvc, charid, foldlen,
1544                                              foldbuf, uniflags);
1545                         DEBUG_TRIE_EXECUTE_r({
1546                             dump_exec_pos( (char *)uc, c, strend, real_start, 
1547                                 s,   do_utf8 );
1548                             PerlIO_printf(Perl_debug_log,
1549                                 " Charid:%3u CP:%4"UVxf" ",
1550                                  charid, uvc);
1551                         });
1552
1553                         do {
1554 #ifdef DEBUGGING
1555                             word = aho->states[ state ].wordnum;
1556 #endif
1557                             base = aho->states[ state ].trans.base;
1558
1559                             DEBUG_TRIE_EXECUTE_r({
1560                                 if (failed) 
1561                                     dump_exec_pos( (char *)uc, c, strend, real_start, 
1562                                         s,   do_utf8 );
1563                                 PerlIO_printf( Perl_debug_log,
1564                                     "%sState: %4"UVxf", word=%"UVxf,
1565                                     failed ? " Fail transition to " : "",
1566                                     (UV)state, (UV)word);
1567                             });
1568                             if ( base ) {
1569                                 U32 tmp;
1570                                 if (charid &&
1571                                      (base + charid > trie->uniquecharcount )
1572                                      && (base + charid - 1 - trie->uniquecharcount
1573                                             < trie->lasttrans)
1574                                      && trie->trans[base + charid - 1 -
1575                                             trie->uniquecharcount].check == state
1576                                      && (tmp=trie->trans[base + charid - 1 -
1577                                         trie->uniquecharcount ].next))
1578                                 {
1579                                     DEBUG_TRIE_EXECUTE_r(
1580                                         PerlIO_printf( Perl_debug_log," - legal\n"));
1581                                     state = tmp;
1582                                     break;
1583                                 }
1584                                 else {
1585                                     DEBUG_TRIE_EXECUTE_r(
1586                                         PerlIO_printf( Perl_debug_log," - fail\n"));
1587                                     failed = 1;
1588                                     state = aho->fail[state];
1589                                 }
1590                             }
1591                             else {
1592                                 /* we must be accepting here */
1593                                 DEBUG_TRIE_EXECUTE_r(
1594                                         PerlIO_printf( Perl_debug_log," - accepting\n"));
1595                                 failed = 1;
1596                                 break;
1597                             }
1598                         } while(state);
1599                         uc += len;
1600                         if (failed) {
1601                             if (leftmost)
1602                                 break;
1603                             if (!state) state = 1;
1604                         }
1605                     }
1606                     if ( aho->states[ state ].wordnum ) {
1607                         U8 *lpos = points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1]) % maxlen ];
1608                         if (!leftmost || lpos < leftmost) {
1609                             DEBUG_r(accepted_word=aho->states[ state ].wordnum);
1610                             leftmost = lpos;
1611                         }
1612                     }
1613                     if (leftmost) {
1614                         s = (char*)leftmost;
1615                         DEBUG_TRIE_EXECUTE_r({
1616                             PerlIO_printf( 
1617                                 Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
1618                                 (UV)accepted_word, (IV)(s - real_start)
1619                             );
1620                         });
1621                         if (!reginfo || regtry(reginfo, &s)) {
1622                             FREETMPS;
1623                             LEAVE;
1624                             goto got_it;
1625                         }
1626                         s = HOPc(s,1);
1627                         DEBUG_TRIE_EXECUTE_r({
1628                             PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
1629                         });
1630                     } else {
1631                         DEBUG_TRIE_EXECUTE_r(
1632                             PerlIO_printf( Perl_debug_log,"No match.\n"));
1633                         break;
1634                     }
1635                 }
1636                 FREETMPS;
1637                 LEAVE;
1638             }
1639             break;
1640         default:
1641             Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1642             break;
1643         }
1644         return 0;
1645       got_it:
1646         return s;
1647 }
1648
1649 /*
1650  - regexec_flags - match a regexp against a string
1651  */
1652 I32
1653 Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *strend,
1654               char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1655 /* strend: pointer to null at end of string */
1656 /* strbeg: real beginning of string */
1657 /* minend: end of match must be >=minend after stringarg. */
1658 /* data: May be used for some additional optimizations. 
1659          Currently its only used, with a U32 cast, for transmitting 
1660          the ganch offset when doing a /g match. This will change */
1661 /* nosave: For optimizations. */
1662 {
1663     dVAR;
1664     /*register*/ char *s;
1665     register regnode *c;
1666     /*register*/ char *startpos = stringarg;
1667     I32 minlen;         /* must match at least this many chars */
1668     I32 dontbother = 0; /* how many characters not to try at end */
1669     I32 end_shift = 0;                  /* Same for the end. */         /* CC */
1670     I32 scream_pos = -1;                /* Internal iterator of scream. */
1671     char *scream_olds = NULL;
1672     SV* const oreplsv = GvSV(PL_replgv);
1673     const bool do_utf8 = (bool)DO_UTF8(sv);
1674     I32 multiline;
1675     RXi_GET_DECL(prog,progi);
1676     regmatch_info reginfo;  /* create some info to pass to regtry etc */
1677
1678     GET_RE_DEBUG_FLAGS_DECL;
1679
1680     PERL_UNUSED_ARG(data);
1681
1682     /* Be paranoid... */
1683     if (prog == NULL || startpos == NULL) {
1684         Perl_croak(aTHX_ "NULL regexp parameter");
1685         return 0;
1686     }
1687
1688     multiline = prog->extflags & RXf_PMf_MULTILINE;
1689     reginfo.prog = prog;
1690
1691     RX_MATCH_UTF8_set(prog, do_utf8);
1692     DEBUG_EXECUTE_r( 
1693         debug_start_match(prog, do_utf8, startpos, strend, 
1694         "Matching");
1695     );
1696
1697     minlen = prog->minlen;
1698     
1699     if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
1700         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1701                               "String too short [regexec_flags]...\n"));
1702         goto phooey;
1703     }
1704
1705     
1706     /* Check validity of program. */
1707     if (UCHARAT(progi->program) != REG_MAGIC) {
1708         Perl_croak(aTHX_ "corrupted regexp program");
1709     }
1710
1711     PL_reg_flags = 0;
1712     PL_reg_eval_set = 0;
1713     PL_reg_maxiter = 0;
1714
1715     if (prog->extflags & RXf_UTF8)
1716         PL_reg_flags |= RF_utf8;
1717
1718     /* Mark beginning of line for ^ and lookbehind. */
1719     reginfo.bol = startpos; /* XXX not used ??? */
1720     PL_bostr  = strbeg;
1721     reginfo.sv = sv;
1722
1723     /* Mark end of line for $ (and such) */
1724     PL_regeol = strend;
1725
1726     /* see how far we have to get to not match where we matched before */
1727     reginfo.till = startpos+minend;
1728
1729     /* If there is a "must appear" string, look for it. */
1730     s = startpos;
1731
1732     if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
1733         MAGIC *mg;
1734
1735         if (flags & REXEC_IGNOREPOS)    /* Means: check only at start */
1736             reginfo.ganch = startpos + prog->gofs;
1737         else if (sv && SvTYPE(sv) >= SVt_PVMG
1738                   && SvMAGIC(sv)
1739                   && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1740                   && mg->mg_len >= 0) {
1741             reginfo.ganch = strbeg + mg->mg_len;        /* Defined pos() */
1742             if (prog->extflags & RXf_ANCH_GPOS) {
1743                 if (s > reginfo.ganch)
1744                     goto phooey;
1745                 s = reginfo.ganch - prog->gofs;
1746             }
1747         }
1748         else if (data) {
1749             reginfo.ganch = strbeg + PTR2UV(data);
1750         } else                          /* pos() not defined */
1751             reginfo.ganch = strbeg;
1752     }
1753     if (PL_curpm && (PM_GETRE(PL_curpm) == prog)) {
1754         I32 *t;
1755         if (!progi->swap) {
1756         /* We have to be careful. If the previous successful match
1757            was from this regex we don't want a subsequent paritally
1758            successful match to clobber the old results. 
1759            So when we detect this possibility we add a swap buffer
1760            to the re, and switch the buffer each match. If we fail
1761            we switch it back, otherwise we leave it swapped.
1762         */
1763             Newxz(progi->swap, 1, regexp_paren_ofs);
1764             /* no need to copy these */
1765             Newxz(progi->swap->startp, prog->nparens + 1, I32);
1766             Newxz(progi->swap->endp, prog->nparens + 1, I32);
1767         }
1768         t = progi->swap->startp;
1769         progi->swap->startp = prog->startp;
1770         prog->startp = t;
1771         t = progi->swap->endp;
1772         progi->swap->endp = prog->endp;
1773         prog->endp = t;
1774     }
1775     if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
1776         re_scream_pos_data d;
1777
1778         d.scream_olds = &scream_olds;
1779         d.scream_pos = &scream_pos;
1780         s = re_intuit_start(prog, sv, s, strend, flags, &d);
1781         if (!s) {
1782             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1783             goto phooey;        /* not present */
1784         }
1785     }
1786
1787
1788
1789     /* Simplest case:  anchored match need be tried only once. */
1790     /*  [unless only anchor is BOL and multiline is set] */
1791     if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {
1792         if (s == startpos && regtry(&reginfo, &startpos))
1793             goto got_it;
1794         else if (multiline || (prog->intflags & PREGf_IMPLICIT)
1795                  || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
1796         {
1797             char *end;
1798
1799             if (minlen)
1800                 dontbother = minlen - 1;
1801             end = HOP3c(strend, -dontbother, strbeg) - 1;
1802             /* for multiline we only have to try after newlines */
1803             if (prog->check_substr || prog->check_utf8) {
1804                 if (s == startpos)
1805                     goto after_try;
1806                 while (1) {
1807                     if (regtry(&reginfo, &s))
1808                         goto got_it;
1809                   after_try:
1810                     if (s >= end)
1811                         goto phooey;
1812                     if (prog->extflags & RXf_USE_INTUIT) {
1813                         s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
1814                         if (!s)
1815                             goto phooey;
1816                     }
1817                     else
1818                         s++;
1819                 }               
1820             } else {
1821                 if (s > startpos)
1822                     s--;
1823                 while (s < end) {
1824                     if (*s++ == '\n') { /* don't need PL_utf8skip here */
1825                         if (regtry(&reginfo, &s))
1826                             goto got_it;
1827                     }
1828                 }               
1829             }
1830         }
1831         goto phooey;
1832     } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK)) 
1833     {
1834         /* the warning about reginfo.ganch being used without intialization
1835            is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN 
1836            and we only enter this block when the same bit is set. */
1837         char *tmp_s = reginfo.ganch - prog->gofs;
1838         if (regtry(&reginfo, &tmp_s))
1839             goto got_it;
1840         goto phooey;
1841     }
1842
1843     /* Messy cases:  unanchored match. */
1844     if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
1845         /* we have /x+whatever/ */
1846         /* it must be a one character string (XXXX Except UTF?) */
1847         char ch;
1848 #ifdef DEBUGGING
1849         int did_match = 0;
1850 #endif
1851         if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1852             do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1853         ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
1854
1855         if (do_utf8) {
1856             REXEC_FBC_SCAN(
1857                 if (*s == ch) {
1858                     DEBUG_EXECUTE_r( did_match = 1 );
1859                     if (regtry(&reginfo, &s)) goto got_it;
1860                     s += UTF8SKIP(s);
1861                     while (s < strend && *s == ch)
1862                         s += UTF8SKIP(s);
1863                 }
1864             );
1865         }
1866         else {
1867             REXEC_FBC_SCAN(
1868                 if (*s == ch) {
1869                     DEBUG_EXECUTE_r( did_match = 1 );
1870                     if (regtry(&reginfo, &s)) goto got_it;
1871                     s++;
1872                     while (s < strend && *s == ch)
1873                         s++;
1874                 }
1875             );
1876         }
1877         DEBUG_EXECUTE_r(if (!did_match)
1878                 PerlIO_printf(Perl_debug_log,
1879                                   "Did not find anchored character...\n")
1880                );
1881     }
1882     else if (prog->anchored_substr != NULL
1883               || prog->anchored_utf8 != NULL
1884               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
1885                   && prog->float_max_offset < strend - s)) {
1886         SV *must;
1887         I32 back_max;
1888         I32 back_min;
1889         char *last;
1890         char *last1;            /* Last position checked before */
1891 #ifdef DEBUGGING
1892         int did_match = 0;
1893 #endif
1894         if (prog->anchored_substr || prog->anchored_utf8) {
1895             if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1896                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1897             must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
1898             back_max = back_min = prog->anchored_offset;
1899         } else {
1900             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1901                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1902             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
1903             back_max = prog->float_max_offset;
1904             back_min = prog->float_min_offset;
1905         }
1906         
1907             
1908         if (must == &PL_sv_undef)
1909             /* could not downgrade utf8 check substring, so must fail */
1910             goto phooey;
1911
1912         if (back_min<0) {
1913             last = strend;
1914         } else {
1915             last = HOP3c(strend,        /* Cannot start after this */
1916                   -(I32)(CHR_SVLEN(must)
1917                          - (SvTAIL(must) != 0) + back_min), strbeg);
1918         }
1919         if (s > PL_bostr)
1920             last1 = HOPc(s, -1);
1921         else
1922             last1 = s - 1;      /* bogus */
1923
1924         /* XXXX check_substr already used to find "s", can optimize if
1925            check_substr==must. */
1926         scream_pos = -1;
1927         dontbother = end_shift;
1928         strend = HOPc(strend, -dontbother);
1929         while ( (s <= last) &&
1930                 ((flags & REXEC_SCREAM)
1931                  ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
1932                                     end_shift, &scream_pos, 0))
1933                  : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
1934                                   (unsigned char*)strend, must,
1935                                   multiline ? FBMrf_MULTILINE : 0))) ) {
1936             /* we may be pointing at the wrong string */
1937             if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
1938                 s = strbeg + (s - SvPVX_const(sv));
1939             DEBUG_EXECUTE_r( did_match = 1 );
1940             if (HOPc(s, -back_max) > last1) {
1941                 last1 = HOPc(s, -back_min);
1942                 s = HOPc(s, -back_max);
1943             }
1944             else {
1945                 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
1946
1947                 last1 = HOPc(s, -back_min);
1948                 s = t;
1949             }
1950             if (do_utf8) {
1951                 while (s <= last1) {
1952                     if (regtry(&reginfo, &s))
1953                         goto got_it;
1954                     s += UTF8SKIP(s);
1955                 }
1956             }
1957             else {
1958                 while (s <= last1) {
1959                     if (regtry(&reginfo, &s))
1960                         goto got_it;
1961                     s++;
1962                 }
1963             }
1964         }
1965         DEBUG_EXECUTE_r(if (!did_match) {
1966             RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0), 
1967                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
1968             PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
1969                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
1970                                ? "anchored" : "floating"),
1971                 quoted, RE_SV_TAIL(must));
1972         });                 
1973         goto phooey;
1974     }
1975     else if ( (c = progi->regstclass) ) {
1976         if (minlen) {
1977             const OPCODE op = OP(progi->regstclass);
1978             /* don't bother with what can't match */
1979             if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
1980                 strend = HOPc(strend, -(minlen - 1));
1981         }
1982         DEBUG_EXECUTE_r({
1983             SV * const prop = sv_newmortal();
1984             regprop(prog, prop, c);
1985             {
1986                 RE_PV_QUOTED_DECL(quoted,UTF,PERL_DEBUG_PAD_ZERO(1),
1987                     s,strend-s,60);
1988                 PerlIO_printf(Perl_debug_log,
1989                     "Matching stclass %.*s against %s (%d chars)\n",
1990                     (int)SvCUR(prop), SvPVX_const(prop),
1991                      quoted, (int)(strend - s));
1992             }
1993         });
1994         if (find_byclass(prog, c, s, strend, &reginfo))
1995             goto got_it;
1996         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
1997     }
1998     else {
1999         dontbother = 0;
2000         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2001             /* Trim the end. */
2002             char *last;
2003             SV* float_real;
2004
2005             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2006                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2007             float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
2008
2009             if (flags & REXEC_SCREAM) {
2010                 last = screaminstr(sv, float_real, s - strbeg,
2011                                    end_shift, &scream_pos, 1); /* last one */
2012                 if (!last)
2013                     last = scream_olds; /* Only one occurrence. */
2014                 /* we may be pointing at the wrong string */
2015                 else if (RX_MATCH_COPIED(prog))
2016                     s = strbeg + (s - SvPVX_const(sv));
2017             }
2018             else {
2019                 STRLEN len;
2020                 const char * const little = SvPV_const(float_real, len);
2021
2022                 if (SvTAIL(float_real)) {
2023                     if (memEQ(strend - len + 1, little, len - 1))
2024                         last = strend - len + 1;
2025                     else if (!multiline)
2026                         last = memEQ(strend - len, little, len)
2027                             ? strend - len : NULL;
2028                     else
2029                         goto find_last;
2030                 } else {
2031                   find_last:
2032                     if (len)
2033                         last = rninstr(s, strend, little, little + len);
2034                     else
2035                         last = strend;  /* matching "$" */
2036                 }
2037             }
2038             if (last == NULL) {
2039                 DEBUG_EXECUTE_r(
2040                     PerlIO_printf(Perl_debug_log,
2041                         "%sCan't trim the tail, match fails (should not happen)%s\n",
2042                         PL_colors[4], PL_colors[5]));
2043                 goto phooey; /* Should not happen! */
2044             }
2045             dontbother = strend - last + prog->float_min_offset;
2046         }
2047         if (minlen && (dontbother < minlen))
2048             dontbother = minlen - 1;
2049         strend -= dontbother;              /* this one's always in bytes! */
2050         /* We don't know much -- general case. */
2051         if (do_utf8) {
2052             for (;;) {
2053                 if (regtry(&reginfo, &s))
2054                     goto got_it;
2055                 if (s >= strend)
2056                     break;
2057                 s += UTF8SKIP(s);
2058             };
2059         }
2060         else {
2061             do {
2062                 if (regtry(&reginfo, &s))
2063                     goto got_it;
2064             } while (s++ < strend);
2065         }
2066     }
2067
2068     /* Failure. */
2069     goto phooey;
2070
2071 got_it:
2072     RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
2073
2074     if (PL_reg_eval_set) {
2075         /* Preserve the current value of $^R */
2076         if (oreplsv != GvSV(PL_replgv))
2077             sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
2078                                                   restored, the value remains
2079                                                   the same. */
2080         restore_pos(aTHX_ prog);
2081     }
2082     if (prog->paren_names) 
2083         (void)hv_iterinit(prog->paren_names);
2084
2085     /* make sure $`, $&, $', and $digit will work later */
2086     if ( !(flags & REXEC_NOT_FIRST) ) {
2087         RX_MATCH_COPY_FREE(prog);
2088         if (flags & REXEC_COPY_STR) {
2089             const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2090 #ifdef PERL_OLD_COPY_ON_WRITE
2091             if ((SvIsCOW(sv)
2092                  || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2093                 if (DEBUG_C_TEST) {
2094                     PerlIO_printf(Perl_debug_log,
2095                                   "Copy on write: regexp capture, type %d\n",
2096                                   (int) SvTYPE(sv));
2097                 }
2098                 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2099                 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2100                 assert (SvPOKp(prog->saved_copy));
2101             } else
2102 #endif
2103             {
2104                 RX_MATCH_COPIED_on(prog);
2105                 s = savepvn(strbeg, i);
2106                 prog->subbeg = s;
2107             }
2108             prog->sublen = i;
2109         }
2110         else {
2111             prog->subbeg = strbeg;
2112             prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
2113         }
2114     }
2115
2116     return 1;
2117
2118 phooey:
2119     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2120                           PL_colors[4], PL_colors[5]));
2121     if (PL_reg_eval_set)
2122         restore_pos(aTHX_ prog);
2123     if (progi->swap) {
2124         /* we failed :-( roll it back */
2125         I32 *t;
2126         t = progi->swap->startp;
2127         progi->swap->startp = prog->startp;
2128         prog->startp = t;
2129         t = progi->swap->endp;
2130         progi->swap->endp = prog->endp;
2131         prog->endp = t;
2132     }
2133     return 0;
2134 }
2135
2136
2137 /*
2138  - regtry - try match at specific point
2139  */
2140 STATIC I32                      /* 0 failure, 1 success */
2141 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
2142 {
2143     dVAR;
2144     register I32 *sp;
2145     register I32 *ep;
2146     CHECKPOINT lastcp;
2147     regexp *prog = reginfo->prog;
2148     RXi_GET_DECL(prog,progi);
2149     GET_RE_DEBUG_FLAGS_DECL;
2150     reginfo->cutpoint=NULL;
2151
2152     if ((prog->extflags & RXf_EVAL_SEEN) && !PL_reg_eval_set) {
2153         MAGIC *mg;
2154
2155         PL_reg_eval_set = RS_init;
2156         DEBUG_EXECUTE_r(DEBUG_s(
2157             PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
2158                           (IV)(PL_stack_sp - PL_stack_base));
2159             ));
2160         SAVESTACK_CXPOS();
2161         cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2162         /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
2163         SAVETMPS;
2164         /* Apparently this is not needed, judging by wantarray. */
2165         /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2166            cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2167
2168         if (reginfo->sv) {
2169             /* Make $_ available to executed code. */
2170             if (reginfo->sv != DEFSV) {
2171                 SAVE_DEFSV;
2172                 DEFSV = reginfo->sv;
2173             }
2174         
2175             if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2176                   && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2177                 /* prepare for quick setting of pos */
2178 #ifdef PERL_OLD_COPY_ON_WRITE
2179                 if (SvIsCOW(reginfo->sv))
2180                     sv_force_normal_flags(reginfo->sv, 0);
2181 #endif
2182                 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2183                                  &PL_vtbl_mglob, NULL, 0);
2184                 mg->mg_len = -1;
2185             }
2186             PL_reg_magic    = mg;
2187             PL_reg_oldpos   = mg->mg_len;
2188             SAVEDESTRUCTOR_X(restore_pos, prog);
2189         }
2190         if (!PL_reg_curpm) {
2191             Newxz(PL_reg_curpm, 1, PMOP);
2192 #ifdef USE_ITHREADS
2193             {
2194                 SV* const repointer = newSViv(0);
2195                 /* so we know which PL_regex_padav element is PL_reg_curpm */
2196                 SvFLAGS(repointer) |= SVf_BREAK;
2197                 av_push(PL_regex_padav,repointer);
2198                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2199                 PL_regex_pad = AvARRAY(PL_regex_padav);
2200             }
2201 #endif      
2202         }
2203         PM_SETRE(PL_reg_curpm, prog);
2204         PL_reg_oldcurpm = PL_curpm;
2205         PL_curpm = PL_reg_curpm;
2206         if (RX_MATCH_COPIED(prog)) {
2207             /*  Here is a serious problem: we cannot rewrite subbeg,
2208                 since it may be needed if this match fails.  Thus
2209                 $` inside (?{}) could fail... */
2210             PL_reg_oldsaved = prog->subbeg;
2211             PL_reg_oldsavedlen = prog->sublen;
2212 #ifdef PERL_OLD_COPY_ON_WRITE
2213             PL_nrs = prog->saved_copy;
2214 #endif
2215             RX_MATCH_COPIED_off(prog);
2216         }
2217         else
2218             PL_reg_oldsaved = NULL;
2219         prog->subbeg = PL_bostr;
2220         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2221     }
2222     DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
2223     prog->startp[0] = *startpos - PL_bostr;
2224     PL_reginput = *startpos;
2225     PL_reglastparen = &prog->lastparen;
2226     PL_reglastcloseparen = &prog->lastcloseparen;
2227     prog->lastparen = 0;
2228     prog->lastcloseparen = 0;
2229     PL_regsize = 0;
2230     PL_regstartp = prog->startp;
2231     PL_regendp = prog->endp;
2232     if (PL_reg_start_tmpl <= prog->nparens) {
2233         PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2234         if(PL_reg_start_tmp)
2235             Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2236         else
2237             Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2238     }
2239
2240     /* XXXX What this code is doing here?!!!  There should be no need
2241        to do this again and again, PL_reglastparen should take care of
2242        this!  --ilya*/
2243
2244     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2245      * Actually, the code in regcppop() (which Ilya may be meaning by
2246      * PL_reglastparen), is not needed at all by the test suite
2247      * (op/regexp, op/pat, op/split), but that code is needed, oddly
2248      * enough, for building DynaLoader, or otherwise this
2249      * "Error: '*' not in typemap in DynaLoader.xs, line 164"
2250      * will happen.  Meanwhile, this code *is* needed for the
2251      * above-mentioned test suite tests to succeed.  The common theme
2252      * on those tests seems to be returning null fields from matches.
2253      * --jhi */
2254 #if 1
2255     sp = PL_regstartp;
2256     ep = PL_regendp;
2257     if (prog->nparens) {
2258         register I32 i;
2259         for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2260             *++sp = -1;
2261             *++ep = -1;
2262         }
2263     }
2264 #endif
2265     REGCP_SET(lastcp);
2266     if (regmatch(reginfo, progi->program + 1)) {
2267         PL_regendp[0] = PL_reginput - PL_bostr;
2268         return 1;
2269     }
2270     if (reginfo->cutpoint)
2271         *startpos= reginfo->cutpoint;
2272     REGCP_UNWIND(lastcp);
2273     return 0;
2274 }
2275
2276
2277 #define sayYES goto yes
2278 #define sayNO goto no
2279 #define sayNO_SILENT goto no_silent
2280
2281 /* we dont use STMT_START/END here because it leads to 
2282    "unreachable code" warnings, which are bogus, but distracting. */
2283 #define CACHEsayNO \
2284     if (ST.cache_mask) \
2285        PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
2286     sayNO
2287
2288 /* this is used to determine how far from the left messages like
2289    'failed...' are printed. It should be set such that messages 
2290    are inline with the regop output that created them.
2291 */
2292 #define REPORT_CODE_OFF 32
2293
2294
2295 /* Make sure there is a test for this +1 options in re_tests */
2296 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2297
2298 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2299 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
2300
2301 #define SLAB_FIRST(s) (&(s)->states[0])
2302 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2303
2304 /* grab a new slab and return the first slot in it */
2305
2306 STATIC regmatch_state *
2307 S_push_slab(pTHX)
2308 {
2309 #if PERL_VERSION < 9
2310     dMY_CXT;
2311 #endif
2312     regmatch_slab *s = PL_regmatch_slab->next;
2313     if (!s) {
2314         Newx(s, 1, regmatch_slab);
2315         s->prev = PL_regmatch_slab;
2316         s->next = NULL;
2317         PL_regmatch_slab->next = s;
2318     }
2319     PL_regmatch_slab = s;
2320     return SLAB_FIRST(s);
2321 }
2322
2323
2324 /* push a new state then goto it */
2325
2326 #define PUSH_STATE_GOTO(state, node) \
2327     scan = node; \
2328     st->resume_state = state; \
2329     goto push_state;
2330
2331 /* push a new state with success backtracking, then goto it */
2332
2333 #define PUSH_YES_STATE_GOTO(state, node) \
2334     scan = node; \
2335     st->resume_state = state; \
2336     goto push_yes_state;
2337
2338
2339
2340 /*
2341
2342 regmatch() - main matching routine
2343
2344 This is basically one big switch statement in a loop. We execute an op,
2345 set 'next' to point the next op, and continue. If we come to a point which
2346 we may need to backtrack to on failure such as (A|B|C), we push a
2347 backtrack state onto the backtrack stack. On failure, we pop the top
2348 state, and re-enter the loop at the state indicated. If there are no more
2349 states to pop, we return failure.
2350
2351 Sometimes we also need to backtrack on success; for example /A+/, where
2352 after successfully matching one A, we need to go back and try to
2353 match another one; similarly for lookahead assertions: if the assertion
2354 completes successfully, we backtrack to the state just before the assertion
2355 and then carry on.  In these cases, the pushed state is marked as
2356 'backtrack on success too'. This marking is in fact done by a chain of
2357 pointers, each pointing to the previous 'yes' state. On success, we pop to
2358 the nearest yes state, discarding any intermediate failure-only states.
2359 Sometimes a yes state is pushed just to force some cleanup code to be
2360 called at the end of a successful match or submatch; e.g. (??{$re}) uses
2361 it to free the inner regex.
2362
2363 Note that failure backtracking rewinds the cursor position, while
2364 success backtracking leaves it alone.
2365
2366 A pattern is complete when the END op is executed, while a subpattern
2367 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2368 ops trigger the "pop to last yes state if any, otherwise return true"
2369 behaviour.
2370
2371 A common convention in this function is to use A and B to refer to the two
2372 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2373 the subpattern to be matched possibly multiple times, while B is the entire
2374 rest of the pattern. Variable and state names reflect this convention.
2375
2376 The states in the main switch are the union of ops and failure/success of
2377 substates associated with with that op.  For example, IFMATCH is the op
2378 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2379 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2380 successfully matched A and IFMATCH_A_fail is a state saying that we have
2381 just failed to match A. Resume states always come in pairs. The backtrack
2382 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2383 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2384 on success or failure.
2385
2386 The struct that holds a backtracking state is actually a big union, with
2387 one variant for each major type of op. The variable st points to the
2388 top-most backtrack struct. To make the code clearer, within each
2389 block of code we #define ST to alias the relevant union.
2390
2391 Here's a concrete example of a (vastly oversimplified) IFMATCH
2392 implementation:
2393
2394     switch (state) {
2395     ....
2396
2397 #define ST st->u.ifmatch
2398
2399     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2400         ST.foo = ...; // some state we wish to save
2401         ...
2402         // push a yes backtrack state with a resume value of
2403         // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
2404         // first node of A:
2405         PUSH_YES_STATE_GOTO(IFMATCH_A, A);
2406         // NOTREACHED
2407
2408     case IFMATCH_A: // we have successfully executed A; now continue with B
2409         next = B;
2410         bar = ST.foo; // do something with the preserved value
2411         break;
2412
2413     case IFMATCH_A_fail: // A failed, so the assertion failed
2414         ...;   // do some housekeeping, then ...
2415         sayNO; // propagate the failure
2416
2417 #undef ST
2418
2419     ...
2420     }
2421
2422 For any old-timers reading this who are familiar with the old recursive
2423 approach, the code above is equivalent to:
2424
2425     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2426     {
2427         int foo = ...
2428         ...
2429         if (regmatch(A)) {
2430             next = B;
2431             bar = foo;
2432             break;
2433         }
2434         ...;   // do some housekeeping, then ...
2435         sayNO; // propagate the failure
2436     }
2437
2438 The topmost backtrack state, pointed to by st, is usually free. If you
2439 want to claim it, populate any ST.foo fields in it with values you wish to
2440 save, then do one of
2441
2442         PUSH_STATE_GOTO(resume_state, node);
2443         PUSH_YES_STATE_GOTO(resume_state, node);
2444
2445 which sets that backtrack state's resume value to 'resume_state', pushes a
2446 new free entry to the top of the backtrack stack, then goes to 'node'.
2447 On backtracking, the free slot is popped, and the saved state becomes the
2448 new free state. An ST.foo field in this new top state can be temporarily
2449 accessed to retrieve values, but once the main loop is re-entered, it
2450 becomes available for reuse.
2451
2452 Note that the depth of the backtrack stack constantly increases during the
2453 left-to-right execution of the pattern, rather than going up and down with
2454 the pattern nesting. For example the stack is at its maximum at Z at the
2455 end of the pattern, rather than at X in the following:
2456
2457     /(((X)+)+)+....(Y)+....Z/
2458
2459 The only exceptions to this are lookahead/behind assertions and the cut,
2460 (?>A), which pop all the backtrack states associated with A before
2461 continuing.
2462  
2463 Bascktrack state structs are allocated in slabs of about 4K in size.
2464 PL_regmatch_state and st always point to the currently active state,
2465 and PL_regmatch_slab points to the slab currently containing
2466 PL_regmatch_state.  The first time regmatch() is called, the first slab is
2467 allocated, and is never freed until interpreter destruction. When the slab
2468 is full, a new one is allocated and chained to the end. At exit from
2469 regmatch(), slabs allocated since entry are freed.
2470
2471 */
2472  
2473
2474 #define DEBUG_STATE_pp(pp)                                  \
2475     DEBUG_STATE_r({                                         \
2476         DUMP_EXEC_POS(locinput, scan, do_utf8);             \
2477         PerlIO_printf(Perl_debug_log,                       \
2478             "    %*s"pp" %s%s%s%s%s\n",                     \
2479             depth*2, "",                                    \
2480             reg_name[st->resume_state],                     \
2481             ((st==yes_state||st==mark_state) ? "[" : ""),   \
2482             ((st==yes_state) ? "Y" : ""),                   \
2483             ((st==mark_state) ? "M" : ""),                  \
2484             ((st==yes_state||st==mark_state) ? "]" : "")    \
2485         );                                                  \
2486     });
2487
2488
2489 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2490
2491 #ifdef DEBUGGING
2492
2493 STATIC void
2494 S_debug_start_match(pTHX_ const regexp *prog, const bool do_utf8, 
2495     const char *start, const char *end, const char *blurb)
2496 {
2497     const bool utf8_pat= prog->extflags & RXf_UTF8 ? 1 : 0;
2498     if (!PL_colorset)   
2499             reginitcolors();    
2500     {
2501         RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0), 
2502             prog->precomp, prog->prelen, 60);   
2503         
2504         RE_PV_QUOTED_DECL(s1, do_utf8, PERL_DEBUG_PAD_ZERO(1), 
2505             start, end - start, 60); 
2506         
2507         PerlIO_printf(Perl_debug_log, 
2508             "%s%s REx%s %s against %s\n", 
2509                        PL_colors[4], blurb, PL_colors[5], s0, s1); 
2510         
2511         if (do_utf8||utf8_pat) 
2512             PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2513                 utf8_pat ? "pattern" : "",
2514                 utf8_pat && do_utf8 ? " and " : "",
2515                 do_utf8 ? "string" : ""
2516             ); 
2517     }
2518 }
2519
2520 STATIC void
2521 S_dump_exec_pos(pTHX_ const char *locinput, 
2522                       const regnode *scan, 
2523                       const char *loc_regeol, 
2524                       const char *loc_bostr, 
2525                       const char *loc_reg_starttry,
2526                       const bool do_utf8)
2527 {
2528     const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
2529     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2530     int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
2531     /* The part of the string before starttry has one color
2532        (pref0_len chars), between starttry and current
2533        position another one (pref_len - pref0_len chars),
2534        after the current position the third one.
2535        We assume that pref0_len <= pref_len, otherwise we
2536        decrease pref0_len.  */
2537     int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2538         ? (5 + taill) - l : locinput - loc_bostr;
2539     int pref0_len;
2540
2541     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2542         pref_len++;
2543     pref0_len = pref_len  - (locinput - loc_reg_starttry);
2544     if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2545         l = ( loc_regeol - locinput > (5 + taill) - pref_len
2546               ? (5 + taill) - pref_len : loc_regeol - locinput);
2547     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2548         l--;
2549     if (pref0_len < 0)
2550         pref0_len = 0;
2551     if (pref0_len > pref_len)
2552         pref0_len = pref_len;
2553     {
2554         const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
2555
2556         RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
2557             (locinput - pref_len),pref0_len, 60, 4, 5);
2558         
2559         RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
2560                     (locinput - pref_len + pref0_len),
2561                     pref_len - pref0_len, 60, 2, 3);
2562         
2563         RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
2564                     locinput, loc_regeol - locinput, 10, 0, 1);
2565
2566         const STRLEN tlen=len0+len1+len2;
2567         PerlIO_printf(Perl_debug_log,
2568                     "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
2569                     (IV)(locinput - loc_bostr),
2570                     len0, s0,
2571                     len1, s1,
2572                     (docolor ? "" : "> <"),
2573                     len2, s2,
2574                     (int)(tlen > 19 ? 0 :  19 - tlen),
2575                     "");
2576     }
2577 }
2578
2579 #endif
2580
2581 /* reg_check_named_buff_matched()
2582  * Checks to see if a named buffer has matched. The data array of 
2583  * buffer numbers corresponding to the buffer is expected to reside
2584  * in the regexp->data->data array in the slot stored in the ARG() of
2585  * node involved. Note that this routine doesn't actually care about the
2586  * name, that information is not preserved from compilation to execution.
2587  * Returns the index of the leftmost defined buffer with the given name
2588  * or 0 if non of the buffers matched.
2589  */
2590 STATIC I32
2591 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan) {
2592     I32 n;
2593     RXi_GET_DECL(rex,rexi);
2594     SV *sv_dat=(SV*)rexi->data->data[ ARG( scan ) ];
2595     I32 *nums=(I32*)SvPVX(sv_dat);
2596     for ( n=0; n<SvIVX(sv_dat); n++ ) {
2597         if ((I32)*PL_reglastparen >= nums[n] &&
2598             PL_regendp[nums[n]] != -1)
2599         {
2600             return nums[n];
2601         }
2602     }
2603     return 0;
2604 }
2605
2606 STATIC I32                      /* 0 failure, 1 success */
2607 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
2608 {
2609 #if PERL_VERSION < 9
2610     dMY_CXT;
2611 #endif
2612     dVAR;
2613     register const bool do_utf8 = PL_reg_match_utf8;
2614     const U32 uniflags = UTF8_ALLOW_DEFAULT;
2615
2616     regexp *rex = reginfo->prog;
2617     RXi_GET_DECL(rex,rexi);
2618     
2619     regmatch_slab  *orig_slab;
2620     regmatch_state *orig_state;
2621
2622     /* the current state. This is a cached copy of PL_regmatch_state */
2623     register regmatch_state *st;
2624
2625     /* cache heavy used fields of st in registers */
2626     register regnode *scan;
2627     register regnode *next;
2628     register U32 n = 0; /* general value; init to avoid compiler warning */
2629     register I32 ln = 0; /* len or last;  init to avoid compiler warning */
2630     register char *locinput = PL_reginput;
2631     register I32 nextchr;   /* is always set to UCHARAT(locinput) */
2632
2633     bool result = 0;        /* return value of S_regmatch */
2634     int depth = 0;          /* depth of backtrack stack */
2635     int nochange_depth = 0; /* depth of GOSUB recursion with nochange*/
2636     regmatch_state *yes_state = NULL; /* state to pop to on success of
2637                                                             subpattern */
2638     /* mark_state piggy backs on the yes_state logic so that when we unwind 
2639        the stack on success we can update the mark_state as we go */
2640     regmatch_state *mark_state = NULL; /* last mark state we have seen */
2641     
2642     regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
2643     struct regmatch_state  *cur_curlyx = NULL; /* most recent curlyx */
2644     U32 state_num;
2645     bool no_final = 0;      /* prevent failure from backtracking? */
2646     bool do_cutgroup = 0;   /* no_final only until next branch/trie entry */
2647     char *startpoint = PL_reginput;
2648     SV *popmark = NULL;     /* are we looking for a mark? */
2649     SV *sv_commit = NULL;   /* last mark name seen in failure */
2650     SV *sv_yes_mark = NULL; /* last mark name we have seen 
2651                                during a successfull match */
2652     U32 lastopen = 0;       /* last open we saw */
2653     bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;   
2654                
2655     
2656     /* these three flags are set by various ops to signal information to
2657      * the very next op. They have a useful lifetime of exactly one loop
2658      * iteration, and are not preserved or restored by state pushes/pops
2659      */
2660     bool sw = 0;            /* the condition value in (?(cond)a|b) */
2661     bool minmod = 0;        /* the next "{n,m}" is a "{n,m}?" */
2662     int logical = 0;        /* the following EVAL is:
2663                                 0: (?{...})
2664                                 1: (?(?{...})X|Y)
2665                                 2: (??{...})
2666                                or the following IFMATCH/UNLESSM is:
2667                                 false: plain (?=foo)
2668                                 true:  used as a condition: (?(?=foo))
2669                             */
2670
2671 #ifdef DEBUGGING
2672     GET_RE_DEBUG_FLAGS_DECL;
2673 #endif
2674
2675     DEBUG_OPTIMISE_r( {    
2676             PerlIO_printf(Perl_debug_log,"regmatch start\n");
2677     });
2678     /* on first ever call to regmatch, allocate first slab */
2679     if (!PL_regmatch_slab) {
2680         Newx(PL_regmatch_slab, 1, regmatch_slab);
2681         PL_regmatch_slab->prev = NULL;
2682         PL_regmatch_slab->next = NULL;
2683         PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2684     }
2685
2686     /* remember current high-water mark for exit */
2687     /* XXX this should be done with SAVE* instead */
2688     orig_slab  = PL_regmatch_slab;
2689     orig_state = PL_regmatch_state;
2690
2691     /* grab next free state slot */
2692     st = ++PL_regmatch_state;
2693     if (st >  SLAB_LAST(PL_regmatch_slab))
2694         st = PL_regmatch_state = S_push_slab(aTHX);
2695
2696     /* Note that nextchr is a byte even in UTF */
2697     nextchr = UCHARAT(locinput);
2698     scan = prog;
2699     while (scan != NULL) {
2700
2701         DEBUG_EXECUTE_r( {
2702             SV * const prop = sv_newmortal();
2703             regnode *rnext=regnext(scan);
2704             DUMP_EXEC_POS( locinput, scan, do_utf8 );
2705             regprop(rex, prop, scan);
2706             
2707             PerlIO_printf(Perl_debug_log,
2708                     "%3"IVdf":%*s%s(%"IVdf")\n",
2709                     (IV)(scan - rexi->program), depth*2, "",
2710                     SvPVX_const(prop),
2711                     (PL_regkind[OP(scan)] == END || !rnext) ? 
2712                         0 : (IV)(rnext - rexi->program));
2713         });
2714
2715         next = scan + NEXT_OFF(scan);
2716         if (next == scan)
2717             next = NULL;
2718         state_num = OP(scan);
2719
2720       reenter_switch:
2721         switch (state_num) {
2722         case BOL:
2723             if (locinput == PL_bostr)
2724             {
2725                 /* reginfo->till = reginfo->bol; */
2726                 break;
2727             }
2728             sayNO;
2729         case MBOL:
2730             if (locinput == PL_bostr ||
2731                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2732             {
2733                 break;
2734             }
2735             sayNO;
2736         case SBOL:
2737             if (locinput == PL_bostr)
2738                 break;
2739             sayNO;
2740         case GPOS:
2741             if (locinput == reginfo->ganch)
2742                 break;
2743             sayNO;
2744
2745         case KEEPS:
2746             /* update the startpoint */
2747             st->u.keeper.val = PL_regstartp[0];
2748             PL_reginput = locinput;
2749             PL_regstartp[0] = locinput - PL_bostr;
2750             PUSH_STATE_GOTO(KEEPS_next, next);
2751             /*NOT-REACHED*/
2752         case KEEPS_next_fail:
2753             /* rollback the start point change */
2754             PL_regstartp[0] = st->u.keeper.val;
2755             sayNO_SILENT;
2756             /*NOT-REACHED*/
2757         case EOL:
2758                 goto seol;
2759         case MEOL:
2760             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2761                 sayNO;
2762             break;
2763         case SEOL:
2764           seol:
2765             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2766                 sayNO;
2767             if (PL_regeol - locinput > 1)
2768                 sayNO;
2769             break;
2770         case EOS:
2771             if (PL_regeol != locinput)
2772                 sayNO;
2773             break;
2774         case SANY:
2775             if (!nextchr && locinput >= PL_regeol)
2776                 sayNO;
2777             if (do_utf8) {
2778                 locinput += PL_utf8skip[nextchr];
2779                 if (locinput > PL_regeol)
2780                     sayNO;
2781                 nextchr = UCHARAT(locinput);
2782             }
2783             else
2784                 nextchr = UCHARAT(++locinput);
2785             break;
2786         case CANY:
2787             if (!nextchr && locinput >= PL_regeol)
2788                 sayNO;
2789             nextchr = UCHARAT(++locinput);
2790             break;
2791         case REG_ANY:
2792             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2793                 sayNO;
2794             if (do_utf8) {
2795                 locinput += PL_utf8skip[nextchr];
2796                 if (locinput > PL_regeol)
2797                     sayNO;
2798                 nextchr = UCHARAT(locinput);
2799             }
2800             else
2801                 nextchr = UCHARAT(++locinput);
2802             break;
2803
2804 #undef  ST
2805 #define ST st->u.trie
2806         case TRIEC:
2807             /* In this case the charclass data is available inline so
2808                we can fail fast without a lot of extra overhead. 
2809              */
2810             if (scan->flags == EXACT || !do_utf8) {
2811                 if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
2812                     DEBUG_EXECUTE_r(
2813                         PerlIO_printf(Perl_debug_log,
2814                                   "%*s  %sfailed to match trie start class...%s\n",
2815                                   REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2816                     );
2817                     sayNO_SILENT;
2818                     /* NOTREACHED */
2819                 }                       
2820             }
2821             /* FALL THROUGH */
2822         case TRIE:
2823             {
2824                 /* what type of TRIE am I? (utf8 makes this contextual) */
2825                 const enum { trie_plain, trie_utf8, trie_utf8_fold }
2826                     trie_type = do_utf8 ?
2827                           (scan->flags == EXACT ? trie_utf8 : trie_utf8_fold)
2828                         : trie_plain;
2829
2830                 /* what trie are we using right now */
2831                 reg_trie_data * const trie
2832                     = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
2833                 HV * widecharmap = (HV *)rexi->data->data[ ARG( scan ) + 1 ];
2834                 U32 state = trie->startstate;
2835
2836                 if (trie->bitmap && trie_type != trie_utf8_fold &&
2837                     !TRIE_BITMAP_TEST(trie,*locinput)
2838                 ) {
2839                     if (trie->states[ state ].wordnum) {
2840                          DEBUG_EXECUTE_r(
2841                             PerlIO_printf(Perl_debug_log,
2842                                           "%*s  %smatched empty string...%s\n",
2843                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2844                         );
2845                         break;
2846                     } else {
2847                         DEBUG_EXECUTE_r(
2848                             PerlIO_printf(Perl_debug_log,
2849                                           "%*s  %sfailed to match trie start class...%s\n",
2850                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2851                         );
2852                         sayNO_SILENT;
2853                    }
2854                 }
2855
2856             { 
2857                 U8 *uc = ( U8* )locinput;
2858
2859                 STRLEN len = 0;
2860                 STRLEN foldlen = 0;
2861                 U8 *uscan = (U8*)NULL;
2862                 STRLEN bufflen=0;
2863                 SV *sv_accept_buff = NULL;
2864                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2865
2866                 ST.accepted = 0; /* how many accepting states we have seen */
2867                 ST.B = next;
2868                 ST.jump = trie->jump;
2869                 ST.me = scan;
2870                 
2871                 /*
2872                    traverse the TRIE keeping track of all accepting states
2873                    we transition through until we get to a failing node.
2874                 */
2875
2876                 while ( state && uc <= (U8*)PL_regeol ) {
2877                     U32 base = trie->states[ state ].trans.base;
2878                     UV uvc = 0;
2879                     U16 charid;
2880                     /* We use charid to hold the wordnum as we don't use it
2881                        for charid until after we have done the wordnum logic. 
2882                        We define an alias just so that the wordnum logic reads
2883                        more naturally. */
2884
2885 #define got_wordnum charid
2886                     got_wordnum = trie->states[ state ].wordnum;
2887
2888                     if ( got_wordnum ) {
2889                         if ( ! ST.accepted ) {
2890                             ENTER;
2891                             SAVETMPS;
2892                             bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
2893                             sv_accept_buff=newSV(bufflen *
2894                                             sizeof(reg_trie_accepted) - 1);
2895                             SvCUR_set(sv_accept_buff, 0);
2896                             SvPOK_on(sv_accept_buff);
2897                             sv_2mortal(sv_accept_buff);
2898                             SAVETMPS;
2899                             ST.accept_buff =
2900                                 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
2901                         }
2902                         do {
2903                             if (ST.accepted >= bufflen) {
2904                                 bufflen *= 2;
2905                                 ST.accept_buff =(reg_trie_accepted*)
2906                                     SvGROW(sv_accept_buff,
2907                                         bufflen * sizeof(reg_trie_accepted));
2908                             }
2909                             SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
2910                                 + sizeof(reg_trie_accepted));
2911
2912
2913                             ST.accept_buff[ST.accepted].wordnum = got_wordnum;
2914                             ST.accept_buff[ST.accepted].endpos = uc;
2915                             ++ST.accepted;
2916                         } while (trie->nextword && (got_wordnum= trie->nextword[got_wordnum]));
2917                     }
2918 #undef got_wordnum 
2919
2920                     DEBUG_TRIE_EXECUTE_r({
2921                                 DUMP_EXEC_POS( (char *)uc, scan, do_utf8 );
2922                                 PerlIO_printf( Perl_debug_log,
2923                                     "%*s  %sState: %4"UVxf" Accepted: %4"UVxf" ",
2924                                     2+depth * 2, "", PL_colors[4],
2925                                     (UV)state, (UV)ST.accepted );
2926                     });
2927
2928                     if ( base ) {
2929                         REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
2930                                              uscan, len, uvc, charid, foldlen,
2931                                              foldbuf, uniflags);
2932
2933                         if (charid &&
2934                              (base + charid > trie->uniquecharcount )
2935                              && (base + charid - 1 - trie->uniquecharcount
2936                                     < trie->lasttrans)
2937                              && trie->trans[base + charid - 1 -
2938                                     trie->uniquecharcount].check == state)
2939                         {
2940                             state = trie->trans[base + charid - 1 -
2941                                 trie->uniquecharcount ].next;
2942                         }
2943                         else {
2944                             state = 0;
2945                         }
2946                         uc += len;
2947
2948                     }
2949                     else {
2950                         state = 0;
2951                     }
2952                     DEBUG_TRIE_EXECUTE_r(
2953                         PerlIO_printf( Perl_debug_log,
2954                             "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
2955                             charid, uvc, (UV)state, PL_colors[5] );
2956                     );
2957                 }
2958                 if (!ST.accepted )
2959                    sayNO;
2960
2961                 DEBUG_EXECUTE_r(
2962                     PerlIO_printf( Perl_debug_log,
2963                         "%*s  %sgot %"IVdf" possible matches%s\n",
2964                         REPORT_CODE_OFF + depth * 2, "",
2965                         PL_colors[4], (IV)ST.accepted, PL_colors[5] );
2966                 );
2967             }}
2968
2969             /* FALL THROUGH */
2970         case TRIE_next_fail: /* we failed - try next alterative */
2971             if (do_cutgroup) {
2972                 do_cutgroup = 0;
2973                 no_final = 0;
2974             }
2975             if ( ST.accepted == 1 ) {
2976                 /* only one choice left - just continue */
2977                 DEBUG_EXECUTE_r({
2978                     AV *const trie_words
2979                         = (AV *) rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET];
2980                     SV ** const tmp = av_fetch( trie_words, 
2981                         ST.accept_buff[ 0 ].wordnum-1, 0 );
2982                     SV *sv= tmp ? sv_newmortal() : NULL;
2983                     
2984                     PerlIO_printf( Perl_debug_log,
2985                         "%*s  %sonly one match left: #%d <%s>%s\n",
2986                         REPORT_CODE_OFF+depth*2, "", PL_colors[4],
2987                         ST.accept_buff[ 0 ].wordnum,
2988                         tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0, 
2989                                 PL_colors[0], PL_colors[1],
2990                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
2991                             ) 
2992                         : "not compiled under -Dr",
2993                         PL_colors[5] );
2994                 });
2995                 PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
2996                 /* in this case we free tmps/leave before we call regmatch
2997                    as we wont be using accept_buff again. */
2998                 
2999                 locinput = PL_reginput;
3000                 nextchr = UCHARAT(locinput);
3001                 if ( !ST.jump || !ST.jump[ST.accept_buff[0].wordnum]) 
3002                     scan = ST.B;
3003                 else
3004                     scan = ST.me + ST.jump[ST.accept_buff[0].wordnum];
3005                 if (!has_cutgroup) {
3006                     FREETMPS;
3007                     LEAVE;
3008                 } else {
3009                     ST.accepted--;
3010                     PUSH_YES_STATE_GOTO(TRIE_next, scan);
3011                 }
3012                 
3013                 continue; /* execute rest of RE */
3014             }
3015
3016             if (!ST.accepted-- ) {
3017                 DEBUG_EXECUTE_r({
3018                     PerlIO_printf( Perl_debug_log,
3019                         "%*s  %sTRIE failed...%s\n",
3020                         REPORT_CODE_OFF+depth*2, "", 
3021                         PL_colors[4],
3022                         PL_colors[5] );
3023                 });
3024                 FREETMPS;
3025                 LEAVE;
3026                 sayNO_SILENT;
3027             }
3028
3029             /*
3030                There are at least two accepting states left.  Presumably
3031                the number of accepting states is going to be low,
3032                typically two. So we simply scan through to find the one
3033                with lowest wordnum.  Once we find it, we swap the last
3034                state into its place and decrement the size. We then try to
3035                match the rest of the pattern at the point where the word
3036                ends. If we succeed, control just continues along the
3037                regex; if we fail we return here to try the next accepting
3038                state
3039              */
3040
3041             {
3042                 U32 best = 0;
3043                 U32 cur;
3044                 for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
3045                     DEBUG_TRIE_EXECUTE_r(
3046                         PerlIO_printf( Perl_debug_log,
3047                             "%*s  %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
3048                             REPORT_CODE_OFF + depth * 2, "", PL_colors[4],
3049                             (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
3050                             ST.accept_buff[ cur ].wordnum, PL_colors[5] );
3051                     );
3052
3053                     if (ST.accept_buff[cur].wordnum <
3054                             ST.accept_buff[best].wordnum)
3055                         best = cur;
3056                 }
3057
3058                 DEBUG_EXECUTE_r({
3059                     AV *const trie_words
3060                         = (AV *) rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET];
3061                     SV ** const tmp = av_fetch( trie_words, 
3062                         ST.accept_buff[ best ].wordnum - 1, 0 );
3063                     regnode *nextop=(!ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) ? 
3064                                     ST.B : 
3065                                     ST.me + ST.jump[ST.accept_buff[best].wordnum];    
3066                     SV *sv= tmp ? sv_newmortal() : NULL;
3067                     
3068                     PerlIO_printf( Perl_debug_log, 
3069                         "%*s  %strying alternation #%d <%s> at node #%d %s\n",
3070                         REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3071                         ST.accept_buff[best].wordnum,
3072                         tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0, 
3073                                 PL_colors[0], PL_colors[1],
3074                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3075                             ) : "not compiled under -Dr", 
3076                             REG_NODE_NUM(nextop),
3077                         PL_colors[5] );
3078                 });
3079
3080                 if ( best<ST.accepted ) {
3081                     reg_trie_accepted tmp = ST.accept_buff[ best ];
3082                     ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
3083                     ST.accept_buff[ ST.accepted ] = tmp;
3084                     best = ST.accepted;
3085                 }
3086                 PL_reginput = (char *)ST.accept_buff[ best ].endpos;
3087                 if ( !ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) {
3088                     scan = ST.B;
3089                     /* NOTREACHED */
3090                 } else {
3091                     scan = ST.me + ST.jump[ST.accept_buff[best].wordnum];
3092                     /* NOTREACHED */
3093                 }
3094                 if (has_cutgroup) {
3095                     PUSH_YES_STATE_GOTO(TRIE_next, scan);    
3096                     /* NOTREACHED */
3097                 } else {
3098                     PUSH_STATE_GOTO(TRIE_next, scan);
3099                     /* NOTREACHED */
3100                 }
3101                 /* NOTREACHED */
3102             }
3103             /* NOTREACHED */
3104         case TRIE_next:
3105             FREETMPS;
3106             LEAVE;
3107             sayYES;
3108 #undef  ST
3109
3110         case EXACT: {
3111             char *s = STRING(scan);
3112             ln = STR_LEN(scan);
3113             if (do_utf8 != UTF) {
3114                 /* The target and the pattern have differing utf8ness. */
3115                 char *l = locinput;
3116                 const char * const e = s + ln;
3117
3118                 if (do_utf8) {
3119                     /* The target is utf8, the pattern is not utf8. */
3120                     while (s < e) {
3121                         STRLEN ulen;
3122                         if (l >= PL_regeol)
3123                              sayNO;
3124                         if (NATIVE_TO_UNI(*(U8*)s) !=
3125                             utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3126                                             uniflags))
3127                              sayNO;
3128                         l += ulen;
3129                         s ++;
3130                     }
3131                 }
3132                 else {
3133                     /* The target is not utf8, the pattern is utf8. */
3134                     while (s < e) {
3135                         STRLEN ulen;
3136                         if (l >= PL_regeol)
3137                             sayNO;
3138                         if (NATIVE_TO_UNI(*((U8*)l)) !=
3139                             utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3140                                            uniflags))
3141                             sayNO;
3142                         s += ulen;
3143                         l ++;
3144                     }
3145                 }
3146                 locinput = l;
3147                 nextchr = UCHARAT(locinput);
3148                 break;
3149             }
3150             /* The target and the pattern have the same utf8ness. */
3151             /* Inline the first character, for speed. */
3152             if (UCHARAT(s) != nextchr)
3153                 sayNO;
3154             if (PL_regeol - locinput < ln)
3155                 sayNO;
3156             if (ln > 1 && memNE(s, locinput, ln))
3157                 sayNO;
3158             locinput += ln;
3159             nextchr = UCHARAT(locinput);
3160             break;
3161             }
3162         case EXACTFL:
3163             PL_reg_flags |= RF_tainted;
3164             /* FALL THROUGH */
3165         case EXACTF: {
3166             char * const s = STRING(scan);
3167             ln = STR_LEN(scan);
3168
3169             if (do_utf8 || UTF) {
3170               /* Either target or the pattern are utf8. */
3171                 const char * const l = locinput;
3172                 char *e = PL_regeol;
3173
3174                 if (ibcmp_utf8(s, 0,  ln, (bool)UTF,
3175                                l, &e, 0,  do_utf8)) {
3176                      /* One more case for the sharp s:
3177                       * pack("U0U*", 0xDF) =~ /ss/i,
3178                       * the 0xC3 0x9F are the UTF-8
3179                       * byte sequence for the U+00DF. */
3180                      if (!(do_utf8 &&
3181                            toLOWER(s[0]) == 's' &&
3182                            ln >= 2 &&
3183                            toLOWER(s[1]) == 's' &&
3184                            (U8)l[0] == 0xC3 &&
3185                            e - l >= 2 &&
3186                            (U8)l[1] == 0x9F))
3187                           sayNO;
3188                 }
3189                 locinput = e;
3190                 nextchr = UCHARAT(locinput);
3191                 break;
3192             }
3193
3194             /* Neither the target and the pattern are utf8. */
3195
3196             /* Inline the first character, for speed. */
3197             if (UCHARAT(s) != nextchr &&
3198                 UCHARAT(s) != ((OP(scan) == EXACTF)
3199                                ? PL_fold : PL_fold_locale)[nextchr])
3200                 sayNO;
3201             if (PL_regeol - locinput < ln)
3202                 sayNO;
3203             if (ln > 1 && (OP(scan) == EXACTF
3204                            ? ibcmp(s, locinput, ln)
3205                            : ibcmp_locale(s, locinput, ln)))
3206                 sayNO;
3207             locinput += ln;
3208             nextchr = UCHARAT(locinput);
3209             break;
3210             }
3211         case ANYOF:
3212             if (do_utf8) {
3213                 STRLEN inclasslen = PL_regeol - locinput;
3214
3215                 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3216                     goto anyof_fail;
3217                 if (locinput >= PL_regeol)
3218                     sayNO;
3219                 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3220                 nextchr = UCHARAT(locinput);
3221                 break;
3222             }
3223             else {
3224                 if (nextchr < 0)
3225                     nextchr = UCHARAT(locinput);
3226                 if (!REGINCLASS(rex, scan, (U8*)locinput))
3227                     goto anyof_fail;
3228                 if (!nextchr && locinput >= PL_regeol)
3229                     sayNO;
3230                 nextchr = UCHARAT(++locinput);
3231                 break;
3232             }
3233         anyof_fail:
3234             /* If we might have the case of the German sharp s
3235              * in a casefolding Unicode character class. */
3236
3237             if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3238                  locinput += SHARP_S_SKIP;
3239                  nextchr = UCHARAT(locinput);
3240             }
3241             else
3242                  sayNO;
3243             break;
3244         case ALNUML:
3245             PL_reg_flags |= RF_tainted;
3246             /* FALL THROUGH */
3247         case ALNUM:
3248             if (!nextchr)
3249                 sayNO;
3250             if (do_utf8) {
3251                 LOAD_UTF8_CHARCLASS_ALNUM();
3252                 if (!(OP(scan) == ALNUM
3253                       ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3254                       : isALNUM_LC_utf8((U8*)locinput)))
3255                 {
3256                     sayNO;
3257                 }
3258                 locinput += PL_utf8skip[nextchr];
3259                 nextchr = UCHARAT(locinput);
3260                 break;
3261             }
3262             if (!(OP(scan) == ALNUM
3263                   ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
3264                 sayNO;
3265             nextchr = UCHARAT(++locinput);
3266             break;
3267         case NALNUML:
3268             PL_reg_flags |= RF_tainted;
3269             /* FALL THROUGH */
3270         case NALNUM:
3271             if (!nextchr && locinput >= PL_regeol)
3272                 sayNO;
3273             if (do_utf8) {
3274                 LOAD_UTF8_CHARCLASS_ALNUM();
3275                 if (OP(scan) == NALNUM
3276                     ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3277                     : isALNUM_LC_utf8((U8*)locinput))
3278                 {
3279                     sayNO;
3280                 }
3281                 locinput += PL_utf8skip[nextchr];
3282                 nextchr = UCHARAT(locinput);
3283                 break;
3284             }
3285             if (OP(scan) == NALNUM
3286                 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
3287                 sayNO;
3288             nextchr = UCHARAT(++locinput);
3289             break;
3290         case BOUNDL:
3291         case NBOUNDL:
3292             PL_reg_flags |= RF_tainted;
3293             /* FALL THROUGH */
3294         case BOUND:
3295         case NBOUND:
3296             /* was last char in word? */
3297             if (do_utf8) {
3298                 if (locinput == PL_bostr)
3299                     ln = '\n';
3300                 else {
3301                     const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3302                 
3303                     ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3304                 }
3305                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3306                     ln = isALNUM_uni(ln);
3307                     LOAD_UTF8_CHARCLASS_ALNUM();
3308                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3309                 }
3310                 else {
3311                     ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
3312                     n = isALNUM_LC_utf8((U8*)locinput);
3313                 }
3314             }
3315             else {
3316                 ln = (locinput != PL_bostr) ?
3317                     UCHARAT(locinput - 1) : '\n';
3318                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3319                     ln = isALNUM(ln);
3320                     n = isALNUM(nextchr);
3321                 }
3322                 else {
3323                     ln = isALNUM_LC(ln);
3324                     n = isALNUM_LC(nextchr);
3325                 }
3326             }
3327             if (((!ln) == (!n)) == (OP(scan) == BOUND ||
3328                                     OP(scan) == BOUNDL))
3329                     sayNO;
3330             break;
3331         case SPACEL:
3332             PL_reg_flags |= RF_tainted;
3333             /* FALL THROUGH */
3334         case SPACE:
3335             if (!nextchr)
3336                 sayNO;
3337             if (do_utf8) {
3338                 if (UTF8_IS_CONTINUED(nextchr)) {
3339                     LOAD_UTF8_CHARCLASS_SPACE();
3340                     if (!(OP(scan) == SPACE
3341                           ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3342                           : isSPACE_LC_utf8((U8*)locinput)))
3343                     {
3344                         sayNO;
3345                     }
3346                     locinput += PL_utf8skip[nextchr];
3347                     nextchr = UCHARAT(locinput);
3348                     break;
3349                 }
3350                 if (!(OP(scan) == SPACE
3351                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3352                     sayNO;
3353                 nextchr = UCHARAT(++locinput);
3354             }
3355             else {
3356                 if (!(OP(scan) == SPACE
3357                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3358                     sayNO;
3359                 nextchr = UCHARAT(++locinput);
3360             }
3361             break;
3362         case NSPACEL:
3363             PL_reg_flags |= RF_tainted;
3364             /* FALL THROUGH */
3365         case NSPACE:
3366             if (!nextchr && locinput >= PL_regeol)
3367                 sayNO;
3368             if (do_utf8) {
3369                 LOAD_UTF8_CHARCLASS_SPACE();
3370                 if (OP(scan) == NSPACE
3371                     ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3372                     : isSPACE_LC_utf8((U8*)locinput))
3373                 {
3374                     sayNO;
3375                 }
3376                 locinput += PL_utf8skip[nextchr];
3377                 nextchr = UCHARAT(locinput);
3378                 break;
3379             }
3380             if (OP(scan) == NSPACE
3381                 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
3382                 sayNO;
3383             nextchr = UCHARAT(++locinput);
3384             break;
3385         case DIGITL:
3386             PL_reg_flags |= RF_tainted;
3387             /* FALL THROUGH */
3388         case DIGIT:
3389             if (!nextchr)
3390                 sayNO;
3391             if (do_utf8) {
3392                 LOAD_UTF8_CHARCLASS_DIGIT();
3393                 if (!(OP(scan) == DIGIT
3394                       ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3395                       : isDIGIT_LC_utf8((U8*)locinput)))
3396                 {
3397                     sayNO;
3398                 }
3399                 locinput += PL_utf8skip[nextchr];
3400                 nextchr = UCHARAT(locinput);
3401                 break;
3402             }
3403             if (!(OP(scan) == DIGIT
3404                   ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
3405                 sayNO;
3406             nextchr = UCHARAT(++locinput);
3407             break;
3408         case NDIGITL:
3409             PL_reg_flags |= RF_tainted;
3410             /* FALL THROUGH */
3411         case NDIGIT:
3412             if (!nextchr && locinput >= PL_regeol)
3413                 sayNO;
3414             if (do_utf8) {
3415                 LOAD_UTF8_CHARCLASS_DIGIT();
3416                 if (OP(scan) == NDIGIT
3417                     ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3418                     : isDIGIT_LC_utf8((U8*)locinput))
3419                 {
3420                     sayNO;
3421                 }
3422                 locinput += PL_utf8skip[nextchr];
3423                 nextchr = UCHARAT(locinput);
3424                 break;
3425             }
3426             if (OP(scan) == NDIGIT
3427                 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
3428                 sayNO;
3429             nextchr = UCHARAT(++locinput);
3430             break;
3431         case CLUMP:
3432             if (locinput >= PL_regeol)
3433                 sayNO;
3434             if  (do_utf8) {
3435                 LOAD_UTF8_CHARCLASS_MARK();
3436                 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3437                     sayNO;
3438                 locinput += PL_utf8skip[nextchr];
3439                 while (locinput < PL_regeol &&
3440                        swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3441                     locinput += UTF8SKIP(locinput);
3442                 if (locinput > PL_regeol)
3443                     sayNO;
3444             } 
3445             else
3446                locinput++;
3447             nextchr = UCHARAT(locinput);
3448             break;
3449             
3450         case NREFFL:
3451         {
3452             char *s;
3453             char type;
3454             PL_reg_flags |= RF_tainted;
3455             /* FALL THROUGH */
3456         case NREF:
3457         case NREFF:
3458             type = OP(scan);
3459             n = reg_check_named_buff_matched(rex,scan);
3460
3461             if ( n ) {
3462                 type = REF + ( type - NREF );
3463                 goto do_ref;
3464             } else {
3465                 sayNO;
3466             }
3467             /* unreached */
3468         case REFFL:
3469             PL_reg_flags |= RF_tainted;
3470             /* FALL THROUGH */
3471         case REF:
3472         case REFF: 
3473             n = ARG(scan);  /* which paren pair */
3474             type = OP(scan);
3475           do_ref:  
3476             ln = PL_regstartp[n];
3477             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3478             if (*PL_reglastparen < n || ln == -1)
3479                 sayNO;                  /* Do not match unless seen CLOSEn. */
3480             if (ln == PL_regendp[n])
3481                 break;
3482
3483             s = PL_bostr + ln;
3484             if (do_utf8 && type != REF) {       /* REF can do byte comparison */
3485                 char *l = locinput;
3486                 const char *e = PL_bostr + PL_regendp[n];
3487                 /*
3488                  * Note that we can't do the "other character" lookup trick as
3489                  * in the 8-bit case (no pun intended) because in Unicode we
3490                  * have to map both upper and title case to lower case.
3491                  */
3492                 if (type == REFF) {
3493                     while (s < e) {
3494                         STRLEN ulen1, ulen2;
3495                         U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3496                         U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3497
3498                         if (l >= PL_regeol)
3499                             sayNO;
3500                         toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3501                         toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3502                         if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3503                             sayNO;
3504                         s += ulen1;
3505                         l += ulen2;
3506                     }
3507                 }
3508                 locinput = l;
3509                 nextchr = UCHARAT(locinput);
3510                 break;
3511             }
3512
3513             /* Inline the first character, for speed. */
3514             if (UCHARAT(s) != nextchr &&
3515                 (type == REF ||
3516                  (UCHARAT(s) != (type == REFF
3517                                   ? PL_fold : PL_fold_locale)[nextchr])))
3518                 sayNO;
3519             ln = PL_regendp[n] - ln;
3520             if (locinput + ln > PL_regeol)
3521                 sayNO;
3522             if (ln > 1 && (type == REF
3523                            ? memNE(s, locinput, ln)
3524                            : (type == REFF
3525                               ? ibcmp(s, locinput, ln)
3526                               : ibcmp_locale(s, locinput, ln))))
3527                 sayNO;
3528             locinput += ln;
3529             nextchr = UCHARAT(locinput);
3530             break;
3531         }
3532         case NOTHING:
3533         case TAIL:
3534             break;
3535         case BACK:
3536             break;
3537
3538 #undef  ST
3539 #define ST st->u.eval
3540         {
3541             SV *ret;
3542             regexp *re;
3543             regexp_internal *rei;
3544             regnode *startpoint;
3545
3546         case GOSTART:
3547         case GOSUB: /*    /(...(?1))/      */
3548             if (cur_eval && cur_eval->locinput==locinput) {
3549                 if (cur_eval->u.eval.close_paren == (U32)ARG(scan)) 
3550                     Perl_croak(aTHX_ "Infinite recursion in regex");
3551                 if ( ++nochange_depth > MAX_RECURSE_EVAL_NOCHANGE_DEPTH ) 
3552                     Perl_croak(aTHX_ 
3553                         "Pattern subroutine nesting without pos change"
3554                         " exceeded limit in regex");
3555             } else {
3556                 nochange_depth = 0;
3557             }
3558             re = rex;
3559             rei = rexi;
3560             (void)ReREFCNT_inc(rex);
3561             if (OP(scan)==GOSUB) {
3562                 startpoint = scan + ARG2L(scan);
3563                 ST.close_paren = ARG(scan);
3564             } else {
3565                 startpoint = rei->program+1;
3566                 ST.close_paren = 0;
3567             }
3568             goto eval_recurse_doit;
3569             /* NOTREACHED */
3570         case EVAL:  /*   /(?{A})B/   /(??{A})B/  and /(?(?{A})X|Y)B/   */        
3571             if (cur_eval && cur_eval->locinput==locinput) {
3572                 if ( ++nochange_depth > MAX_RECURSE_EVAL_NOCHANGE_DEPTH ) 
3573                     Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
3574             } else {
3575                 nochange_depth = 0;
3576             }    
3577             {
3578                 /* execute the code in the {...} */
3579                 dSP;
3580                 SV ** const before = SP;
3581                 OP_4tree * const oop = PL_op;
3582                 COP * const ocurcop = PL_curcop;
3583                 PAD *old_comppad;
3584             
3585                 n = ARG(scan);
3586                 PL_op = (OP_4tree*)rexi->data->data[n];
3587                 DEBUG_STATE_r( PerlIO_printf(Perl_debug_log, 
3588                     "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3589                 PAD_SAVE_LOCAL(old_comppad, (PAD*)rexi->data->data[n + 2]);
3590                 PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
3591
3592                 if (sv_yes_mark) {
3593                     SV *sv_mrk = get_sv("REGMARK", 1);
3594                     sv_setsv(sv_mrk, sv_yes_mark);
3595                 }
3596
3597                 CALLRUNOPS(aTHX);                       /* Scalar context. */
3598                 SPAGAIN;
3599                 if (SP == before)
3600                     ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
3601                 else {
3602                     ret = POPs;
3603                     PUTBACK;
3604                 }
3605
3606                 PL_op = oop;
3607                 PAD_RESTORE_LOCAL(old_comppad);
3608                 PL_curcop = ocurcop;
3609                 if (!logical) {
3610                     /* /(?{...})/ */
3611                     sv_setsv(save_scalar(PL_replgv), ret);
3612                     break;
3613                 }
3614             }
3615             if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
3616                 logical = 0;
3617                 {
3618                     /* extract RE object from returned value; compiling if
3619                      * necessary */
3620
3621                     MAGIC *mg = NULL;
3622                     const SV *sv;
3623                     if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
3624                         mg = mg_find(sv, PERL_MAGIC_qr);
3625                     else if (SvSMAGICAL(ret)) {
3626                         if (SvGMAGICAL(ret))
3627                             sv_unmagic(ret, PERL_MAGIC_qr);
3628                         else
3629                             mg = mg_find(ret, PERL_MAGIC_qr);
3630                     }
3631
3632                     if (mg) {
3633                         re = (regexp *)mg->mg_obj;
3634                         (void)ReREFCNT_inc(re);
3635                     }
3636                     else {
3637                         STRLEN len;
3638                         const char * const t = SvPV_const(ret, len);
3639                         PMOP pm;
3640                         const I32 osize = PL_regsize;
3641
3642                         Zero(&pm, 1, PMOP);
3643                         if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
3644                         re = CALLREGCOMP((char*)t, (char*)t + len, &pm);
3645                         if (!(SvFLAGS(ret)
3646                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3647                                 | SVs_GMG)))
3648                             sv_magic(ret,(SV*)ReREFCNT_inc(re),
3649                                         PERL_MAGIC_qr,0,0);
3650                         PL_regsize = osize;
3651                     }
3652                 }
3653                 rei = RXi_GET(re);
3654                 DEBUG_EXECUTE_r(
3655                     debug_start_match(re, do_utf8, locinput, PL_regeol, 
3656                         "Matching embedded");
3657                 );              
3658                 startpoint = rei->program + 1;
3659                 ST.close_paren = 0; /* only used for GOSUB */
3660                 /* borrowed from regtry */
3661                 if (PL_reg_start_tmpl <= re->nparens) {
3662                     PL_reg_start_tmpl = re->nparens*3/2 + 3;
3663                     if(PL_reg_start_tmp)
3664                         Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
3665                     else
3666                         Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
3667                 }                       
3668
3669         eval_recurse_doit: /* Share code with GOSUB below this line */                          
3670                 /* run the pattern returned from (??{...}) */
3671                 ST.cp = regcppush(0);   /* Save *all* the positions. */
3672                 REGCP_SET(ST.lastcp);
3673                 
3674                 PL_regstartp = re->startp; /* essentially NOOP on GOSUB */
3675                 PL_regendp = re->endp;     /* essentially NOOP on GOSUB */
3676                 
3677                 *PL_reglastparen = 0;
3678                 *PL_reglastcloseparen = 0;
3679                 PL_reginput = locinput;
3680                 PL_regsize = 0;
3681
3682                 /* XXXX This is too dramatic a measure... */
3683                 PL_reg_maxiter = 0;
3684
3685                 ST.toggle_reg_flags = PL_reg_flags;
3686                 if (re->extflags & RXf_UTF8)
3687                     PL_reg_flags |= RF_utf8;
3688                 else
3689                     PL_reg_flags &= ~RF_utf8;
3690                 ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
3691
3692                 ST.prev_rex = rex;
3693                 ST.prev_curlyx = cur_curlyx;
3694                 rex = re;
3695                 rexi = rei;
3696                 cur_curlyx = NULL;
3697                 ST.B = next;
3698                 ST.prev_eval = cur_eval;
3699                 cur_eval = st;
3700                 /* now continue from first node in postoned RE */
3701                 PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
3702                 /* NOTREACHED */
3703             }
3704             /* logical is 1,   /(?(?{...})X|Y)/ */
3705             sw = (bool)SvTRUE(ret);
3706             logical = 0;
3707             break;
3708         }
3709
3710         case EVAL_AB: /* cleanup after a successful (??{A})B */
3711             /* note: this is called twice; first after popping B, then A */
3712             PL_reg_flags ^= ST.toggle_reg_flags; 
3713             ReREFCNT_dec(rex);
3714             rex = ST.prev_rex;
3715             rexi = RXi_GET(rex);
3716             regcpblow(ST.cp);
3717             cur_eval = ST.prev_eval;
3718             cur_curlyx = ST.prev_curlyx;
3719             /* XXXX This is too dramatic a measure... */
3720             PL_reg_maxiter = 0;
3721             sayYES;
3722
3723
3724         case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
3725             /* note: this is called twice; first after popping B, then A */
3726             PL_reg_flags ^= ST.toggle_reg_flags; 
3727             ReREFCNT_dec(rex);
3728             rex = ST.prev_rex;
3729             rexi = RXi_GET(rex); 
3730             PL_reginput = locinput;
3731             REGCP_UNWIND(ST.lastcp);
3732             regcppop(rex);
3733             cur_eval = ST.prev_eval;
3734             cur_curlyx = ST.prev_curlyx;
3735             /* XXXX This is too dramatic a measure... */
3736             PL_reg_maxiter = 0;
3737             sayNO_SILENT;
3738 #undef ST
3739
3740         case OPEN:
3741             n = ARG(scan);  /* which paren pair */
3742             PL_reg_start_tmp[n] = locinput;
3743             if (n > PL_regsize)
3744                 PL_regsize = n;
3745             lastopen = n;
3746             break;
3747         case CLOSE:
3748             n = ARG(scan);  /* which paren pair */
3749             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3750             PL_regendp[n] = locinput - PL_bostr;
3751             /*if (n > PL_regsize)
3752                 PL_regsize = n;*/
3753             if (n > *PL_reglastparen)
3754                 *PL_reglastparen = n;
3755             *PL_reglastcloseparen = n;
3756             if (cur_eval && cur_eval->u.eval.close_paren == n) {
3757                 goto fake_end;
3758             }    
3759             break;
3760         case ACCEPT:
3761             if (ARG(scan)){
3762                 regnode *cursor;
3763                 for (cursor=scan;
3764                      cursor && OP(cursor)!=END; 
3765                      cursor=regnext(cursor)) 
3766                 {
3767                     if ( OP(cursor)==CLOSE ){
3768                         n = ARG(cursor);
3769                         if ( n <= lastopen ) {
3770                             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3771                             PL_regendp[n] = locinput - PL_bostr;
3772                             /*if (n > PL_regsize)
3773                             PL_regsize = n;*/
3774                             if (n > *PL_reglastparen)
3775                                 *PL_reglastparen = n;
3776                             *PL_reglastcloseparen = n;
3777                             if ( n == ARG(scan) || (cur_eval &&
3778                                 cur_eval->u.eval.close_paren == n))
3779                                 break;
3780                         }
3781                     }
3782                 }
3783             }
3784             goto fake_end;
3785             /*NOTREACHED*/          
3786         case GROUPP:
3787             n = ARG(scan);  /* which paren pair */
3788             sw = (bool)(*PL_reglastparen >= n && PL_regendp[n] != -1);
3789             break;
3790         case NGROUPP:
3791             /* reg_check_named_buff_matched returns 0 for no match */
3792             sw = (bool)(0 < reg_check_named_buff_matched(rex,scan));
3793             break;
3794         case INSUBP:
3795             n = ARG(scan);
3796             sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
3797             break;
3798         case DEFINEP:
3799             sw = 0;
3800             break;
3801         case IFTHEN:
3802             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3803             if (sw)
3804                 next = NEXTOPER(NEXTOPER(scan));
3805             else {
3806                 next = scan + ARG(scan);
3807                 if (OP(next) == IFTHEN) /* Fake one. */
3808                     next = NEXTOPER(NEXTOPER(next));
3809             }
3810             break;
3811         case LOGICAL:
3812             logical = scan->flags;
3813             break;
3814
3815 /*******************************************************************
3816
3817 The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
3818 pattern, where A and B are subpatterns. (For simple A, CURLYM or
3819 STAR/PLUS/CURLY/CURLYN are used instead.)
3820
3821 A*B is compiled as <CURLYX><A><WHILEM><B>
3822
3823 On entry to the subpattern, CURLYX is called. This pushes a CURLYX
3824 state, which contains the current count, initialised to -1. It also sets
3825 cur_curlyx to point to this state, with any previous value saved in the
3826 state block.
3827
3828 CURLYX then jumps straight to the WHILEM op, rather than executing A,
3829 since the pattern may possibly match zero times (i.e. it's a while {} loop
3830 rather than a do {} while loop).
3831
3832 Each entry to WHILEM represents a successful match of A. The count in the
3833 CURLYX block is incremented, another WHILEM state is pushed, and execution
3834 passes to A or B depending on greediness and the current count.
3835
3836 For example, if matching against the string a1a2a3b (where the aN are
3837 substrings that match /A/), then the match progresses as follows: (the
3838 pushed states are interspersed with the bits of strings matched so far):
3839
3840     <CURLYX cnt=-1>
3841     <CURLYX cnt=0><WHILEM>
3842     <CURLYX cnt=1><WHILEM> a1 <WHILEM>
3843     <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
3844     <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
3845     <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
3846
3847 (Contrast this with something like CURLYM, which maintains only a single
3848 backtrack state:
3849
3850     <CURLYM cnt=0> a1
3851     a1 <CURLYM cnt=1> a2
3852     a1 a2 <CURLYM cnt=2> a3
3853     a1 a2 a3 <CURLYM cnt=3> b
3854 )
3855
3856 Each WHILEM state block marks a point to backtrack to upon partial failure
3857 of A or B, and also contains some minor state data related to that
3858 iteration.  The CURLYX block, pointed to by cur_curlyx, contains the
3859 overall state, such as the count, and pointers to the A and B ops.
3860
3861 This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
3862 must always point to the *current* CURLYX block, the rules are:
3863
3864 When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
3865 and set cur_curlyx to point the new block.
3866
3867 When popping the CURLYX block after a successful or unsuccessful match,
3868 restore the previous cur_curlyx.
3869
3870 When WHILEM is about to execute B, save the current cur_curlyx, and set it
3871 to the outer one saved in the CURLYX block.
3872
3873 When popping the WHILEM block after a successful or unsuccessful B match,
3874 restore the previous cur_curlyx.
3875
3876 Here's an example for the pattern (AI* BI)*BO
3877 I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
3878
3879 cur_
3880 curlyx backtrack stack
3881 ------ ---------------
3882 NULL   
3883 CO     <CO prev=NULL> <WO>
3884 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai 
3885 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi 
3886 NULL   <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
3887
3888 At this point the pattern succeeds, and we work back down the stack to
3889 clean up, restoring as we go:
3890
3891 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi 
3892 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai 
3893 CO     <CO prev=NULL> <WO>
3894 NULL   
3895
3896 *******************************************************************/
3897
3898 #define ST st->u.curlyx
3899
3900         case CURLYX:    /* start of /A*B/  (for complex A) */
3901         {
3902             /* No need to save/restore up to this paren */
3903             I32 parenfloor = scan->flags;
3904             
3905             assert(next); /* keep Coverity happy */
3906             if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
3907                 next += ARG(next);
3908
3909             /* XXXX Probably it is better to teach regpush to support
3910                parenfloor > PL_regsize... */
3911             if (parenfloor > (I32)*PL_reglastparen)
3912                 parenfloor = *PL_reglastparen; /* Pessimization... */
3913
3914             ST.prev_curlyx= cur_curlyx;
3915             cur_curlyx = st;
3916             ST.cp = PL_savestack_ix;
3917
3918             /* these fields contain the state of the current curly.
3919              * they are accessed by subsequent WHILEMs */
3920             ST.parenfloor = parenfloor;
3921             ST.min = ARG1(scan);
3922             ST.max = ARG2(scan);
3923             ST.A = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3924             ST.B = next;
3925             ST.minmod = minmod;
3926             minmod = 0;
3927             ST.count = -1;      /* this will be updated by WHILEM */
3928             ST.lastloc = NULL;  /* this will be updated by WHILEM */
3929
3930             PL_reginput = locinput;
3931             PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next));
3932             /* NOTREACHED */
3933         }
3934
3935         case CURLYX_end: /* just finished matching all of A*B */
3936             if (PL_reg_eval_set){
3937                 SV *pres= GvSV(PL_replgv);
3938                 SvREFCNT_inc(pres);
3939                 regcpblow(ST.cp);
3940                 sv_setsv(GvSV(PL_replgv), pres);
3941                 SvREFCNT_dec(pres);
3942             } else {
3943                 regcpblow(ST.cp);
3944             }
3945             cur_curlyx = ST.prev_curlyx;
3946             sayYES;
3947             /* NOTREACHED */
3948
3949         case CURLYX_end_fail: /* just failed to match all of A*B */
3950             regcpblow(ST.cp);
3951             cur_curlyx = ST.prev_curlyx;
3952             sayNO;
3953             /* NOTREACHED */
3954
3955
3956 #undef ST