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