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