In PL_regexp_padav, store regexps via real references, rather than
[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      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
289      * --jhi updated by dapm */
290     for (i = *PL_reglastparen + 1; i <= rex->nparens; i++) {
291         if (i > PL_regsize)
292             PL_regoffs[i].start = -1;
293         PL_regoffs[i].end = -1;
294     }
295 #endif
296     return input;
297 }
298
299 #define regcpblow(cp) LEAVE_SCOPE(cp)   /* Ignores regcppush()ed data. */
300
301 /*
302  * pregexec and friends
303  */
304
305 #ifndef PERL_IN_XSUB_RE
306 /*
307  - pregexec - match a regexp against a string
308  */
309 I32
310 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, register char *strend,
311          char *strbeg, I32 minend, SV *screamer, U32 nosave)
312 /* strend: pointer to null at end of string */
313 /* strbeg: real beginning of string */
314 /* minend: end of match must be >=minend after stringarg. */
315 /* nosave: For optimizations. */
316 {
317     return
318         regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
319                       nosave ? 0 : REXEC_COPY_STR);
320 }
321 #endif
322
323 /*
324  * Need to implement the following flags for reg_anch:
325  *
326  * USE_INTUIT_NOML              - Useful to call re_intuit_start() first
327  * USE_INTUIT_ML
328  * INTUIT_AUTORITATIVE_NOML     - Can trust a positive answer
329  * INTUIT_AUTORITATIVE_ML
330  * INTUIT_ONCE_NOML             - Intuit can match in one location only.
331  * INTUIT_ONCE_ML
332  *
333  * Another flag for this function: SECOND_TIME (so that float substrs
334  * with giant delta may be not rechecked).
335  */
336
337 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
338
339 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
340    Otherwise, only SvCUR(sv) is used to get strbeg. */
341
342 /* XXXX We assume that strpos is strbeg unless sv. */
343
344 /* XXXX Some places assume that there is a fixed substring.
345         An update may be needed if optimizer marks as "INTUITable"
346         RExen without fixed substrings.  Similarly, it is assumed that
347         lengths of all the strings are no more than minlen, thus they
348         cannot come from lookahead.
349         (Or minlen should take into account lookahead.) 
350   NOTE: Some of this comment is not correct. minlen does now take account
351   of lookahead/behind. Further research is required. -- demerphq
352
353 */
354
355 /* A failure to find a constant substring means that there is no need to make
356    an expensive call to REx engine, thus we celebrate a failure.  Similarly,
357    finding a substring too deep into the string means that less calls to
358    regtry() should be needed.
359
360    REx compiler's optimizer found 4 possible hints:
361         a) Anchored substring;
362         b) Fixed substring;
363         c) Whether we are anchored (beginning-of-line or \G);
364         d) First node (of those at offset 0) which may distingush positions;
365    We use a)b)d) and multiline-part of c), and try to find a position in the
366    string which does not contradict any of them.
367  */
368
369 /* Most of decisions we do here should have been done at compile time.
370    The nodes of the REx which we used for the search should have been
371    deleted from the finite automaton. */
372
373 char *
374 Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos,
375                      char *strend, const U32 flags, re_scream_pos_data *data)
376 {
377     dVAR;
378     struct regexp *const prog = (struct regexp *)SvANY(rx);
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(rx,do_utf8);
399
400     if (RX_UTF8(rx)) {
401         PL_reg_flags |= RF_utf8;
402     }
403     DEBUG_EXECUTE_r( 
404         debug_start_match(rx, 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, RX_PRECOMP(prog));
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 && RXp_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 #define DECL_TRIE_TYPE(scan) \
994     const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold } \
995                     trie_type = (scan->flags != EXACT) \
996                               ? (do_utf8 ? trie_utf8_fold : (UTF ? trie_latin_utf8_fold : trie_plain)) \
997                               : (do_utf8 ? trie_utf8 : trie_plain)
998
999 #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len,  \
1000 uvc, charid, foldlen, foldbuf, uniflags) STMT_START {                       \
1001     switch (trie_type) {                                                    \
1002     case trie_utf8_fold:                                                    \
1003         if ( foldlen>0 ) {                                                  \
1004             uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );     \
1005             foldlen -= len;                                                 \
1006             uscan += len;                                                   \
1007             len=0;                                                          \
1008         } else {                                                            \
1009             uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );   \
1010             uvc = to_uni_fold( uvc, foldbuf, &foldlen );                    \
1011             foldlen -= UNISKIP( uvc );                                      \
1012             uscan = foldbuf + UNISKIP( uvc );                               \
1013         }                                                                   \
1014         break;                                                              \
1015     case trie_latin_utf8_fold:                                              \
1016         if ( foldlen>0 ) {                                                  \
1017             uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );     \
1018             foldlen -= len;                                                 \
1019             uscan += len;                                                   \
1020             len=0;                                                          \
1021         } else {                                                            \
1022             len = 1;                                                        \
1023             uvc = to_uni_fold( *(U8*)uc, foldbuf, &foldlen );               \
1024             foldlen -= UNISKIP( uvc );                                      \
1025             uscan = foldbuf + UNISKIP( uvc );                               \
1026         }                                                                   \
1027         break;                                                              \
1028     case trie_utf8:                                                         \
1029         uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );       \
1030         break;                                                              \
1031     case trie_plain:                                                        \
1032         uvc = (UV)*uc;                                                      \
1033         len = 1;                                                            \
1034     }                                                                       \
1035                                                                             \
1036     if (uvc < 256) {                                                        \
1037         charid = trie->charmap[ uvc ];                                      \
1038     }                                                                       \
1039     else {                                                                  \
1040         charid = 0;                                                         \
1041         if (widecharmap) {                                                  \
1042             SV** const svpp = hv_fetch(widecharmap,                         \
1043                         (char*)&uvc, sizeof(UV), 0);                        \
1044             if (svpp)                                                       \
1045                 charid = (U16)SvIV(*svpp);                                  \
1046         }                                                                   \
1047     }                                                                       \
1048 } STMT_END
1049
1050 #define REXEC_FBC_EXACTISH_CHECK(CoNd)                 \
1051 {                                                      \
1052     char *my_strend= (char *)strend;                   \
1053     if ( (CoNd)                                        \
1054          && (ln == len ||                              \
1055              !ibcmp_utf8(s, &my_strend, 0,  do_utf8,   \
1056                         m, NULL, ln, (bool)UTF))       \
1057          && (!reginfo || regtry(reginfo, &s)) )        \
1058         goto got_it;                                   \
1059     else {                                             \
1060          U8 foldbuf[UTF8_MAXBYTES_CASE+1];             \
1061          uvchr_to_utf8(tmpbuf, c);                     \
1062          f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);  \
1063          if ( f != c                                   \
1064               && (f == c1 || f == c2)                  \
1065               && (ln == len ||                         \
1066                 !ibcmp_utf8(s, &my_strend, 0,  do_utf8,\
1067                               m, NULL, ln, (bool)UTF)) \
1068               && (!reginfo || regtry(reginfo, &s)) )   \
1069               goto got_it;                             \
1070     }                                                  \
1071 }                                                      \
1072 s += len
1073
1074 #define REXEC_FBC_EXACTISH_SCAN(CoNd)                     \
1075 STMT_START {                                              \
1076     while (s <= e) {                                      \
1077         if ( (CoNd)                                       \
1078              && (ln == 1 || !(OP(c) == EXACTF             \
1079                               ? ibcmp(s, m, ln)           \
1080                               : ibcmp_locale(s, m, ln)))  \
1081              && (!reginfo || regtry(reginfo, &s)) )        \
1082             goto got_it;                                  \
1083         s++;                                              \
1084     }                                                     \
1085 } STMT_END
1086
1087 #define REXEC_FBC_UTF8_SCAN(CoDe)                     \
1088 STMT_START {                                          \
1089     while (s + (uskip = UTF8SKIP(s)) <= strend) {     \
1090         CoDe                                          \
1091         s += uskip;                                   \
1092     }                                                 \
1093 } STMT_END
1094
1095 #define REXEC_FBC_SCAN(CoDe)                          \
1096 STMT_START {                                          \
1097     while (s < strend) {                              \
1098         CoDe                                          \
1099         s++;                                          \
1100     }                                                 \
1101 } STMT_END
1102
1103 #define REXEC_FBC_UTF8_CLASS_SCAN(CoNd)               \
1104 REXEC_FBC_UTF8_SCAN(                                  \
1105     if (CoNd) {                                       \
1106         if (tmp && (!reginfo || regtry(reginfo, &s)))  \
1107             goto got_it;                              \
1108         else                                          \
1109             tmp = doevery;                            \
1110     }                                                 \
1111     else                                              \
1112         tmp = 1;                                      \
1113 )
1114
1115 #define REXEC_FBC_CLASS_SCAN(CoNd)                    \
1116 REXEC_FBC_SCAN(                                       \
1117     if (CoNd) {                                       \
1118         if (tmp && (!reginfo || regtry(reginfo, &s)))  \
1119             goto got_it;                              \
1120         else                                          \
1121             tmp = doevery;                            \
1122     }                                                 \
1123     else                                              \
1124         tmp = 1;                                      \
1125 )
1126
1127 #define REXEC_FBC_TRYIT               \
1128 if ((!reginfo || regtry(reginfo, &s))) \
1129     goto got_it
1130
1131 #define REXEC_FBC_CSCAN(CoNdUtF8,CoNd)                         \
1132     if (do_utf8) {                                             \
1133         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1134     }                                                          \
1135     else {                                                     \
1136         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1137     }                                                          \
1138     break
1139     
1140 #define REXEC_FBC_CSCAN_PRELOAD(UtFpReLoAd,CoNdUtF8,CoNd)      \
1141     if (do_utf8) {                                             \
1142         UtFpReLoAd;                                            \
1143         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1144     }                                                          \
1145     else {                                                     \
1146         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1147     }                                                          \
1148     break
1149
1150 #define REXEC_FBC_CSCAN_TAINT(CoNdUtF8,CoNd)                   \
1151     PL_reg_flags |= RF_tainted;                                \
1152     if (do_utf8) {                                             \
1153         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1154     }                                                          \
1155     else {                                                     \
1156         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1157     }                                                          \
1158     break
1159
1160 #define DUMP_EXEC_POS(li,s,doutf8) \
1161     dump_exec_pos(li,s,(PL_regeol),(PL_bostr),(PL_reg_starttry),doutf8)
1162
1163 /* We know what class REx starts with.  Try to find this position... */
1164 /* if reginfo is NULL, its a dryrun */
1165 /* annoyingly all the vars in this routine have different names from their counterparts
1166    in regmatch. /grrr */
1167
1168 STATIC char *
1169 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, 
1170     const char *strend, regmatch_info *reginfo)
1171 {
1172         dVAR;
1173         const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
1174         char *m;
1175         STRLEN ln;
1176         STRLEN lnc;
1177         register STRLEN uskip;
1178         unsigned int c1;
1179         unsigned int c2;
1180         char *e;
1181         register I32 tmp = 1;   /* Scratch variable? */
1182         register const bool do_utf8 = PL_reg_match_utf8;
1183         RXi_GET_DECL(prog,progi);
1184         
1185         /* We know what class it must start with. */
1186         switch (OP(c)) {
1187         case ANYOF:
1188             if (do_utf8) {
1189                  REXEC_FBC_UTF8_CLASS_SCAN((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
1190                           !UTF8_IS_INVARIANT((U8)s[0]) ?
1191                           reginclass(prog, c, (U8*)s, 0, do_utf8) :
1192                           REGINCLASS(prog, c, (U8*)s));
1193             }
1194             else {
1195                  while (s < strend) {
1196                       STRLEN skip = 1;
1197
1198                       if (REGINCLASS(prog, c, (U8*)s) ||
1199                           (ANYOF_FOLD_SHARP_S(c, s, strend) &&
1200                            /* The assignment of 2 is intentional:
1201                             * for the folded sharp s, the skip is 2. */
1202                            (skip = SHARP_S_SKIP))) {
1203                            if (tmp && (!reginfo || regtry(reginfo, &s)))
1204                                 goto got_it;
1205                            else
1206                                 tmp = doevery;
1207                       }
1208                       else 
1209                            tmp = 1;
1210                       s += skip;
1211                  }
1212             }
1213             break;
1214         case CANY:
1215             REXEC_FBC_SCAN(
1216                 if (tmp && (!reginfo || regtry(reginfo, &s)))
1217                     goto got_it;
1218                 else
1219                     tmp = doevery;
1220             );
1221             break;
1222         case EXACTF:
1223             m   = STRING(c);
1224             ln  = STR_LEN(c);   /* length to match in octets/bytes */
1225             lnc = (I32) ln;     /* length to match in characters */
1226             if (UTF) {
1227                 STRLEN ulen1, ulen2;
1228                 U8 *sm = (U8 *) m;
1229                 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
1230                 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
1231                 /* used by commented-out code below */
1232                 /*const U32 uniflags = UTF8_ALLOW_DEFAULT;*/
1233                 
1234                 /* XXX: Since the node will be case folded at compile
1235                    time this logic is a little odd, although im not 
1236                    sure that its actually wrong. --dmq */
1237                    
1238                 c1 = to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1239                 c2 = to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1240
1241                 /* XXX: This is kinda strange. to_utf8_XYZ returns the 
1242                    codepoint of the first character in the converted
1243                    form, yet originally we did the extra step. 
1244                    No tests fail by commenting this code out however
1245                    so Ive left it out. -- dmq.
1246                    
1247                 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE, 
1248                                     0, uniflags);
1249                 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
1250                                     0, uniflags);
1251                 */
1252                 
1253                 lnc = 0;
1254                 while (sm < ((U8 *) m + ln)) {
1255                     lnc++;
1256                     sm += UTF8SKIP(sm);
1257                 }
1258             }
1259             else {
1260                 c1 = *(U8*)m;
1261                 c2 = PL_fold[c1];
1262             }
1263             goto do_exactf;
1264         case EXACTFL:
1265             m   = STRING(c);
1266             ln  = STR_LEN(c);
1267             lnc = (I32) ln;
1268             c1 = *(U8*)m;
1269             c2 = PL_fold_locale[c1];
1270           do_exactf:
1271             e = HOP3c(strend, -((I32)lnc), s);
1272
1273             if (!reginfo && e < s)
1274                 e = s;                  /* Due to minlen logic of intuit() */
1275
1276             /* The idea in the EXACTF* cases is to first find the
1277              * first character of the EXACTF* node and then, if
1278              * necessary, case-insensitively compare the full
1279              * text of the node.  The c1 and c2 are the first
1280              * characters (though in Unicode it gets a bit
1281              * more complicated because there are more cases
1282              * than just upper and lower: one needs to use
1283              * the so-called folding case for case-insensitive
1284              * matching (called "loose matching" in Unicode).
1285              * ibcmp_utf8() will do just that. */
1286
1287             if (do_utf8 || UTF) {
1288                 UV c, f;
1289                 U8 tmpbuf [UTF8_MAXBYTES+1];
1290                 STRLEN len = 1;
1291                 STRLEN foldlen;
1292                 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1293                 if (c1 == c2) {
1294                     /* Upper and lower of 1st char are equal -
1295                      * probably not a "letter". */
1296                     while (s <= e) {
1297                         if (do_utf8) {
1298                             c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1299                                            uniflags);
1300                         } else {
1301                             c = *((U8*)s);
1302                         }                                         
1303                         REXEC_FBC_EXACTISH_CHECK(c == c1);
1304                     }
1305                 }
1306                 else {
1307                     while (s <= e) {
1308                         if (do_utf8) {
1309                             c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1310                                            uniflags);
1311                         } else {
1312                             c = *((U8*)s);
1313                         }
1314
1315                         /* Handle some of the three Greek sigmas cases.
1316                          * Note that not all the possible combinations
1317                          * are handled here: some of them are handled
1318                          * by the standard folding rules, and some of
1319                          * them (the character class or ANYOF cases)
1320                          * are handled during compiletime in
1321                          * regexec.c:S_regclass(). */
1322                         if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1323                             c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1324                             c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1325
1326                         REXEC_FBC_EXACTISH_CHECK(c == c1 || c == c2);
1327                     }
1328                 }
1329             }
1330             else {
1331                 /* Neither pattern nor string are UTF8 */
1332                 if (c1 == c2)
1333                     REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1334                 else
1335                     REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1336             }
1337             break;
1338         case BOUNDL:
1339             PL_reg_flags |= RF_tainted;
1340             /* FALL THROUGH */
1341         case BOUND:
1342             if (do_utf8) {
1343                 if (s == PL_bostr)
1344                     tmp = '\n';
1345                 else {
1346                     U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1347                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1348                 }
1349                 tmp = ((OP(c) == BOUND ?
1350                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1351                 LOAD_UTF8_CHARCLASS_ALNUM();
1352                 REXEC_FBC_UTF8_SCAN(
1353                     if (tmp == !(OP(c) == BOUND ?
1354                                  (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1355                                  isALNUM_LC_utf8((U8*)s)))
1356                     {
1357                         tmp = !tmp;
1358                         REXEC_FBC_TRYIT;
1359                 }
1360                 );
1361             }
1362             else {
1363                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1364                 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1365                 REXEC_FBC_SCAN(
1366                     if (tmp ==
1367                         !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1368                         tmp = !tmp;
1369                         REXEC_FBC_TRYIT;
1370                 }
1371                 );
1372             }
1373             if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, &s)))
1374                 goto got_it;
1375             break;
1376         case NBOUNDL:
1377             PL_reg_flags |= RF_tainted;
1378             /* FALL THROUGH */
1379         case NBOUND:
1380             if (do_utf8) {
1381                 if (s == PL_bostr)
1382                     tmp = '\n';
1383                 else {
1384                     U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1385                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1386                 }
1387                 tmp = ((OP(c) == NBOUND ?
1388                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1389                 LOAD_UTF8_CHARCLASS_ALNUM();
1390                 REXEC_FBC_UTF8_SCAN(
1391                     if (tmp == !(OP(c) == NBOUND ?
1392                                  (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1393                                  isALNUM_LC_utf8((U8*)s)))
1394                         tmp = !tmp;
1395                     else REXEC_FBC_TRYIT;
1396                 );
1397             }
1398             else {
1399                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1400                 tmp = ((OP(c) == NBOUND ?
1401                         isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1402                 REXEC_FBC_SCAN(
1403                     if (tmp ==
1404                         !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1405                         tmp = !tmp;
1406                     else REXEC_FBC_TRYIT;
1407                 );
1408             }
1409             if ((!prog->minlen && !tmp) && (!reginfo || regtry(reginfo, &s)))
1410                 goto got_it;
1411             break;
1412         case ALNUM:
1413             REXEC_FBC_CSCAN_PRELOAD(
1414                 LOAD_UTF8_CHARCLASS_ALNUM(),
1415                 swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8),
1416                 isALNUM(*s)
1417             );
1418         case ALNUML:
1419             REXEC_FBC_CSCAN_TAINT(
1420                 isALNUM_LC_utf8((U8*)s),
1421                 isALNUM_LC(*s)
1422             );
1423         case NALNUM:
1424             REXEC_FBC_CSCAN_PRELOAD(
1425                 LOAD_UTF8_CHARCLASS_ALNUM(),
1426                 !swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8),
1427                 !isALNUM(*s)
1428             );
1429         case NALNUML:
1430             REXEC_FBC_CSCAN_TAINT(
1431                 !isALNUM_LC_utf8((U8*)s),
1432                 !isALNUM_LC(*s)
1433             );
1434         case SPACE:
1435             REXEC_FBC_CSCAN_PRELOAD(
1436                 LOAD_UTF8_CHARCLASS_SPACE(),
1437                 *s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8),
1438                 isSPACE(*s)
1439             );
1440         case SPACEL:
1441             REXEC_FBC_CSCAN_TAINT(
1442                 *s == ' ' || isSPACE_LC_utf8((U8*)s),
1443                 isSPACE_LC(*s)
1444             );
1445         case NSPACE:
1446             REXEC_FBC_CSCAN_PRELOAD(
1447                 LOAD_UTF8_CHARCLASS_SPACE(),
1448                 !(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)),
1449                 !isSPACE(*s)
1450             );
1451         case NSPACEL:
1452             REXEC_FBC_CSCAN_TAINT(
1453                 !(*s == ' ' || isSPACE_LC_utf8((U8*)s)),
1454                 !isSPACE_LC(*s)
1455             );
1456         case DIGIT:
1457             REXEC_FBC_CSCAN_PRELOAD(
1458                 LOAD_UTF8_CHARCLASS_DIGIT(),
1459                 swash_fetch(PL_utf8_digit,(U8*)s, do_utf8),
1460                 isDIGIT(*s)
1461             );
1462         case DIGITL:
1463             REXEC_FBC_CSCAN_TAINT(
1464                 isDIGIT_LC_utf8((U8*)s),
1465                 isDIGIT_LC(*s)
1466             );
1467         case NDIGIT:
1468             REXEC_FBC_CSCAN_PRELOAD(
1469                 LOAD_UTF8_CHARCLASS_DIGIT(),
1470                 !swash_fetch(PL_utf8_digit,(U8*)s, do_utf8),
1471                 !isDIGIT(*s)
1472             );
1473         case NDIGITL:
1474             REXEC_FBC_CSCAN_TAINT(
1475                 !isDIGIT_LC_utf8((U8*)s),
1476                 !isDIGIT_LC(*s)
1477             );
1478         case LNBREAK:
1479             REXEC_FBC_CSCAN(
1480                 is_LNBREAK_utf8(s),
1481                 is_LNBREAK_latin1(s)
1482             );
1483         case VERTWS:
1484             REXEC_FBC_CSCAN(
1485                 is_VERTWS_utf8(s),
1486                 is_VERTWS_latin1(s)
1487             );
1488         case NVERTWS:
1489             REXEC_FBC_CSCAN(
1490                 !is_VERTWS_utf8(s),
1491                 !is_VERTWS_latin1(s)
1492             );
1493         case HORIZWS:
1494             REXEC_FBC_CSCAN(
1495                 is_HORIZWS_utf8(s),
1496                 is_HORIZWS_latin1(s)
1497             );
1498         case NHORIZWS:
1499             REXEC_FBC_CSCAN(
1500                 !is_HORIZWS_utf8(s),
1501                 !is_HORIZWS_latin1(s)
1502             );      
1503         case AHOCORASICKC:
1504         case AHOCORASICK: 
1505             {
1506                 DECL_TRIE_TYPE(c);
1507                 /* what trie are we using right now */
1508                 reg_ac_data *aho
1509                     = (reg_ac_data*)progi->data->data[ ARG( c ) ];
1510                 reg_trie_data *trie
1511                     = (reg_trie_data*)progi->data->data[ aho->trie ];
1512                 HV *widecharmap = (HV*) progi->data->data[ aho->trie + 1 ];
1513
1514                 const char *last_start = strend - trie->minlen;
1515 #ifdef DEBUGGING
1516                 const char *real_start = s;
1517 #endif
1518                 STRLEN maxlen = trie->maxlen;
1519                 SV *sv_points;
1520                 U8 **points; /* map of where we were in the input string
1521                                 when reading a given char. For ASCII this
1522                                 is unnecessary overhead as the relationship
1523                                 is always 1:1, but for Unicode, especially
1524                                 case folded Unicode this is not true. */
1525                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1526                 U8 *bitmap=NULL;
1527
1528
1529                 GET_RE_DEBUG_FLAGS_DECL;
1530
1531                 /* We can't just allocate points here. We need to wrap it in
1532                  * an SV so it gets freed properly if there is a croak while
1533                  * running the match */
1534                 ENTER;
1535                 SAVETMPS;
1536                 sv_points=newSV(maxlen * sizeof(U8 *));
1537                 SvCUR_set(sv_points,
1538                     maxlen * sizeof(U8 *));
1539                 SvPOK_on(sv_points);
1540                 sv_2mortal(sv_points);
1541                 points=(U8**)SvPV_nolen(sv_points );
1542                 if ( trie_type != trie_utf8_fold 
1543                      && (trie->bitmap || OP(c)==AHOCORASICKC) ) 
1544                 {
1545                     if (trie->bitmap) 
1546                         bitmap=(U8*)trie->bitmap;
1547                     else
1548                         bitmap=(U8*)ANYOF_BITMAP(c);
1549                 }
1550                 /* this is the Aho-Corasick algorithm modified a touch
1551                    to include special handling for long "unknown char" 
1552                    sequences. The basic idea being that we use AC as long
1553                    as we are dealing with a possible matching char, when
1554                    we encounter an unknown char (and we have not encountered
1555                    an accepting state) we scan forward until we find a legal 
1556                    starting char. 
1557                    AC matching is basically that of trie matching, except
1558                    that when we encounter a failing transition, we fall back
1559                    to the current states "fail state", and try the current char 
1560                    again, a process we repeat until we reach the root state, 
1561                    state 1, or a legal transition. If we fail on the root state 
1562                    then we can either terminate if we have reached an accepting 
1563                    state previously, or restart the entire process from the beginning 
1564                    if we have not.
1565
1566                  */
1567                 while (s <= last_start) {
1568                     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1569                     U8 *uc = (U8*)s;
1570                     U16 charid = 0;
1571                     U32 base = 1;
1572                     U32 state = 1;
1573                     UV uvc = 0;
1574                     STRLEN len = 0;
1575                     STRLEN foldlen = 0;
1576                     U8 *uscan = (U8*)NULL;
1577                     U8 *leftmost = NULL;
1578 #ifdef DEBUGGING                    
1579                     U32 accepted_word= 0;
1580 #endif
1581                     U32 pointpos = 0;
1582
1583                     while ( state && uc <= (U8*)strend ) {
1584                         int failed=0;
1585                         U32 word = aho->states[ state ].wordnum;
1586
1587                         if( state==1 ) {
1588                             if ( bitmap ) {
1589                                 DEBUG_TRIE_EXECUTE_r(
1590                                     if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1591                                         dump_exec_pos( (char *)uc, c, strend, real_start, 
1592                                             (char *)uc, do_utf8 );
1593                                         PerlIO_printf( Perl_debug_log,
1594                                             " Scanning for legal start char...\n");
1595                                     }
1596                                 );            
1597                                 while ( uc <= (U8*)last_start  && !BITMAP_TEST(bitmap,*uc) ) {
1598                                     uc++;
1599                                 }
1600                                 s= (char *)uc;
1601                             }
1602                             if (uc >(U8*)last_start) break;
1603                         }
1604                                             
1605                         if ( word ) {
1606                             U8 *lpos= points[ (pointpos - trie->wordlen[word-1] ) % maxlen ];
1607                             if (!leftmost || lpos < leftmost) {
1608                                 DEBUG_r(accepted_word=word);
1609                                 leftmost= lpos;
1610                             }
1611                             if (base==0) break;
1612                             
1613                         }
1614                         points[pointpos++ % maxlen]= uc;
1615                         REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
1616                                              uscan, len, uvc, charid, foldlen,
1617                                              foldbuf, uniflags);
1618                         DEBUG_TRIE_EXECUTE_r({
1619                             dump_exec_pos( (char *)uc, c, strend, real_start, 
1620                                 s,   do_utf8 );
1621                             PerlIO_printf(Perl_debug_log,
1622                                 " Charid:%3u CP:%4"UVxf" ",
1623                                  charid, uvc);
1624                         });
1625
1626                         do {
1627 #ifdef DEBUGGING
1628                             word = aho->states[ state ].wordnum;
1629 #endif
1630                             base = aho->states[ state ].trans.base;
1631
1632                             DEBUG_TRIE_EXECUTE_r({
1633                                 if (failed) 
1634                                     dump_exec_pos( (char *)uc, c, strend, real_start, 
1635                                         s,   do_utf8 );
1636                                 PerlIO_printf( Perl_debug_log,
1637                                     "%sState: %4"UVxf", word=%"UVxf,
1638                                     failed ? " Fail transition to " : "",
1639                                     (UV)state, (UV)word);
1640                             });
1641                             if ( base ) {
1642                                 U32 tmp;
1643                                 if (charid &&
1644                                      (base + charid > trie->uniquecharcount )
1645                                      && (base + charid - 1 - trie->uniquecharcount
1646                                             < trie->lasttrans)
1647                                      && trie->trans[base + charid - 1 -
1648                                             trie->uniquecharcount].check == state
1649                                      && (tmp=trie->trans[base + charid - 1 -
1650                                         trie->uniquecharcount ].next))
1651                                 {
1652                                     DEBUG_TRIE_EXECUTE_r(
1653                                         PerlIO_printf( Perl_debug_log," - legal\n"));
1654                                     state = tmp;
1655                                     break;
1656                                 }
1657                                 else {
1658                                     DEBUG_TRIE_EXECUTE_r(
1659                                         PerlIO_printf( Perl_debug_log," - fail\n"));
1660                                     failed = 1;
1661                                     state = aho->fail[state];
1662                                 }
1663                             }
1664                             else {
1665                                 /* we must be accepting here */
1666                                 DEBUG_TRIE_EXECUTE_r(
1667                                         PerlIO_printf( Perl_debug_log," - accepting\n"));
1668                                 failed = 1;
1669                                 break;
1670                             }
1671                         } while(state);
1672                         uc += len;
1673                         if (failed) {
1674                             if (leftmost)
1675                                 break;
1676                             if (!state) state = 1;
1677                         }
1678                     }
1679                     if ( aho->states[ state ].wordnum ) {
1680                         U8 *lpos = points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1]) % maxlen ];
1681                         if (!leftmost || lpos < leftmost) {
1682                             DEBUG_r(accepted_word=aho->states[ state ].wordnum);
1683                             leftmost = lpos;
1684                         }
1685                     }
1686                     if (leftmost) {
1687                         s = (char*)leftmost;
1688                         DEBUG_TRIE_EXECUTE_r({
1689                             PerlIO_printf( 
1690                                 Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
1691                                 (UV)accepted_word, (IV)(s - real_start)
1692                             );
1693                         });
1694                         if (!reginfo || regtry(reginfo, &s)) {
1695                             FREETMPS;
1696                             LEAVE;
1697                             goto got_it;
1698                         }
1699                         s = HOPc(s,1);
1700                         DEBUG_TRIE_EXECUTE_r({
1701                             PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
1702                         });
1703                     } else {
1704                         DEBUG_TRIE_EXECUTE_r(
1705                             PerlIO_printf( Perl_debug_log,"No match.\n"));
1706                         break;
1707                     }
1708                 }
1709                 FREETMPS;
1710                 LEAVE;
1711             }
1712             break;
1713         default:
1714             Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1715             break;
1716         }
1717         return 0;
1718       got_it:
1719         return s;
1720 }
1721
1722 static void 
1723 S_swap_match_buff (pTHX_ regexp *prog) {
1724     regexp_paren_pair *t;
1725
1726     if (!prog->swap) {
1727     /* We have to be careful. If the previous successful match
1728        was from this regex we don't want a subsequent paritally
1729        successful match to clobber the old results. 
1730        So when we detect this possibility we add a swap buffer
1731        to the re, and switch the buffer each match. If we fail
1732        we switch it back, otherwise we leave it swapped.
1733     */
1734         Newxz(prog->swap, (prog->nparens + 1), regexp_paren_pair);
1735     }
1736     t = prog->swap;
1737     prog->swap = prog->offs;
1738     prog->offs = t;
1739 }    
1740
1741
1742 /*
1743  - regexec_flags - match a regexp against a string
1744  */
1745 I32
1746 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *strend,
1747               char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1748 /* strend: pointer to null at end of string */
1749 /* strbeg: real beginning of string */
1750 /* minend: end of match must be >=minend after stringarg. */
1751 /* data: May be used for some additional optimizations. 
1752          Currently its only used, with a U32 cast, for transmitting 
1753          the ganch offset when doing a /g match. This will change */
1754 /* nosave: For optimizations. */
1755 {
1756     dVAR;
1757     struct regexp *const prog = (struct regexp *)SvANY(rx);
1758     /*register*/ char *s;
1759     register regnode *c;
1760     /*register*/ char *startpos = stringarg;
1761     I32 minlen;         /* must match at least this many chars */
1762     I32 dontbother = 0; /* how many characters not to try at end */
1763     I32 end_shift = 0;                  /* Same for the end. */         /* CC */
1764     I32 scream_pos = -1;                /* Internal iterator of scream. */
1765     char *scream_olds = NULL;
1766     const bool do_utf8 = (bool)DO_UTF8(sv);
1767     I32 multiline;
1768     RXi_GET_DECL(prog,progi);
1769     regmatch_info reginfo;  /* create some info to pass to regtry etc */
1770     bool swap_on_fail = 0;
1771
1772     GET_RE_DEBUG_FLAGS_DECL;
1773
1774     PERL_UNUSED_ARG(data);
1775
1776     /* Be paranoid... */
1777     if (prog == NULL || startpos == NULL) {
1778         Perl_croak(aTHX_ "NULL regexp parameter");
1779         return 0;
1780     }
1781
1782     multiline = prog->extflags & RXf_PMf_MULTILINE;
1783     reginfo.prog = rx;   /* Yes, sorry that this is confusing.  */
1784
1785     RX_MATCH_UTF8_set(rx, do_utf8);
1786     DEBUG_EXECUTE_r( 
1787         debug_start_match(rx, do_utf8, startpos, strend, 
1788         "Matching");
1789     );
1790
1791     minlen = prog->minlen;
1792     
1793     if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
1794         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1795                               "String too short [regexec_flags]...\n"));
1796         goto phooey;
1797     }
1798
1799     
1800     /* Check validity of program. */
1801     if (UCHARAT(progi->program) != REG_MAGIC) {
1802         Perl_croak(aTHX_ "corrupted regexp program");
1803     }
1804
1805     PL_reg_flags = 0;
1806     PL_reg_eval_set = 0;
1807     PL_reg_maxiter = 0;
1808
1809     if (RX_UTF8(rx))
1810         PL_reg_flags |= RF_utf8;
1811
1812     /* Mark beginning of line for ^ and lookbehind. */
1813     reginfo.bol = startpos; /* XXX not used ??? */
1814     PL_bostr  = strbeg;
1815     reginfo.sv = sv;
1816
1817     /* Mark end of line for $ (and such) */
1818     PL_regeol = strend;
1819
1820     /* see how far we have to get to not match where we matched before */
1821     reginfo.till = startpos+minend;
1822
1823     /* If there is a "must appear" string, look for it. */
1824     s = startpos;
1825
1826     if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
1827         MAGIC *mg;
1828
1829         if (flags & REXEC_IGNOREPOS)    /* Means: check only at start */
1830             reginfo.ganch = startpos + prog->gofs;
1831         else if (sv && SvTYPE(sv) >= SVt_PVMG
1832                   && SvMAGIC(sv)
1833                   && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1834                   && mg->mg_len >= 0) {
1835             reginfo.ganch = strbeg + mg->mg_len;        /* Defined pos() */
1836             if (prog->extflags & RXf_ANCH_GPOS) {
1837                 if (s > reginfo.ganch)
1838                     goto phooey;
1839                 s = reginfo.ganch - prog->gofs;
1840             }
1841         }
1842         else if (data) {
1843             reginfo.ganch = strbeg + PTR2UV(data);
1844         } else                          /* pos() not defined */
1845             reginfo.ganch = strbeg;
1846     }
1847     if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
1848         swap_on_fail = 1;
1849         swap_match_buff(prog); /* do we need a save destructor here for
1850                                   eval dies? */
1851     }
1852     if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
1853         re_scream_pos_data d;
1854
1855         d.scream_olds = &scream_olds;
1856         d.scream_pos = &scream_pos;
1857         s = re_intuit_start(rx, sv, s, strend, flags, &d);
1858         if (!s) {
1859             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1860             goto phooey;        /* not present */
1861         }
1862     }
1863
1864
1865
1866     /* Simplest case:  anchored match need be tried only once. */
1867     /*  [unless only anchor is BOL and multiline is set] */
1868     if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {
1869         if (s == startpos && regtry(&reginfo, &startpos))
1870             goto got_it;
1871         else if (multiline || (prog->intflags & PREGf_IMPLICIT)
1872                  || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
1873         {
1874             char *end;
1875
1876             if (minlen)
1877                 dontbother = minlen - 1;
1878             end = HOP3c(strend, -dontbother, strbeg) - 1;
1879             /* for multiline we only have to try after newlines */
1880             if (prog->check_substr || prog->check_utf8) {
1881                 if (s == startpos)
1882                     goto after_try;
1883                 while (1) {
1884                     if (regtry(&reginfo, &s))
1885                         goto got_it;
1886                   after_try:
1887                     if (s > end)
1888                         goto phooey;
1889                     if (prog->extflags & RXf_USE_INTUIT) {
1890                         s = re_intuit_start(rx, sv, s + 1, strend, flags, NULL);
1891                         if (!s)
1892                             goto phooey;
1893                     }
1894                     else
1895                         s++;
1896                 }               
1897             } else {
1898                 if (s > startpos)
1899                     s--;
1900                 while (s < end) {
1901                     if (*s++ == '\n') { /* don't need PL_utf8skip here */
1902                         if (regtry(&reginfo, &s))
1903                             goto got_it;
1904                     }
1905                 }               
1906             }
1907         }
1908         goto phooey;
1909     } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK)) 
1910     {
1911         /* the warning about reginfo.ganch being used without intialization
1912            is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN 
1913            and we only enter this block when the same bit is set. */
1914         char *tmp_s = reginfo.ganch - prog->gofs;
1915         if (regtry(&reginfo, &tmp_s))
1916             goto got_it;
1917         goto phooey;
1918     }
1919
1920     /* Messy cases:  unanchored match. */
1921     if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
1922         /* we have /x+whatever/ */
1923         /* it must be a one character string (XXXX Except UTF?) */
1924         char ch;
1925 #ifdef DEBUGGING
1926         int did_match = 0;
1927 #endif
1928         if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1929             do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1930         ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
1931
1932         if (do_utf8) {
1933             REXEC_FBC_SCAN(
1934                 if (*s == ch) {
1935                     DEBUG_EXECUTE_r( did_match = 1 );
1936                     if (regtry(&reginfo, &s)) goto got_it;
1937                     s += UTF8SKIP(s);
1938                     while (s < strend && *s == ch)
1939                         s += UTF8SKIP(s);
1940                 }
1941             );
1942         }
1943         else {
1944             REXEC_FBC_SCAN(
1945                 if (*s == ch) {
1946                     DEBUG_EXECUTE_r( did_match = 1 );
1947                     if (regtry(&reginfo, &s)) goto got_it;
1948                     s++;
1949                     while (s < strend && *s == ch)
1950                         s++;
1951                 }
1952             );
1953         }
1954         DEBUG_EXECUTE_r(if (!did_match)
1955                 PerlIO_printf(Perl_debug_log,
1956                                   "Did not find anchored character...\n")
1957                );
1958     }
1959     else if (prog->anchored_substr != NULL
1960               || prog->anchored_utf8 != NULL
1961               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
1962                   && prog->float_max_offset < strend - s)) {
1963         SV *must;
1964         I32 back_max;
1965         I32 back_min;
1966         char *last;
1967         char *last1;            /* Last position checked before */
1968 #ifdef DEBUGGING
1969         int did_match = 0;
1970 #endif
1971         if (prog->anchored_substr || prog->anchored_utf8) {
1972             if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1973                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1974             must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
1975             back_max = back_min = prog->anchored_offset;
1976         } else {
1977             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1978                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1979             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
1980             back_max = prog->float_max_offset;
1981             back_min = prog->float_min_offset;
1982         }
1983         
1984             
1985         if (must == &PL_sv_undef)
1986             /* could not downgrade utf8 check substring, so must fail */
1987             goto phooey;
1988
1989         if (back_min<0) {
1990             last = strend;
1991         } else {
1992             last = HOP3c(strend,        /* Cannot start after this */
1993                   -(I32)(CHR_SVLEN(must)
1994                          - (SvTAIL(must) != 0) + back_min), strbeg);
1995         }
1996         if (s > PL_bostr)
1997             last1 = HOPc(s, -1);
1998         else
1999             last1 = s - 1;      /* bogus */
2000
2001         /* XXXX check_substr already used to find "s", can optimize if
2002            check_substr==must. */
2003         scream_pos = -1;
2004         dontbother = end_shift;
2005         strend = HOPc(strend, -dontbother);
2006         while ( (s <= last) &&
2007                 ((flags & REXEC_SCREAM)
2008                  ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
2009                                     end_shift, &scream_pos, 0))
2010                  : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
2011                                   (unsigned char*)strend, must,
2012                                   multiline ? FBMrf_MULTILINE : 0))) ) {
2013             /* we may be pointing at the wrong string */
2014             if ((flags & REXEC_SCREAM) && RXp_MATCH_COPIED(prog))
2015                 s = strbeg + (s - SvPVX_const(sv));
2016             DEBUG_EXECUTE_r( did_match = 1 );
2017             if (HOPc(s, -back_max) > last1) {
2018                 last1 = HOPc(s, -back_min);
2019                 s = HOPc(s, -back_max);
2020             }
2021             else {
2022                 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
2023
2024                 last1 = HOPc(s, -back_min);
2025                 s = t;
2026             }
2027             if (do_utf8) {
2028                 while (s <= last1) {
2029                     if (regtry(&reginfo, &s))
2030                         goto got_it;
2031                     s += UTF8SKIP(s);
2032                 }
2033             }
2034             else {
2035                 while (s <= last1) {
2036                     if (regtry(&reginfo, &s))
2037                         goto got_it;
2038                     s++;
2039                 }
2040             }
2041         }
2042         DEBUG_EXECUTE_r(if (!did_match) {
2043             RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0), 
2044                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
2045             PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
2046                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
2047                                ? "anchored" : "floating"),
2048                 quoted, RE_SV_TAIL(must));
2049         });                 
2050         goto phooey;
2051     }
2052     else if ( (c = progi->regstclass) ) {
2053         if (minlen) {
2054             const OPCODE op = OP(progi->regstclass);
2055             /* don't bother with what can't match */
2056             if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
2057                 strend = HOPc(strend, -(minlen - 1));
2058         }
2059         DEBUG_EXECUTE_r({
2060             SV * const prop = sv_newmortal();
2061             regprop(prog, prop, c);
2062             {
2063                 RE_PV_QUOTED_DECL(quoted,do_utf8,PERL_DEBUG_PAD_ZERO(1),
2064                     s,strend-s,60);
2065                 PerlIO_printf(Perl_debug_log,
2066                     "Matching stclass %.*s against %s (%d chars)\n",
2067                     (int)SvCUR(prop), SvPVX_const(prop),
2068                      quoted, (int)(strend - s));
2069             }
2070         });
2071         if (find_byclass(prog, c, s, strend, &reginfo))
2072             goto got_it;
2073         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2074     }
2075     else {
2076         dontbother = 0;
2077         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2078             /* Trim the end. */
2079             char *last;
2080             SV* float_real;
2081
2082             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2083                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2084             float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
2085
2086             if (flags & REXEC_SCREAM) {
2087                 last = screaminstr(sv, float_real, s - strbeg,
2088                                    end_shift, &scream_pos, 1); /* last one */
2089                 if (!last)
2090                     last = scream_olds; /* Only one occurrence. */
2091                 /* we may be pointing at the wrong string */
2092                 else if (RXp_MATCH_COPIED(prog))
2093                     s = strbeg + (s - SvPVX_const(sv));
2094             }
2095             else {
2096                 STRLEN len;
2097                 const char * const little = SvPV_const(float_real, len);
2098
2099                 if (SvTAIL(float_real)) {
2100                     if (memEQ(strend - len + 1, little, len - 1))
2101                         last = strend - len + 1;
2102                     else if (!multiline)
2103                         last = memEQ(strend - len, little, len)
2104                             ? strend - len : NULL;
2105                     else
2106                         goto find_last;
2107                 } else {
2108                   find_last:
2109                     if (len)
2110                         last = rninstr(s, strend, little, little + len);
2111                     else
2112                         last = strend;  /* matching "$" */
2113                 }
2114             }
2115             if (last == NULL) {
2116                 DEBUG_EXECUTE_r(
2117                     PerlIO_printf(Perl_debug_log,
2118                         "%sCan't trim the tail, match fails (should not happen)%s\n",
2119                         PL_colors[4], PL_colors[5]));
2120                 goto phooey; /* Should not happen! */
2121             }
2122             dontbother = strend - last + prog->float_min_offset;
2123         }
2124         if (minlen && (dontbother < minlen))
2125             dontbother = minlen - 1;
2126         strend -= dontbother;              /* this one's always in bytes! */
2127         /* We don't know much -- general case. */
2128         if (do_utf8) {
2129             for (;;) {
2130                 if (regtry(&reginfo, &s))
2131                     goto got_it;
2132                 if (s >= strend)
2133                     break;
2134                 s += UTF8SKIP(s);
2135             };
2136         }
2137         else {
2138             do {
2139                 if (regtry(&reginfo, &s))
2140                     goto got_it;
2141             } while (s++ < strend);
2142         }
2143     }
2144
2145     /* Failure. */
2146     goto phooey;
2147
2148 got_it:
2149     RX_MATCH_TAINTED_set(rx, PL_reg_flags & RF_tainted);
2150
2151     if (PL_reg_eval_set)
2152         restore_pos(aTHX_ prog);
2153     if (RXp_PAREN_NAMES(prog)) 
2154         (void)hv_iterinit(RXp_PAREN_NAMES(prog));
2155
2156     /* make sure $`, $&, $', and $digit will work later */
2157     if ( !(flags & REXEC_NOT_FIRST) ) {
2158         RX_MATCH_COPY_FREE(rx);
2159         if (flags & REXEC_COPY_STR) {
2160             const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2161 #ifdef PERL_OLD_COPY_ON_WRITE
2162             if ((SvIsCOW(sv)
2163                  || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2164                 if (DEBUG_C_TEST) {
2165                     PerlIO_printf(Perl_debug_log,
2166                                   "Copy on write: regexp capture, type %d\n",
2167                                   (int) SvTYPE(sv));
2168                 }
2169                 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2170                 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2171                 assert (SvPOKp(prog->saved_copy));
2172             } else
2173 #endif
2174             {
2175                 RX_MATCH_COPIED_on(rx);
2176                 s = savepvn(strbeg, i);
2177                 prog->subbeg = s;
2178             }
2179             prog->sublen = i;
2180         }
2181         else {
2182             prog->subbeg = strbeg;
2183             prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
2184         }
2185     }
2186
2187     return 1;
2188
2189 phooey:
2190     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2191                           PL_colors[4], PL_colors[5]));
2192     if (PL_reg_eval_set)
2193         restore_pos(aTHX_ prog);
2194     if (swap_on_fail) 
2195         /* we failed :-( roll it back */
2196         swap_match_buff(prog);
2197     
2198     return 0;
2199 }
2200
2201
2202 /*
2203  - regtry - try match at specific point
2204  */
2205 STATIC I32                      /* 0 failure, 1 success */
2206 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
2207 {
2208     dVAR;
2209     CHECKPOINT lastcp;
2210     REGEXP *const rx = reginfo->prog;
2211     regexp *const prog = (struct regexp *)SvANY(rx);
2212     RXi_GET_DECL(prog,progi);
2213     GET_RE_DEBUG_FLAGS_DECL;
2214     reginfo->cutpoint=NULL;
2215
2216     if ((prog->extflags & RXf_EVAL_SEEN) && !PL_reg_eval_set) {
2217         MAGIC *mg;
2218
2219         PL_reg_eval_set = RS_init;
2220         DEBUG_EXECUTE_r(DEBUG_s(
2221             PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
2222                           (IV)(PL_stack_sp - PL_stack_base));
2223             ));
2224         SAVESTACK_CXPOS();
2225         cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2226         /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
2227         SAVETMPS;
2228         /* Apparently this is not needed, judging by wantarray. */
2229         /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2230            cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2231
2232         if (reginfo->sv) {
2233             /* Make $_ available to executed code. */
2234             if (reginfo->sv != DEFSV) {
2235                 SAVE_DEFSV;
2236                 DEFSV = reginfo->sv;
2237             }
2238         
2239             if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2240                   && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2241                 /* prepare for quick setting of pos */
2242 #ifdef PERL_OLD_COPY_ON_WRITE
2243                 if (SvIsCOW(reginfo->sv))
2244                     sv_force_normal_flags(reginfo->sv, 0);
2245 #endif
2246                 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2247                                  &PL_vtbl_mglob, NULL, 0);
2248                 mg->mg_len = -1;
2249             }
2250             PL_reg_magic    = mg;
2251             PL_reg_oldpos   = mg->mg_len;
2252             SAVEDESTRUCTOR_X(restore_pos, prog);
2253         }
2254         if (!PL_reg_curpm) {
2255             Newxz(PL_reg_curpm, 1, PMOP);
2256 #ifdef USE_ITHREADS
2257             {
2258                 SV* const repointer = newSViv(0);
2259                 /* so we know which PL_regex_padav element is PL_reg_curpm
2260                    when clearing up in perl_destruct() */
2261                 SvFLAGS(repointer) |= SVf_BREAK;
2262                 av_push(PL_regex_padav,SvREFCNT_inc_simple_NN(repointer));
2263                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2264                 PL_regex_pad = AvARRAY(PL_regex_padav);
2265             }
2266 #endif      
2267         }
2268         PM_SETRE(PL_reg_curpm, rx);
2269         PL_reg_oldcurpm = PL_curpm;
2270         PL_curpm = PL_reg_curpm;
2271         if (RXp_MATCH_COPIED(prog)) {
2272             /*  Here is a serious problem: we cannot rewrite subbeg,
2273                 since it may be needed if this match fails.  Thus
2274                 $` inside (?{}) could fail... */
2275             PL_reg_oldsaved = prog->subbeg;
2276             PL_reg_oldsavedlen = prog->sublen;
2277 #ifdef PERL_OLD_COPY_ON_WRITE
2278             PL_nrs = prog->saved_copy;
2279 #endif
2280             RXp_MATCH_COPIED_off(prog);
2281         }
2282         else
2283             PL_reg_oldsaved = NULL;
2284         prog->subbeg = PL_bostr;
2285         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2286     }
2287     DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
2288     prog->offs[0].start = *startpos - PL_bostr;
2289     PL_reginput = *startpos;
2290     PL_reglastparen = &prog->lastparen;
2291     PL_reglastcloseparen = &prog->lastcloseparen;
2292     prog->lastparen = 0;
2293     prog->lastcloseparen = 0;
2294     PL_regsize = 0;
2295     PL_regoffs = prog->offs;
2296     if (PL_reg_start_tmpl <= prog->nparens) {
2297         PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2298         if(PL_reg_start_tmp)
2299             Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2300         else
2301             Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2302     }
2303
2304     /* XXXX What this code is doing here?!!!  There should be no need
2305        to do this again and again, PL_reglastparen should take care of
2306        this!  --ilya*/
2307
2308     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2309      * Actually, the code in regcppop() (which Ilya may be meaning by
2310      * PL_reglastparen), is not needed at all by the test suite
2311      * (op/regexp, op/pat, op/split), but that code is needed otherwise
2312      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
2313      * Meanwhile, this code *is* needed for the
2314      * above-mentioned test suite tests to succeed.  The common theme
2315      * on those tests seems to be returning null fields from matches.
2316      * --jhi updated by dapm */
2317 #if 1
2318     if (prog->nparens) {
2319         regexp_paren_pair *pp = PL_regoffs;
2320         register I32 i;
2321         for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2322             ++pp;
2323             pp->start = -1;
2324             pp->end = -1;
2325         }
2326     }
2327 #endif
2328     REGCP_SET(lastcp);
2329     if (regmatch(reginfo, progi->program + 1)) {
2330         PL_regoffs[0].end = PL_reginput - PL_bostr;
2331         return 1;
2332     }
2333     if (reginfo->cutpoint)
2334         *startpos= reginfo->cutpoint;
2335     REGCP_UNWIND(lastcp);
2336     return 0;
2337 }
2338
2339
2340 #define sayYES goto yes
2341 #define sayNO goto no
2342 #define sayNO_SILENT goto no_silent
2343
2344 /* we dont use STMT_START/END here because it leads to 
2345    "unreachable code" warnings, which are bogus, but distracting. */
2346 #define CACHEsayNO \
2347     if (ST.cache_mask) \
2348        PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
2349     sayNO
2350
2351 /* this is used to determine how far from the left messages like
2352    'failed...' are printed. It should be set such that messages 
2353    are inline with the regop output that created them.
2354 */
2355 #define REPORT_CODE_OFF 32
2356
2357
2358 /* Make sure there is a test for this +1 options in re_tests */
2359 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2360
2361 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2362 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
2363
2364 #define SLAB_FIRST(s) (&(s)->states[0])
2365 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2366
2367 /* grab a new slab and return the first slot in it */
2368
2369 STATIC regmatch_state *
2370 S_push_slab(pTHX)
2371 {
2372 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2373     dMY_CXT;
2374 #endif
2375     regmatch_slab *s = PL_regmatch_slab->next;
2376     if (!s) {
2377         Newx(s, 1, regmatch_slab);
2378         s->prev = PL_regmatch_slab;
2379         s->next = NULL;
2380         PL_regmatch_slab->next = s;
2381     }
2382     PL_regmatch_slab = s;
2383     return SLAB_FIRST(s);
2384 }
2385
2386
2387 /* push a new state then goto it */
2388
2389 #define PUSH_STATE_GOTO(state, node) \
2390     scan = node; \
2391     st->resume_state = state; \
2392     goto push_state;
2393
2394 /* push a new state with success backtracking, then goto it */
2395
2396 #define PUSH_YES_STATE_GOTO(state, node) \
2397     scan = node; \
2398     st->resume_state = state; \
2399     goto push_yes_state;
2400
2401
2402
2403 /*
2404
2405 regmatch() - main matching routine
2406
2407 This is basically one big switch statement in a loop. We execute an op,
2408 set 'next' to point the next op, and continue. If we come to a point which
2409 we may need to backtrack to on failure such as (A|B|C), we push a
2410 backtrack state onto the backtrack stack. On failure, we pop the top
2411 state, and re-enter the loop at the state indicated. If there are no more
2412 states to pop, we return failure.
2413
2414 Sometimes we also need to backtrack on success; for example /A+/, where
2415 after successfully matching one A, we need to go back and try to
2416 match another one; similarly for lookahead assertions: if the assertion
2417 completes successfully, we backtrack to the state just before the assertion
2418 and then carry on.  In these cases, the pushed state is marked as
2419 'backtrack on success too'. This marking is in fact done by a chain of
2420 pointers, each pointing to the previous 'yes' state. On success, we pop to
2421 the nearest yes state, discarding any intermediate failure-only states.
2422 Sometimes a yes state is pushed just to force some cleanup code to be
2423 called at the end of a successful match or submatch; e.g. (??{$re}) uses
2424 it to free the inner regex.
2425
2426 Note that failure backtracking rewinds the cursor position, while
2427 success backtracking leaves it alone.
2428
2429 A pattern is complete when the END op is executed, while a subpattern
2430 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2431 ops trigger the "pop to last yes state if any, otherwise return true"
2432 behaviour.
2433
2434 A common convention in this function is to use A and B to refer to the two
2435 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2436 the subpattern to be matched possibly multiple times, while B is the entire
2437 rest of the pattern. Variable and state names reflect this convention.
2438
2439 The states in the main switch are the union of ops and failure/success of
2440 substates associated with with that op.  For example, IFMATCH is the op
2441 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2442 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2443 successfully matched A and IFMATCH_A_fail is a state saying that we have
2444 just failed to match A. Resume states always come in pairs. The backtrack
2445 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2446 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2447 on success or failure.
2448
2449 The struct that holds a backtracking state is actually a big union, with
2450 one variant for each major type of op. The variable st points to the
2451 top-most backtrack struct. To make the code clearer, within each
2452 block of code we #define ST to alias the relevant union.
2453
2454 Here's a concrete example of a (vastly oversimplified) IFMATCH
2455 implementation:
2456
2457     switch (state) {
2458     ....
2459
2460 #define ST st->u.ifmatch
2461
2462     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2463         ST.foo = ...; // some state we wish to save
2464         ...
2465         // push a yes backtrack state with a resume value of
2466         // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
2467         // first node of A:
2468         PUSH_YES_STATE_GOTO(IFMATCH_A, A);
2469         // NOTREACHED
2470
2471     case IFMATCH_A: // we have successfully executed A; now continue with B
2472         next = B;
2473         bar = ST.foo; // do something with the preserved value
2474         break;
2475
2476     case IFMATCH_A_fail: // A failed, so the assertion failed
2477         ...;   // do some housekeeping, then ...
2478         sayNO; // propagate the failure
2479
2480 #undef ST
2481
2482     ...
2483     }
2484
2485 For any old-timers reading this who are familiar with the old recursive
2486 approach, the code above is equivalent to:
2487
2488     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2489     {
2490         int foo = ...
2491         ...
2492         if (regmatch(A)) {
2493             next = B;
2494             bar = foo;
2495             break;
2496         }
2497         ...;   // do some housekeeping, then ...
2498         sayNO; // propagate the failure
2499     }
2500
2501 The topmost backtrack state, pointed to by st, is usually free. If you
2502 want to claim it, populate any ST.foo fields in it with values you wish to
2503 save, then do one of
2504
2505         PUSH_STATE_GOTO(resume_state, node);
2506         PUSH_YES_STATE_GOTO(resume_state, node);
2507
2508 which sets that backtrack state's resume value to 'resume_state', pushes a
2509 new free entry to the top of the backtrack stack, then goes to 'node'.
2510 On backtracking, the free slot is popped, and the saved state becomes the
2511 new free state. An ST.foo field in this new top state can be temporarily
2512 accessed to retrieve values, but once the main loop is re-entered, it
2513 becomes available for reuse.
2514
2515 Note that the depth of the backtrack stack constantly increases during the
2516 left-to-right execution of the pattern, rather than going up and down with
2517 the pattern nesting. For example the stack is at its maximum at Z at the
2518 end of the pattern, rather than at X in the following:
2519
2520     /(((X)+)+)+....(Y)+....Z/
2521
2522 The only exceptions to this are lookahead/behind assertions and the cut,
2523 (?>A), which pop all the backtrack states associated with A before
2524 continuing.
2525  
2526 Bascktrack state structs are allocated in slabs of about 4K in size.
2527 PL_regmatch_state and st always point to the currently active state,
2528 and PL_regmatch_slab points to the slab currently containing
2529 PL_regmatch_state.  The first time regmatch() is called, the first slab is
2530 allocated, and is never freed until interpreter destruction. When the slab
2531 is full, a new one is allocated and chained to the end. At exit from
2532 regmatch(), slabs allocated since entry are freed.
2533
2534 */
2535  
2536
2537 #define DEBUG_STATE_pp(pp)                                  \
2538     DEBUG_STATE_r({                                         \
2539         DUMP_EXEC_POS(locinput, scan, do_utf8);             \
2540         PerlIO_printf(Perl_debug_log,                       \
2541             "    %*s"pp" %s%s%s%s%s\n",                     \
2542             depth*2, "",                                    \
2543             PL_reg_name[st->resume_state],                     \
2544             ((st==yes_state||st==mark_state) ? "[" : ""),   \
2545             ((st==yes_state) ? "Y" : ""),                   \
2546             ((st==mark_state) ? "M" : ""),                  \
2547             ((st==yes_state||st==mark_state) ? "]" : "")    \
2548         );                                                  \
2549     });
2550
2551
2552 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2553
2554 #ifdef DEBUGGING
2555
2556 STATIC void
2557 S_debug_start_match(pTHX_ const REGEXP *prog, const bool do_utf8, 
2558     const char *start, const char *end, const char *blurb)
2559 {
2560     const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
2561     if (!PL_colorset)   
2562             reginitcolors();    
2563     {
2564         RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0), 
2565             RX_PRECOMP(prog), RX_PRELEN(prog), 60);   
2566         
2567         RE_PV_QUOTED_DECL(s1, do_utf8, PERL_DEBUG_PAD_ZERO(1), 
2568             start, end - start, 60); 
2569         
2570         PerlIO_printf(Perl_debug_log, 
2571             "%s%s REx%s %s against %s\n", 
2572                        PL_colors[4], blurb, PL_colors[5], s0, s1); 
2573         
2574         if (do_utf8||utf8_pat) 
2575             PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2576                 utf8_pat ? "pattern" : "",
2577                 utf8_pat && do_utf8 ? " and " : "",
2578                 do_utf8 ? "string" : ""
2579             ); 
2580     }
2581 }
2582
2583 STATIC void
2584 S_dump_exec_pos(pTHX_ const char *locinput, 
2585                       const regnode *scan, 
2586                       const char *loc_regeol, 
2587                       const char *loc_bostr, 
2588                       const char *loc_reg_starttry,
2589                       const bool do_utf8)
2590 {
2591     const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
2592     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2593     int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
2594     /* The part of the string before starttry has one color
2595        (pref0_len chars), between starttry and current
2596        position another one (pref_len - pref0_len chars),
2597        after the current position the third one.
2598        We assume that pref0_len <= pref_len, otherwise we
2599        decrease pref0_len.  */
2600     int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2601         ? (5 + taill) - l : locinput - loc_bostr;
2602     int pref0_len;
2603
2604     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2605         pref_len++;
2606     pref0_len = pref_len  - (locinput - loc_reg_starttry);
2607     if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2608         l = ( loc_regeol - locinput > (5 + taill) - pref_len
2609               ? (5 + taill) - pref_len : loc_regeol - locinput);
2610     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2611         l--;
2612     if (pref0_len < 0)
2613         pref0_len = 0;
2614     if (pref0_len > pref_len)
2615         pref0_len = pref_len;
2616     {
2617         const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
2618
2619         RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
2620             (locinput - pref_len),pref0_len, 60, 4, 5);
2621         
2622         RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
2623                     (locinput - pref_len + pref0_len),
2624                     pref_len - pref0_len, 60, 2, 3);
2625         
2626         RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
2627                     locinput, loc_regeol - locinput, 10, 0, 1);
2628
2629         const STRLEN tlen=len0+len1+len2;
2630         PerlIO_printf(Perl_debug_log,
2631                     "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
2632                     (IV)(locinput - loc_bostr),
2633                     len0, s0,
2634                     len1, s1,
2635                     (docolor ? "" : "> <"),
2636                     len2, s2,
2637                     (int)(tlen > 19 ? 0 :  19 - tlen),
2638                     "");
2639     }
2640 }
2641
2642 #endif
2643
2644 /* reg_check_named_buff_matched()
2645  * Checks to see if a named buffer has matched. The data array of 
2646  * buffer numbers corresponding to the buffer is expected to reside
2647  * in the regexp->data->data array in the slot stored in the ARG() of
2648  * node involved. Note that this routine doesn't actually care about the
2649  * name, that information is not preserved from compilation to execution.
2650  * Returns the index of the leftmost defined buffer with the given name
2651  * or 0 if non of the buffers matched.
2652  */
2653 STATIC I32
2654 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan) {
2655     I32 n;
2656     RXi_GET_DECL(rex,rexi);
2657     SV *sv_dat=(SV*)rexi->data->data[ ARG( scan ) ];
2658     I32 *nums=(I32*)SvPVX(sv_dat);
2659     for ( n=0; n<SvIVX(sv_dat); n++ ) {
2660         if ((I32)*PL_reglastparen >= nums[n] &&
2661             PL_regoffs[nums[n]].end != -1)
2662         {
2663             return nums[n];
2664         }
2665     }
2666     return 0;
2667 }
2668
2669
2670 /* free all slabs above current one  - called during LEAVE_SCOPE */
2671
2672 STATIC void
2673 S_clear_backtrack_stack(pTHX_ void *p)
2674 {
2675     regmatch_slab *s = PL_regmatch_slab->next;
2676     PERL_UNUSED_ARG(p);
2677
2678     if (!s)
2679         return;
2680     PL_regmatch_slab->next = NULL;
2681     while (s) {
2682         regmatch_slab * const osl = s;
2683         s = s->next;
2684         Safefree(osl);
2685     }
2686 }
2687
2688
2689 #define SETREX(Re1,Re2) \
2690     if (PL_reg_eval_set) PM_SETRE((PL_reg_curpm), (Re2)); \
2691     Re1 = (Re2)
2692
2693 STATIC I32                      /* 0 failure, 1 success */
2694 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
2695 {
2696 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2697     dMY_CXT;
2698 #endif
2699     dVAR;
2700     register const bool do_utf8 = PL_reg_match_utf8;
2701     const U32 uniflags = UTF8_ALLOW_DEFAULT;
2702
2703     REGEXP *rex_sv = reginfo->prog;
2704     regexp *rex = (struct regexp *)SvANY(rex_sv);
2705     RXi_GET_DECL(rex,rexi);
2706     
2707     I32 oldsave;
2708
2709     /* the current state. This is a cached copy of PL_regmatch_state */
2710     register regmatch_state *st;
2711
2712     /* cache heavy used fields of st in registers */
2713     register regnode *scan;
2714     register regnode *next;
2715     register U32 n = 0; /* general value; init to avoid compiler warning */
2716     register I32 ln = 0; /* len or last;  init to avoid compiler warning */
2717     register char *locinput = PL_reginput;
2718     register I32 nextchr;   /* is always set to UCHARAT(locinput) */
2719
2720     bool result = 0;        /* return value of S_regmatch */
2721     int depth = 0;          /* depth of backtrack stack */
2722     U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
2723     const U32 max_nochange_depth =
2724         (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
2725         3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
2726             
2727     regmatch_state *yes_state = NULL; /* state to pop to on success of
2728                                                             subpattern */
2729     /* mark_state piggy backs on the yes_state logic so that when we unwind 
2730        the stack on success we can update the mark_state as we go */
2731     regmatch_state *mark_state = NULL; /* last mark state we have seen */
2732     
2733     regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
2734     struct regmatch_state  *cur_curlyx = NULL; /* most recent curlyx */
2735     U32 state_num;
2736     bool no_final = 0;      /* prevent failure from backtracking? */
2737     bool do_cutgroup = 0;   /* no_final only until next branch/trie entry */
2738     char *startpoint = PL_reginput;
2739     SV *popmark = NULL;     /* are we looking for a mark? */
2740     SV *sv_commit = NULL;   /* last mark name seen in failure */
2741     SV *sv_yes_mark = NULL; /* last mark name we have seen 
2742                                during a successfull match */
2743     U32 lastopen = 0;       /* last open we saw */
2744     bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;   
2745
2746     SV* const oreplsv = GvSV(PL_replgv);
2747                
2748     
2749     /* these three flags are set by various ops to signal information to
2750      * the very next op. They have a useful lifetime of exactly one loop
2751      * iteration, and are not preserved or restored by state pushes/pops
2752      */
2753     bool sw = 0;            /* the condition value in (?(cond)a|b) */
2754     bool minmod = 0;        /* the next "{n,m}" is a "{n,m}?" */
2755     int logical = 0;        /* the following EVAL is:
2756                                 0: (?{...})
2757                                 1: (?(?{...})X|Y)
2758                                 2: (??{...})
2759                                or the following IFMATCH/UNLESSM is:
2760                                 false: plain (?=foo)
2761                                 true:  used as a condition: (?(?=foo))
2762                             */
2763
2764 #ifdef DEBUGGING
2765     GET_RE_DEBUG_FLAGS_DECL;
2766 #endif
2767
2768     DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
2769             PerlIO_printf(Perl_debug_log,"regmatch start\n");
2770     }));
2771     /* on first ever call to regmatch, allocate first slab */
2772     if (!PL_regmatch_slab) {
2773         Newx(PL_regmatch_slab, 1, regmatch_slab);
2774         PL_regmatch_slab->prev = NULL;
2775         PL_regmatch_slab->next = NULL;
2776         PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2777     }
2778
2779     oldsave = PL_savestack_ix;
2780     SAVEDESTRUCTOR_X(S_clear_backtrack_stack, NULL);
2781     SAVEVPTR(PL_regmatch_slab);
2782     SAVEVPTR(PL_regmatch_state);
2783
2784     /* grab next free state slot */
2785     st = ++PL_regmatch_state;
2786     if (st >  SLAB_LAST(PL_regmatch_slab))
2787         st = PL_regmatch_state = S_push_slab(aTHX);
2788
2789     /* Note that nextchr is a byte even in UTF */
2790     nextchr = UCHARAT(locinput);
2791     scan = prog;
2792     while (scan != NULL) {
2793
2794         DEBUG_EXECUTE_r( {
2795             SV * const prop = sv_newmortal();
2796             regnode *rnext=regnext(scan);
2797             DUMP_EXEC_POS( locinput, scan, do_utf8 );
2798             regprop(rex, prop, scan);
2799             
2800             PerlIO_printf(Perl_debug_log,
2801                     "%3"IVdf":%*s%s(%"IVdf")\n",
2802                     (IV)(scan - rexi->program), depth*2, "",
2803                     SvPVX_const(prop),
2804                     (PL_regkind[OP(scan)] == END || !rnext) ? 
2805                         0 : (IV)(rnext - rexi->program));
2806         });
2807
2808         next = scan + NEXT_OFF(scan);
2809         if (next == scan)
2810             next = NULL;
2811         state_num = OP(scan);
2812
2813       reenter_switch:
2814         switch (state_num) {
2815         case BOL:
2816             if (locinput == PL_bostr)
2817             {
2818                 /* reginfo->till = reginfo->bol; */
2819                 break;
2820             }
2821             sayNO;
2822         case MBOL:
2823             if (locinput == PL_bostr ||
2824                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2825             {
2826                 break;
2827             }
2828             sayNO;
2829         case SBOL:
2830             if (locinput == PL_bostr)
2831                 break;
2832             sayNO;
2833         case GPOS:
2834             if (locinput == reginfo->ganch)
2835                 break;
2836             sayNO;
2837
2838         case KEEPS:
2839             /* update the startpoint */
2840             st->u.keeper.val = PL_regoffs[0].start;
2841             PL_reginput = locinput;
2842             PL_regoffs[0].start = locinput - PL_bostr;
2843             PUSH_STATE_GOTO(KEEPS_next, next);
2844             /*NOT-REACHED*/
2845         case KEEPS_next_fail:
2846             /* rollback the start point change */
2847             PL_regoffs[0].start = st->u.keeper.val;
2848             sayNO_SILENT;
2849             /*NOT-REACHED*/
2850         case EOL:
2851                 goto seol;
2852         case MEOL:
2853             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2854                 sayNO;
2855             break;
2856         case SEOL:
2857           seol:
2858             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2859                 sayNO;
2860             if (PL_regeol - locinput > 1)
2861                 sayNO;
2862             break;
2863         case EOS:
2864             if (PL_regeol != locinput)
2865                 sayNO;
2866             break;
2867         case SANY:
2868             if (!nextchr && locinput >= PL_regeol)
2869                 sayNO;
2870             if (do_utf8) {
2871                 locinput += PL_utf8skip[nextchr];
2872                 if (locinput > PL_regeol)
2873                     sayNO;
2874                 nextchr = UCHARAT(locinput);
2875             }
2876             else
2877                 nextchr = UCHARAT(++locinput);
2878             break;
2879         case CANY:
2880             if (!nextchr && locinput >= PL_regeol)
2881                 sayNO;
2882             nextchr = UCHARAT(++locinput);
2883             break;
2884         case REG_ANY:
2885             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2886                 sayNO;
2887             if (do_utf8) {
2888                 locinput += PL_utf8skip[nextchr];
2889                 if (locinput > PL_regeol)
2890                     sayNO;
2891                 nextchr = UCHARAT(locinput);
2892             }
2893             else
2894                 nextchr = UCHARAT(++locinput);
2895             break;
2896
2897 #undef  ST
2898 #define ST st->u.trie
2899         case TRIEC:
2900             /* In this case the charclass data is available inline so
2901                we can fail fast without a lot of extra overhead. 
2902              */
2903             if (scan->flags == EXACT || !do_utf8) {
2904                 if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
2905                     DEBUG_EXECUTE_r(
2906                         PerlIO_printf(Perl_debug_log,
2907                                   "%*s  %sfailed to match trie start class...%s\n",
2908                                   REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2909                     );
2910                     sayNO_SILENT;
2911                     /* NOTREACHED */
2912                 }                       
2913             }
2914             /* FALL THROUGH */
2915         case TRIE:
2916             {
2917                 /* what type of TRIE am I? (utf8 makes this contextual) */
2918                 DECL_TRIE_TYPE(scan);
2919
2920                 /* what trie are we using right now */
2921                 reg_trie_data * const trie
2922                     = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
2923                 HV * widecharmap = (HV *)rexi->data->data[ ARG( scan ) + 1 ];
2924                 U32 state = trie->startstate;
2925
2926                 if (trie->bitmap && trie_type != trie_utf8_fold &&
2927                     !TRIE_BITMAP_TEST(trie,*locinput)
2928                 ) {
2929                     if (trie->states[ state ].wordnum) {
2930                          DEBUG_EXECUTE_r(
2931                             PerlIO_printf(Perl_debug_log,
2932                                           "%*s  %smatched empty string...%s\n",
2933                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2934                         );
2935                         break;
2936                     } else {
2937                         DEBUG_EXECUTE_r(
2938                             PerlIO_printf(Perl_debug_log,
2939                                           "%*s  %sfailed to match trie start class...%s\n",
2940                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2941                         );
2942                         sayNO_SILENT;
2943                    }
2944                 }
2945
2946             { 
2947                 U8 *uc = ( U8* )locinput;
2948
2949                 STRLEN len = 0;
2950                 STRLEN foldlen = 0;
2951                 U8 *uscan = (U8*)NULL;
2952                 STRLEN bufflen=0;
2953                 SV *sv_accept_buff = NULL;
2954                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2955
2956                 ST.accepted = 0; /* how many accepting states we have seen */
2957                 ST.B = next;
2958                 ST.jump = trie->jump;
2959                 ST.me = scan;
2960                 /*
2961                    traverse the TRIE keeping track of all accepting states
2962                    we transition through until we get to a failing node.
2963                 */
2964
2965                 while ( state && uc <= (U8*)PL_regeol ) {
2966                     U32 base = trie->states[ state ].trans.base;
2967                     UV uvc = 0;
2968                     U16 charid;
2969                     /* We use charid to hold the wordnum as we don't use it
2970                        for charid until after we have done the wordnum logic. 
2971                        We define an alias just so that the wordnum logic reads
2972                        more naturally. */
2973
2974 #define got_wordnum charid
2975                     got_wordnum = trie->states[ state ].wordnum;
2976
2977                     if ( got_wordnum ) {
2978                         if ( ! ST.accepted ) {
2979                             ENTER;
2980                             /* SAVETMPS; */ /* XXX is this necessary? dmq */
2981                             bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
2982                             sv_accept_buff=newSV(bufflen *
2983                                             sizeof(reg_trie_accepted) - 1);
2984                             SvCUR_set(sv_accept_buff, 0);
2985                             SvPOK_on(sv_accept_buff);
2986                             sv_2mortal(sv_accept_buff);
2987                             SAVETMPS;
2988                             ST.accept_buff =
2989                                 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
2990                         }
2991                         do {
2992                             if (ST.accepted >= bufflen) {
2993                                 bufflen *= 2;
2994                                 ST.accept_buff =(reg_trie_accepted*)
2995                                     SvGROW(sv_accept_buff,
2996                                         bufflen * sizeof(reg_trie_accepted));
2997                             }
2998                             SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
2999                                 + sizeof(reg_trie_accepted));
3000
3001
3002                             ST.accept_buff[ST.accepted].wordnum = got_wordnum;
3003                             ST.accept_buff[ST.accepted].endpos = uc;
3004                             ++ST.accepted;
3005                         } while (trie->nextword && (got_wordnum= trie->nextword[got_wordnum]));
3006                     }
3007 #undef got_wordnum 
3008
3009                     DEBUG_TRIE_EXECUTE_r({
3010                                 DUMP_EXEC_POS( (char *)uc, scan, do_utf8 );
3011                                 PerlIO_printf( Perl_debug_log,
3012                                     "%*s  %sState: %4"UVxf" Accepted: %4"UVxf" ",
3013                                     2+depth * 2, "", PL_colors[4],
3014                                     (UV)state, (UV)ST.accepted );
3015                     });
3016
3017                     if ( base ) {
3018                         REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
3019                                              uscan, len, uvc, charid, foldlen,
3020                                              foldbuf, uniflags);
3021
3022                         if (charid &&
3023                              (base + charid > trie->uniquecharcount )
3024                              && (base + charid - 1 - trie->uniquecharcount
3025                                     < trie->lasttrans)
3026                              && trie->trans[base + charid - 1 -
3027                                     trie->uniquecharcount].check == state)
3028                         {
3029                             state = trie->trans[base + charid - 1 -
3030                                 trie->uniquecharcount ].next;
3031                         }
3032                         else {
3033                             state = 0;
3034                         }
3035                         uc += len;
3036
3037                     }
3038                     else {
3039                         state = 0;
3040                     }
3041                     DEBUG_TRIE_EXECUTE_r(
3042                         PerlIO_printf( Perl_debug_log,
3043                             "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
3044                             charid, uvc, (UV)state, PL_colors[5] );
3045                     );
3046                 }
3047                 if (!ST.accepted )
3048                    sayNO;
3049
3050                 DEBUG_EXECUTE_r(
3051                     PerlIO_printf( Perl_debug_log,
3052                         "%*s  %sgot %"IVdf" possible matches%s\n",
3053                         REPORT_CODE_OFF + depth * 2, "",
3054                         PL_colors[4], (IV)ST.accepted, PL_colors[5] );
3055                 );
3056             }}
3057             goto trie_first_try; /* jump into the fail handler */
3058             /* NOTREACHED */
3059         case TRIE_next_fail: /* we failed - try next alterative */
3060             if ( ST.jump) {
3061                 REGCP_UNWIND(ST.cp);
3062                 for (n = *PL_reglastparen; n > ST.lastparen; n--)
3063                     PL_regoffs[n].end = -1;
3064                 *PL_reglastparen = n;
3065             }
3066           trie_first_try:
3067             if (do_cutgroup) {
3068                 do_cutgroup = 0;
3069                 no_final = 0;
3070             }
3071
3072             if ( ST.jump) {
3073                 ST.lastparen = *PL_reglastparen;
3074                 REGCP_SET(ST.cp);
3075             }           
3076             if ( ST.accepted == 1 ) {
3077                 /* only one choice left - just continue */
3078                 DEBUG_EXECUTE_r({
3079                     AV *const trie_words
3080                         = (AV *) rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET];
3081                     SV ** const tmp = av_fetch( trie_words, 
3082                         ST.accept_buff[ 0 ].wordnum-1, 0 );
3083                     SV *sv= tmp ? sv_newmortal() : NULL;
3084                     
3085                     PerlIO_printf( Perl_debug_log,
3086                         "%*s  %sonly one match left: #%d <%s>%s\n",
3087                         REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3088                         ST.accept_buff[ 0 ].wordnum,
3089                         tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0, 
3090                                 PL_colors[0], PL_colors[1],
3091                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3092                             ) 
3093                         : "not compiled under -Dr",
3094                         PL_colors[5] );
3095                 });
3096                 PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
3097                 /* in this case we free tmps/leave before we call regmatch
3098                    as we wont be using accept_buff again. */
3099                 
3100                 locinput = PL_reginput;
3101                 nextchr = UCHARAT(locinput);
3102                 if ( !ST.jump || !ST.jump[ST.accept_buff[0].wordnum]) 
3103                     scan = ST.B;
3104                 else
3105                     scan = ST.me + ST.jump[ST.accept_buff[0].wordnum];
3106                 if (!has_cutgroup) {
3107                     FREETMPS;
3108                     LEAVE;
3109                 } else {
3110                     ST.accepted--;
3111                     PUSH_YES_STATE_GOTO(TRIE_next, scan);
3112                 }
3113                 
3114                 continue; /* execute rest of RE */
3115             }
3116             
3117             if ( !ST.accepted-- ) {
3118                 DEBUG_EXECUTE_r({
3119                     PerlIO_printf( Perl_debug_log,
3120                         "%*s  %sTRIE failed...%s\n",
3121                         REPORT_CODE_OFF+depth*2, "", 
3122                         PL_colors[4],
3123                         PL_colors[5] );
3124                 });
3125                 FREETMPS;
3126                 LEAVE;
3127                 sayNO_SILENT;
3128                 /*NOTREACHED*/
3129             } 
3130
3131             /*
3132                There are at least two accepting states left.  Presumably
3133                the number of accepting states is going to be low,
3134                typically two. So we simply scan through to find the one
3135                with lowest wordnum.  Once we find it, we swap the last
3136                state into its place and decrement the size. We then try to
3137                match the rest of the pattern at the point where the word
3138                ends. If we succeed, control just continues along the
3139                regex; if we fail we return here to try the next accepting
3140                state
3141              */
3142
3143             {
3144                 U32 best = 0;
3145                 U32 cur;
3146                 for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
3147                     DEBUG_TRIE_EXECUTE_r(
3148                         PerlIO_printf( Perl_debug_log,
3149                             "%*s  %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
3150                             REPORT_CODE_OFF + depth * 2, "", PL_colors[4],
3151                             (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
3152                             ST.accept_buff[ cur ].wordnum, PL_colors[5] );
3153                     );
3154
3155                     if (ST.accept_buff[cur].wordnum <
3156                             ST.accept_buff[best].wordnum)
3157                         best = cur;
3158                 }
3159
3160                 DEBUG_EXECUTE_r({
3161                     AV *const trie_words
3162                         = (AV *) rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET];
3163                     SV ** const tmp = av_fetch( trie_words, 
3164                         ST.accept_buff[ best ].wordnum - 1, 0 );
3165                     regnode *nextop=(!ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) ? 
3166                                     ST.B : 
3167                                     ST.me + ST.jump[ST.accept_buff[best].wordnum];    
3168                     SV *sv= tmp ? sv_newmortal() : NULL;
3169                     
3170                     PerlIO_printf( Perl_debug_log, 
3171                         "%*s  %strying alternation #%d <%s> at node #%d %s\n",
3172                         REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3173                         ST.accept_buff[best].wordnum,
3174                         tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0, 
3175                                 PL_colors[0], PL_colors[1],
3176                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3177                             ) : "not compiled under -Dr", 
3178                             REG_NODE_NUM(nextop),
3179                         PL_colors[5] );
3180                 });
3181
3182                 if ( best<ST.accepted ) {
3183                     reg_trie_accepted tmp = ST.accept_buff[ best ];
3184                     ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
3185                     ST.accept_buff[ ST.accepted ] = tmp;
3186                     best = ST.accepted;
3187                 }
3188                 PL_reginput = (char *)ST.accept_buff[ best ].endpos;
3189                 if ( !ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) {
3190                     scan = ST.B;
3191                 } else {
3192                     scan = ST.me + ST.jump[ST.accept_buff[best].wordnum];
3193                 }
3194                 PUSH_YES_STATE_GOTO(TRIE_next, scan);    
3195                 /* NOTREACHED */
3196             }
3197             /* NOTREACHED */
3198         case TRIE_next:
3199             FREETMPS;
3200             LEAVE;
3201             sayYES;
3202 #undef  ST
3203
3204         case EXACT: {
3205             char *s = STRING(scan);
3206             ln = STR_LEN(scan);
3207             if (do_utf8 != UTF) {
3208                 /* The target and the pattern have differing utf8ness. */
3209                 char *l = locinput;
3210                 const char * const e = s + ln;
3211
3212                 if (do_utf8) {
3213                     /* The target is utf8, the pattern is not utf8. */
3214                     while (s < e) {
3215                         STRLEN ulen;
3216                         if (l >= PL_regeol)
3217                              sayNO;
3218                         if (NATIVE_TO_UNI(*(U8*)s) !=
3219                             utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3220                                             uniflags))
3221                              sayNO;
3222                         l += ulen;
3223                         s ++;
3224                     }
3225                 }
3226                 else {
3227                     /* The target is not utf8, the pattern is utf8. */
3228                     while (s < e) {
3229                         STRLEN ulen;
3230                         if (l >= PL_regeol)
3231                             sayNO;
3232                         if (NATIVE_TO_UNI(*((U8*)l)) !=
3233                             utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3234                                            uniflags))
3235                             sayNO;
3236                         s += ulen;
3237                         l ++;
3238                     }
3239                 }
3240                 locinput = l;
3241                 nextchr = UCHARAT(locinput);
3242                 break;
3243             }
3244             /* The target and the pattern have the same utf8ness. */
3245             /* Inline the first character, for speed. */
3246             if (UCHARAT(s) != nextchr)
3247                 sayNO;
3248             if (PL_regeol - locinput < ln)
3249                 sayNO;
3250             if (ln > 1 && memNE(s, locinput, ln))
3251                 sayNO;
3252             locinput += ln;
3253             nextchr = UCHARAT(locinput);
3254             break;
3255             }
3256         case EXACTFL:
3257             PL_reg_flags |= RF_tainted;
3258             /* FALL THROUGH */
3259         case EXACTF: {
3260             char * const s = STRING(scan);
3261             ln = STR_LEN(scan);
3262
3263             if (do_utf8 || UTF) {
3264               /* Either target or the pattern are utf8. */
3265                 const char * const l = locinput;
3266                 char *e = PL_regeol;
3267
3268                 if (ibcmp_utf8(s, 0,  ln, (bool)UTF,
3269                                l, &e, 0,  do_utf8)) {
3270                      /* One more case for the sharp s:
3271                       * pack("U0U*", 0xDF) =~ /ss/i,
3272                       * the 0xC3 0x9F are the UTF-8
3273                       * byte sequence for the U+00DF. */
3274
3275                      if (!(do_utf8 &&
3276                            toLOWER(s[0]) == 's' &&
3277                            ln >= 2 &&
3278                            toLOWER(s[1]) == 's' &&
3279                            (U8)l[0] == 0xC3 &&
3280                            e - l >= 2 &&
3281                            (U8)l[1] == 0x9F))
3282                           sayNO;
3283                 }
3284                 locinput = e;
3285                 nextchr = UCHARAT(locinput);
3286                 break;
3287             }
3288
3289             /* Neither the target and the pattern are utf8. */
3290
3291             /* Inline the first character, for speed. */
3292             if (UCHARAT(s) != nextchr &&
3293                 UCHARAT(s) != ((OP(scan) == EXACTF)
3294                                ? PL_fold : PL_fold_locale)[nextchr])
3295                 sayNO;
3296             if (PL_regeol - locinput < ln)
3297                 sayNO;
3298             if (ln > 1 && (OP(scan) == EXACTF
3299                            ? ibcmp(s, locinput, ln)
3300                            : ibcmp_locale(s, locinput, ln)))
3301                 sayNO;
3302             locinput += ln;
3303             nextchr = UCHARAT(locinput);
3304             break;
3305             }
3306         case ANYOF:
3307             if (do_utf8) {
3308                 STRLEN inclasslen = PL_regeol - locinput;
3309
3310                 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3311                     goto anyof_fail;
3312                 if (locinput >= PL_regeol)
3313                     sayNO;
3314                 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3315                 nextchr = UCHARAT(locinput);
3316                 break;
3317             }
3318             else {
3319                 if (nextchr < 0)
3320                     nextchr = UCHARAT(locinput);
3321                 if (!REGINCLASS(rex, scan, (U8*)locinput))
3322                     goto anyof_fail;
3323                 if (!nextchr && locinput >= PL_regeol)
3324                     sayNO;
3325                 nextchr = UCHARAT(++locinput);
3326                 break;
3327             }
3328         anyof_fail:
3329             /* If we might have the case of the German sharp s
3330              * in a casefolding Unicode character class. */
3331
3332             if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3333                  locinput += SHARP_S_SKIP;
3334                  nextchr = UCHARAT(locinput);
3335             }
3336             else
3337                  sayNO;
3338             break;
3339         case ALNUML:
3340             PL_reg_flags |= RF_tainted;
3341             /* FALL THROUGH */
3342         case ALNUM:
3343             if (!nextchr)
3344                 sayNO;
3345             if (do_utf8) {
3346                 LOAD_UTF8_CHARCLASS_ALNUM();
3347                 if (!(OP(scan) == ALNUM
3348                       ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3349                       : isALNUM_LC_utf8((U8*)locinput)))
3350                 {
3351                     sayNO;
3352                 }
3353                 locinput += PL_utf8skip[nextchr];
3354                 nextchr = UCHARAT(locinput);
3355                 break;
3356             }
3357             if (!(OP(scan) == ALNUM
3358                   ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
3359                 sayNO;
3360             nextchr = UCHARAT(++locinput);
3361             break;
3362         case NALNUML:
3363             PL_reg_flags |= RF_tainted;
3364             /* FALL THROUGH */
3365         case NALNUM:
3366             if (!nextchr && locinput >= PL_regeol)
3367                 sayNO;
3368             if (do_utf8) {
3369                 LOAD_UTF8_CHARCLASS_ALNUM();
3370                 if (OP(scan) == NALNUM
3371                     ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3372                     : isALNUM_LC_utf8((U8*)locinput))
3373                 {
3374                     sayNO;
3375                 }
3376                 locinput += PL_utf8skip[nextchr];
3377                 nextchr = UCHARAT(locinput);
3378                 break;
3379             }
3380             if (OP(scan) == NALNUM
3381                 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
3382                 sayNO;
3383             nextchr = UCHARAT(++locinput);
3384             break;
3385         case BOUNDL:
3386         case NBOUNDL:
3387             PL_reg_flags |= RF_tainted;
3388             /* FALL THROUGH */
3389         case BOUND:
3390         case NBOUND:
3391             /* was last char in word? */
3392             if (do_utf8) {
3393                 if (locinput == PL_bostr)
3394                     ln = '\n';
3395                 else {
3396                     const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3397                 
3398                     ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3399                 }
3400                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3401                     ln = isALNUM_uni(ln);
3402                     LOAD_UTF8_CHARCLASS_ALNUM();
3403                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3404                 }
3405                 else {
3406                     ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
3407                     n = isALNUM_LC_utf8((U8*)locinput);
3408                 }
3409             }
3410             else {
3411                 ln = (locinput != PL_bostr) ?
3412                     UCHARAT(locinput - 1) : '\n';
3413                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3414                     ln = isALNUM(ln);
3415                     n = isALNUM(nextchr);
3416                 }
3417                 else {
3418                     ln = isALNUM_LC(ln);
3419                     n = isALNUM_LC(nextchr);
3420                 }
3421             }
3422             if (((!ln) == (!n)) == (OP(scan) == BOUND ||
3423                                     OP(scan) == BOUNDL))
3424                     sayNO;
3425             break;
3426         case SPACEL:
3427             PL_reg_flags |= RF_tainted;
3428             /* FALL THROUGH */
3429         case SPACE:
3430             if (!nextchr)
3431                 sayNO;
3432             if (do_utf8) {
3433                 if (UTF8_IS_CONTINUED(nextchr)) {
3434                     LOAD_UTF8_CHARCLASS_SPACE();
3435                     if (!(OP(scan) == SPACE
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) == SPACE
3446                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3447                     sayNO;
3448                 nextchr = UCHARAT(++locinput);
3449             }
3450             else {
3451                 if (!(OP(scan) == SPACE
3452                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3453                     sayNO;
3454                 nextchr = UCHARAT(++locinput);
3455             }
3456             break;
3457         case NSPACEL:
3458             PL_reg_flags |= RF_tainted;
3459             /* FALL THROUGH */
3460         case NSPACE:
3461             if (!nextchr && locinput >= PL_regeol)
3462                 sayNO;
3463             if (do_utf8) {
3464                 LOAD_UTF8_CHARCLASS_SPACE();
3465                 if (OP(scan) == NSPACE
3466                     ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3467                     : isSPACE_LC_utf8((U8*)locinput))
3468                 {
3469                     sayNO;
3470                 }
3471                 locinput += PL_utf8skip[nextchr];
3472                 nextchr = UCHARAT(locinput);
3473                 break;
3474             }
3475             if (OP(scan) == NSPACE
3476                 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
3477                 sayNO;
3478             nextchr = UCHARAT(++locinput);
3479             break;
3480         case DIGITL:
3481             PL_reg_flags |= RF_tainted;
3482             /* FALL THROUGH */
3483         case DIGIT:
3484             if (!nextchr)
3485                 sayNO;
3486             if (do_utf8) {
3487                 LOAD_UTF8_CHARCLASS_DIGIT();
3488                 if (!(OP(scan) == DIGIT
3489                       ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3490                       : isDIGIT_LC_utf8((U8*)locinput)))
3491                 {
3492                     sayNO;
3493                 }
3494                 locinput += PL_utf8skip[nextchr];
3495                 nextchr = UCHARAT(locinput);
3496                 break;
3497             }
3498             if (!(OP(scan) == DIGIT
3499                   ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
3500                 sayNO;
3501             nextchr = UCHARAT(++locinput);
3502             break;
3503         case NDIGITL:
3504             PL_reg_flags |= RF_tainted;
3505             /* FALL THROUGH */
3506         case NDIGIT:
3507             if (!nextchr && locinput >= PL_regeol)
3508                 sayNO;
3509             if (do_utf8) {
3510                 LOAD_UTF8_CHARCLASS_DIGIT();
3511                 if (OP(scan) == NDIGIT
3512                     ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3513                     : isDIGIT_LC_utf8((U8*)locinput))
3514                 {
3515                     sayNO;
3516                 }
3517                 locinput += PL_utf8skip[nextchr];
3518                 nextchr = UCHARAT(locinput);
3519                 break;
3520             }
3521             if (OP(scan) == NDIGIT
3522                 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
3523                 sayNO;
3524             nextchr = UCHARAT(++locinput);
3525             break;
3526         case CLUMP:
3527             if (locinput >= PL_regeol)
3528                 sayNO;
3529             if  (do_utf8) {
3530                 LOAD_UTF8_CHARCLASS_MARK();
3531                 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3532                     sayNO;
3533                 locinput += PL_utf8skip[nextchr];
3534                 while (locinput < PL_regeol &&
3535                        swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3536                     locinput += UTF8SKIP(locinput);
3537                 if (locinput > PL_regeol)
3538                     sayNO;
3539             } 
3540             else
3541                locinput++;
3542             nextchr = UCHARAT(locinput);
3543             break;
3544             
3545         case NREFFL:
3546         {
3547             char *s;
3548             char type;
3549             PL_reg_flags |= RF_tainted;
3550             /* FALL THROUGH */
3551         case NREF:
3552         case NREFF:
3553             type = OP(scan);
3554             n = reg_check_named_buff_matched(rex,scan);
3555
3556             if ( n ) {
3557                 type = REF + ( type - NREF );
3558                 goto do_ref;
3559             } else {
3560                 sayNO;
3561             }
3562             /* unreached */
3563         case REFFL:
3564             PL_reg_flags |= RF_tainted;
3565             /* FALL THROUGH */
3566         case REF:
3567         case REFF: 
3568             n = ARG(scan);  /* which paren pair */
3569             type = OP(scan);
3570           do_ref:  
3571             ln = PL_regoffs[n].start;
3572             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3573             if (*PL_reglastparen < n || ln == -1)
3574                 sayNO;                  /* Do not match unless seen CLOSEn. */
3575             if (ln == PL_regoffs[n].end)
3576                 break;
3577
3578             s = PL_bostr + ln;
3579             if (do_utf8 && type != REF) {       /* REF can do byte comparison */
3580                 char *l = locinput;
3581                 const char *e = PL_bostr + PL_regoffs[n].end;
3582                 /*
3583                  * Note that we can't do the "other character" lookup trick as
3584                  * in the 8-bit case (no pun intended) because in Unicode we
3585                  * have to map both upper and title case to lower case.
3586                  */
3587                 if (type == REFF) {
3588                     while (s < e) {
3589                         STRLEN ulen1, ulen2;
3590                         U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3591                         U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3592
3593                         if (l >= PL_regeol)
3594                             sayNO;
3595                         toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3596                         toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3597                         if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3598                             sayNO;
3599                         s += ulen1;
3600                         l += ulen2;
3601                     }
3602                 }
3603                 locinput = l;
3604                 nextchr = UCHARAT(locinput);
3605                 break;
3606             }
3607
3608             /* Inline the first character, for speed. */
3609             if (UCHARAT(s) != nextchr &&
3610                 (type == REF ||
3611                  (UCHARAT(s) != (type == REFF
3612                                   ? PL_fold : PL_fold_locale)[nextchr])))
3613                 sayNO;
3614             ln = PL_regoffs[n].end - ln;
3615             if (locinput + ln > PL_regeol)
3616                 sayNO;
3617             if (ln > 1 && (type == REF
3618                            ? memNE(s, locinput, ln)
3619                            : (type == REFF
3620                               ? ibcmp(s, locinput, ln)
3621                               : ibcmp_locale(s, locinput, ln))))
3622                 sayNO;
3623             locinput += ln;
3624             nextchr = UCHARAT(locinput);
3625             break;
3626         }
3627         case NOTHING:
3628         case TAIL:
3629             break;
3630         case BACK:
3631             break;
3632
3633 #undef  ST
3634 #define ST st->u.eval
3635         {
3636             SV *ret;
3637             REGEXP *re_sv;
3638             regexp *re;
3639             regexp_internal *rei;
3640             regnode *startpoint;
3641
3642         case GOSTART:
3643         case GOSUB: /*    /(...(?1))/   /(...(?&foo))/   */
3644             if (cur_eval && cur_eval->locinput==locinput) {
3645                 if (cur_eval->u.eval.close_paren == (U32)ARG(scan)) 
3646                     Perl_croak(aTHX_ "Infinite recursion in regex");
3647                 if ( ++nochange_depth > max_nochange_depth )
3648                     Perl_croak(aTHX_ 
3649                         "Pattern subroutine nesting without pos change"
3650                         " exceeded limit in regex");
3651             } else {
3652                 nochange_depth = 0;
3653             }
3654             re_sv = rex_sv;
3655             re = rex;
3656             rei = rexi;
3657             (void)ReREFCNT_inc(rex_sv);
3658             if (OP(scan)==GOSUB) {
3659                 startpoint = scan + ARG2L(scan);
3660                 ST.close_paren = ARG(scan);
3661             } else {
3662                 startpoint = rei->program+1;
3663                 ST.close_paren = 0;
3664             }
3665             goto eval_recurse_doit;
3666             /* NOTREACHED */
3667         case EVAL:  /*   /(?{A})B/   /(??{A})B/  and /(?(?{A})X|Y)B/   */        
3668             if (cur_eval && cur_eval->locinput==locinput) {
3669                 if ( ++nochange_depth > max_nochange_depth )
3670                     Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
3671             } else {
3672                 nochange_depth = 0;
3673             }    
3674             {
3675                 /* execute the code in the {...} */
3676                 dSP;
3677                 SV ** const before = SP;
3678                 OP_4tree * const oop = PL_op;
3679                 COP * const ocurcop = PL_curcop;
3680                 PAD *old_comppad;
3681             
3682                 n = ARG(scan);
3683                 PL_op = (OP_4tree*)rexi->data->data[n];
3684                 DEBUG_STATE_r( PerlIO_printf(Perl_debug_log, 
3685                     "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3686                 PAD_SAVE_LOCAL(old_comppad, (PAD*)rexi->data->data[n + 2]);
3687                 PL_regoffs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
3688
3689                 if (sv_yes_mark) {
3690                     SV *sv_mrk = get_sv("REGMARK", 1);
3691                     sv_setsv(sv_mrk, sv_yes_mark);
3692                 }
3693
3694                 CALLRUNOPS(aTHX);                       /* Scalar context. */
3695                 SPAGAIN;
3696                 if (SP == before)
3697                     ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
3698                 else {
3699                     ret = POPs;
3700                     PUTBACK;
3701                 }
3702
3703                 PL_op = oop;
3704                 PAD_RESTORE_LOCAL(old_comppad);
3705                 PL_curcop = ocurcop;
3706                 if (!logical) {
3707                     /* /(?{...})/ */
3708                     sv_setsv(save_scalar(PL_replgv), ret);
3709                     break;
3710                 }
3711             }
3712             if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
3713                 logical = 0;
3714                 {
3715                     /* extract RE object from returned value; compiling if
3716                      * necessary */
3717                     MAGIC *mg = NULL;
3718                     REGEXP *rx = NULL;
3719
3720                     if (SvROK(ret)) {
3721                         SV *const sv = SvRV(ret);
3722
3723                         if (SvTYPE(sv) == SVt_REGEXP) {
3724                             rx = (REGEXP*) sv;
3725                         } else if (SvSMAGICAL(sv)) {
3726                             mg = mg_find(sv, PERL_MAGIC_qr);
3727                             assert(mg);
3728                         }
3729                     } else if (SvTYPE(ret) == SVt_REGEXP) {
3730                         rx = (REGEXP*) ret;
3731                     } else if (SvSMAGICAL(ret)) {
3732                         if (SvGMAGICAL(ret)) {
3733                             /* I don't believe that there is ever qr magic
3734                                here.  */
3735                             assert(!mg_find(ret, PERL_MAGIC_qr));
3736                             sv_unmagic(ret, PERL_MAGIC_qr);
3737                         }
3738                         else {
3739                             mg = mg_find(ret, PERL_MAGIC_qr);
3740                             /* testing suggests mg only ends up non-NULL for
3741                                scalars who were upgraded and compiled in the
3742                                else block below. In turn, this is only
3743                                triggered in the "postponed utf8 string" tests
3744                                in t/op/pat.t  */
3745                         }
3746                     }
3747
3748                     if (mg) {
3749                         rx = (REGEXP *) mg->mg_obj; /*XXX:dmq*/
3750                         assert(rx);
3751                     }
3752                     if (rx) {
3753                         rx = reg_temp_copy(rx);
3754                     }
3755                     else {
3756                         U32 pm_flags = 0;
3757                         const I32 osize = PL_regsize;
3758
3759                         if (DO_UTF8(ret)) {
3760                             assert (SvUTF8(ret));
3761                         } else if (SvUTF8(ret)) {
3762                             /* Not doing UTF-8, despite what the SV says. Is
3763                                this only if we're trapped in use 'bytes'?  */
3764                             /* Make a copy of the octet sequence, but without
3765                                the flag on, as the compiler now honours the
3766                                SvUTF8 flag on ret.  */
3767                             STRLEN len;
3768                             const char *const p = SvPV(ret, len);
3769                             ret = newSVpvn_flags(p, len, SVs_TEMP);
3770                         }
3771                         rx = CALLREGCOMP(ret, pm_flags);
3772                         if (!(SvFLAGS(ret)
3773                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3774                                  | SVs_GMG))) {
3775                             /* This isn't a first class regexp. Instead, it's
3776                                caching a regexp onto an existing, Perl visible
3777                                scalar.  */
3778                             sv_magic(ret, (SV*) rx, PERL_MAGIC_qr, 0, 0);
3779                         }
3780                         PL_regsize = osize;
3781                     }
3782                     re_sv = rx;
3783                     re = (struct regexp *)SvANY(rx);
3784                 }
3785                 RXp_MATCH_COPIED_off(re);
3786                 re->subbeg = rex->subbeg;
3787                 re->sublen = rex->sublen;
3788                 rei = RXi_GET(re);
3789                 DEBUG_EXECUTE_r(
3790                     debug_start_match(re_sv, do_utf8, locinput, PL_regeol, 
3791                         "Matching embedded");
3792                 );              
3793                 startpoint = rei->program + 1;
3794                 ST.close_paren = 0; /* only used for GOSUB */
3795                 /* borrowed from regtry */
3796                 if (PL_reg_start_tmpl <= re->nparens) {
3797                     PL_reg_start_tmpl = re->nparens*3/2 + 3;
3798                     if(PL_reg_start_tmp)
3799                         Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
3800                     else
3801                         Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
3802                 }                       
3803
3804         eval_recurse_doit: /* Share code with GOSUB below this line */                          
3805                 /* run the pattern returned from (??{...}) */
3806                 ST.cp = regcppush(0);   /* Save *all* the positions. */
3807                 REGCP_SET(ST.lastcp);
3808                 
3809                 PL_regoffs = re->offs; /* essentially NOOP on GOSUB */
3810                 
3811                 /* see regtry, specifically PL_reglast(?:close)?paren is a pointer! (i dont know why) :dmq */
3812                 PL_reglastparen = &re->lastparen;
3813                 PL_reglastcloseparen = &re->lastcloseparen;
3814                 re->lastparen = 0;
3815                 re->lastcloseparen = 0;
3816
3817                 PL_reginput = locinput;
3818                 PL_regsize = 0;
3819
3820                 /* XXXX This is too dramatic a measure... */
3821                 PL_reg_maxiter = 0;
3822
3823                 ST.toggle_reg_flags = PL_reg_flags;
3824                 if (RX_UTF8(re_sv))
3825                     PL_reg_flags |= RF_utf8;
3826                 else
3827                     PL_reg_flags &= ~RF_utf8;
3828                 ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
3829
3830                 ST.prev_rex = rex_sv;
3831                 ST.prev_curlyx = cur_curlyx;
3832                 SETREX(rex_sv,re_sv);
3833                 rex = re;
3834                 rexi = rei;
3835                 cur_curlyx = NULL;
3836                 ST.B = next;
3837                 ST.prev_eval = cur_eval;
3838                 cur_eval = st;
3839                 /* now continue from first node in postoned RE */
3840                 PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
3841                 /* NOTREACHED */
3842             }
3843             /* logical is 1,   /(?(?{...})X|Y)/ */
3844             sw = (bool)SvTRUE(ret);
3845             logical = 0;
3846             break;
3847         }
3848
3849         case EVAL_AB: /* cleanup after a successful (??{A})B */
3850             /* note: this is called twice; first after popping B, then A */
3851             PL_reg_flags ^= ST.toggle_reg_flags; 
3852             ReREFCNT_dec(rex_sv);
3853             SETREX(rex_sv,ST.prev_rex);
3854             rex = (struct regexp *)SvANY(rex_sv);
3855             rexi = RXi_GET(rex);
3856             regcpblow(ST.cp);
3857             cur_eval = ST.prev_eval;
3858             cur_curlyx = ST.prev_curlyx;
3859             
3860             PL_reglastparen = &rex->lastparen;
3861             PL_reglastcloseparen = &rex->lastcloseparen;
3862             
3863             /* XXXX This is too dramatic a measure... */
3864             PL_reg_maxiter = 0;
3865             if ( nochange_depth )
3866                 nochange_depth--;
3867             sayYES;
3868
3869
3870         case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
3871             /* note: this is called twice; first after popping B, then A */
3872             PL_reg_flags ^= ST.toggle_reg_flags; 
3873             ReREFCNT_dec(rex_sv);
3874             SETREX(rex_sv,ST.prev_rex);
3875             rex = (struct regexp *)SvANY(rex_sv);
3876             rexi = RXi_GET(rex); 
3877             PL_reglastparen = &rex->lastparen;
3878             PL_reglastcloseparen = &rex->lastcloseparen;
3879
3880             PL_reginput = locinput;
3881             REGCP_UNWIND(ST.lastcp);
3882             regcppop(rex);
3883             cur_eval = ST.prev_eval;
3884             cur_curlyx = ST.prev_curlyx;
3885             /* XXXX This is too dramatic a measure... */
3886             PL_reg_maxiter = 0;
3887             if ( nochange_depth )
3888                 nochange_depth--;
3889             sayNO_SILENT;
3890 #undef ST
3891
3892         case OPEN:
3893             n = ARG(scan);  /* which paren pair */
3894             PL_reg_start_tmp[n] = locinput;
3895             if (n > PL_regsize)
3896                 PL_regsize = n;
3897             lastopen = n;
3898             break;
3899         case CLOSE:
3900             n = ARG(scan);  /* which paren pair */
3901             PL_regoffs[n].start = PL_reg_start_tmp[n] - PL_bostr;
3902             PL_regoffs[n].end = locinput - PL_bostr;
3903             /*if (n > PL_regsize)
3904                 PL_regsize = n;*/
3905             if (n > *PL_reglastparen)
3906                 *PL_reglastparen = n;
3907             *PL_reglastcloseparen = n;
3908             if (cur_eval && cur_eval->u.eval.close_paren == n) {
3909                 goto fake_end;
3910             }    
3911             break;
3912         case ACCEPT:
3913             if (ARG(scan)){
3914                 regnode *cursor;
3915                 for (cursor=scan;
3916                      cursor && OP(cursor)!=END; 
3917                      cursor=regnext(cursor)) 
3918                 {
3919                     if ( OP(cursor)==CLOSE ){
3920                         n = ARG(cursor);
3921                         if ( n <= lastopen ) {
3922                             PL_regoffs[n].start
3923                                 = PL_reg_start_tmp[n] - PL_bostr;
3924                             PL_regoffs[n].end = locinput - PL_bostr;
3925                             /*if (n > PL_regsize)
3926                             PL_regsize = n;*/
3927                             if (n > *PL_reglastparen)
3928                                 *PL_reglastparen = n;
3929                             *PL_reglastcloseparen = n;
3930                             if ( n == ARG(scan) || (cur_eval &&
3931                        &nb