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