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