integrate #18349 from maint-5.8:
[p5sagit/p5-mst-13.2.git] / regexec.c
1 /*    regexec.c
2  */
3
4 /*
5  * "One Ring to rule them all, One Ring to find them..."
6  */
7
8 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
9  * confused with the original package (see point 3 below).  Thanks, Henry!
10  */
11
12 /* Additional note: this code is very heavily munged from Henry's version
13  * in places.  In some spots I've traded clarity for efficiency, so don't
14  * blame Henry for some of the lack of readability.
15  */
16
17 /* The names of the functions have been changed from regcomp and
18  * regexec to  pregcomp and pregexec in order to avoid conflicts
19  * with the POSIX routines of the same names.
20 */
21
22 #ifdef PERL_EXT_RE_BUILD
23 /* need to replace pregcomp et al, so enable that */
24 #  ifndef PERL_IN_XSUB_RE
25 #    define PERL_IN_XSUB_RE
26 #  endif
27 /* need access to debugger hooks */
28 #  if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
29 #    define DEBUGGING
30 #  endif
31 #endif
32
33 #ifdef PERL_IN_XSUB_RE
34 /* We *really* need to overwrite these symbols: */
35 #  define Perl_regexec_flags my_regexec
36 #  define Perl_regdump my_regdump
37 #  define Perl_regprop my_regprop
38 #  define Perl_re_intuit_start my_re_intuit_start
39 /* *These* symbols are masked to allow static link. */
40 #  define Perl_pregexec my_pregexec
41 #  define Perl_reginitcolors my_reginitcolors
42 #  define Perl_regclass_swash my_regclass_swash
43
44 #  define PERL_NO_GET_CONTEXT
45 #endif
46
47 /*SUPPRESS 112*/
48 /*
49  * pregcomp and pregexec -- regsub and regerror are not used in perl
50  *
51  *      Copyright (c) 1986 by University of Toronto.
52  *      Written by Henry Spencer.  Not derived from licensed software.
53  *
54  *      Permission is granted to anyone to use this software for any
55  *      purpose on any computer system, and to redistribute it freely,
56  *      subject to the following restrictions:
57  *
58  *      1. The author is not responsible for the consequences of use of
59  *              this software, no matter how awful, even if they arise
60  *              from defects in it.
61  *
62  *      2. The origin of this software must not be misrepresented, either
63  *              by explicit claim or by omission.
64  *
65  *      3. Altered versions must be plainly marked as such, and must not
66  *              be misrepresented as being the original software.
67  *
68  ****    Alterations to Henry's code are...
69  ****
70  ****    Copyright (c) 1991-2002, Larry Wall
71  ****
72  ****    You may distribute under the terms of either the GNU General Public
73  ****    License or the Artistic License, as specified in the README file.
74  *
75  * Beware that some of this code is subtly aware of the way operator
76  * precedence is structured in regular expressions.  Serious changes in
77  * regular-expression syntax might require a total rethink.
78  */
79 #include "EXTERN.h"
80 #define PERL_IN_REGEXEC_C
81 #include "perl.h"
82
83 #include "regcomp.h"
84
85 #define RF_tainted      1               /* tainted information used? */
86 #define RF_warned       2               /* warned about big count? */
87 #define RF_evaled       4               /* Did an EVAL with setting? */
88 #define RF_utf8         8               /* String contains multibyte chars? */
89
90 #define UTF ((PL_reg_flags & RF_utf8) != 0)
91
92 #define RS_init         1               /* eval environment created */
93 #define RS_set          2               /* replsv value is set */
94
95 #ifndef STATIC
96 #define STATIC  static
97 #endif
98
99 #define REGINCLASS(p,c)  (ANYOF_FLAGS(p) ? reginclass(p,c,0,0) : ANYOF_BITMAP_TEST(p,*(c)))
100
101 /*
102  * Forwards.
103  */
104
105 #define CHR_SVLEN(sv) (do_utf8 ? sv_len_utf8(sv) : SvCUR(sv))
106 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
107
108 #define reghop_c(pos,off) ((char*)reghop((U8*)pos, off))
109 #define reghopmaybe_c(pos,off) ((char*)reghopmaybe((U8*)pos, off))
110 #define HOP(pos,off) (PL_reg_match_utf8 ? reghop((U8*)pos, off) : (U8*)(pos + off))
111 #define HOPMAYBE(pos,off) (PL_reg_match_utf8 ? reghopmaybe((U8*)pos, off) : (U8*)(pos + off))
112 #define HOPc(pos,off) ((char*)HOP(pos,off))
113 #define HOPMAYBEc(pos,off) ((char*)HOPMAYBE(pos,off))
114
115 #define HOPBACK(pos, off) (             \
116     (PL_reg_match_utf8)                 \
117         ? reghopmaybe((U8*)pos, -off)   \
118     : (pos - off >= PL_bostr)           \
119         ? (U8*)(pos - off)              \
120     : (U8*)NULL                         \
121 )
122 #define HOPBACKc(pos, off) (char*)HOPBACK(pos, off)
123
124 #define reghop3_c(pos,off,lim) ((char*)reghop3((U8*)pos, off, (U8*)lim))
125 #define reghopmaybe3_c(pos,off,lim) ((char*)reghopmaybe3((U8*)pos, off, (U8*)lim))
126 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
127 #define HOPMAYBE3(pos,off,lim) (PL_reg_match_utf8 ? reghopmaybe3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
128 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
129 #define HOPMAYBE3c(pos,off,lim) ((char*)HOPMAYBE3(pos,off,lim))
130
131 #define LOAD_UTF8_CHARCLASS(a,b) STMT_START { if (!CAT2(PL_utf8_,a)) { ENTER; save_re_context(); (void)CAT2(is_utf8_, a)((U8*)b); LEAVE; } } STMT_END
132
133 /* for use after a quantifier and before an EXACT-like node -- japhy */
134 #define JUMPABLE(rn) ( \
135     OP(rn) == OPEN || OP(rn) == CLOSE || OP(rn) == EVAL || \
136     OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
137     OP(rn) == PLUS || OP(rn) == MINMOD || \
138     (PL_regkind[(U8)OP(rn)] == CURLY && ARG1(rn) > 0) \
139 )
140
141 #define HAS_TEXT(rn) ( \
142     PL_regkind[(U8)OP(rn)] == EXACT || PL_regkind[(U8)OP(rn)] == REF \
143 )
144
145 /*
146   Search for mandatory following text node; for lookahead, the text must
147   follow but for lookbehind (rn->flags != 0) we skip to the next step.
148 */
149 #define FIND_NEXT_IMPT(rn) STMT_START { \
150     while (JUMPABLE(rn)) \
151         if (OP(rn) == SUSPEND || PL_regkind[(U8)OP(rn)] == CURLY) \
152             rn = NEXTOPER(NEXTOPER(rn)); \
153         else if (OP(rn) == PLUS) \
154             rn = NEXTOPER(rn); \
155         else if (OP(rn) == IFMATCH) \
156             rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
157         else rn += NEXT_OFF(rn); \
158 } STMT_END 
159
160 static void restore_pos(pTHX_ void *arg);
161
162 STATIC CHECKPOINT
163 S_regcppush(pTHX_ I32 parenfloor)
164 {
165     int retval = PL_savestack_ix;
166 #define REGCP_PAREN_ELEMS 4
167     int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
168     int p;
169
170     if (paren_elems_to_push < 0)
171         Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
172
173 #define REGCP_OTHER_ELEMS 6
174     SSCHECK(paren_elems_to_push + REGCP_OTHER_ELEMS);
175     for (p = PL_regsize; p > parenfloor; p--) {
176 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
177         SSPUSHINT(PL_regendp[p]);
178         SSPUSHINT(PL_regstartp[p]);
179         SSPUSHPTR(PL_reg_start_tmp[p]);
180         SSPUSHINT(p);
181     }
182 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
183     SSPUSHINT(PL_regsize);
184     SSPUSHINT(*PL_reglastparen);
185     SSPUSHINT(*PL_reglastcloseparen);
186     SSPUSHPTR(PL_reginput);
187 #define REGCP_FRAME_ELEMS 2
188 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
189  * are needed for the regexp context stack bookkeeping. */
190     SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
191     SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
192
193     return retval;
194 }
195
196 /* These are needed since we do not localize EVAL nodes: */
197 #  define REGCP_SET(cp)  DEBUG_r(PerlIO_printf(Perl_debug_log,          \
198                              "  Setting an EVAL scope, savestack=%"IVdf"\n",    \
199                              (IV)PL_savestack_ix)); cp = PL_savestack_ix
200
201 #  define REGCP_UNWIND(cp)  DEBUG_r(cp != PL_savestack_ix ?             \
202                                 PerlIO_printf(Perl_debug_log,           \
203                                 "  Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
204                                 (IV)(cp), (IV)PL_savestack_ix) : 0); regcpblow(cp)
205
206 STATIC char *
207 S_regcppop(pTHX)
208 {
209     I32 i;
210     U32 paren = 0;
211     char *input;
212     I32 tmps;
213
214     /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
215     i = SSPOPINT;
216     assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
217     i = SSPOPINT; /* Parentheses elements to pop. */
218     input = (char *) SSPOPPTR;
219     *PL_reglastcloseparen = SSPOPINT;
220     *PL_reglastparen = SSPOPINT;
221     PL_regsize = SSPOPINT;
222
223     /* Now restore the parentheses context. */
224     for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
225          i > 0; i -= REGCP_PAREN_ELEMS) {
226         paren = (U32)SSPOPINT;
227         PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
228         PL_regstartp[paren] = SSPOPINT;
229         tmps = SSPOPINT;
230         if (paren <= *PL_reglastparen)
231             PL_regendp[paren] = tmps;
232         DEBUG_r(
233             PerlIO_printf(Perl_debug_log,
234                           "     restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
235                           (UV)paren, (IV)PL_regstartp[paren],
236                           (IV)(PL_reg_start_tmp[paren] - PL_bostr),
237                           (IV)PL_regendp[paren],
238                           (paren > *PL_reglastparen ? "(no)" : ""));
239         );
240     }
241     DEBUG_r(
242         if ((I32)(*PL_reglastparen + 1) <= PL_regnpar) {
243             PerlIO_printf(Perl_debug_log,
244                           "     restoring \\%"IVdf"..\\%"IVdf" to undef\n",
245                           (IV)(*PL_reglastparen + 1), (IV)PL_regnpar);
246         }
247     );
248 #if 1
249     /* It would seem that the similar code in regtry()
250      * already takes care of this, and in fact it is in
251      * a better location to since this code can #if 0-ed out
252      * but the code in regtry() is needed or otherwise tests
253      * requiring null fields (pat.t#187 and split.t#{13,14}
254      * (as of patchlevel 7877)  will fail.  Then again,
255      * this code seems to be necessary or otherwise
256      * building DynaLoader will fail:
257      * "Error: '*' not in typemap in DynaLoader.xs, line 164"
258      * --jhi */
259     for (paren = *PL_reglastparen + 1; (I32)paren <= PL_regnpar; paren++) {
260         if ((I32)paren > PL_regsize)
261             PL_regstartp[paren] = -1;
262         PL_regendp[paren] = -1;
263     }
264 #endif
265     return input;
266 }
267
268 STATIC char *
269 S_regcp_set_to(pTHX_ I32 ss)
270 {
271     I32 tmp = PL_savestack_ix;
272
273     PL_savestack_ix = ss;
274     regcppop();
275     PL_savestack_ix = tmp;
276     return Nullch;
277 }
278
279 typedef struct re_cc_state
280 {
281     I32 ss;
282     regnode *node;
283     struct re_cc_state *prev;
284     CURCUR *cc;
285     regexp *re;
286 } re_cc_state;
287
288 #define regcpblow(cp) LEAVE_SCOPE(cp)   /* Ignores regcppush()ed data. */
289
290 #define TRYPAREN(paren, n, input) {                             \
291     if (paren) {                                                \
292         if (n) {                                                \
293             PL_regstartp[paren] = HOPc(input, -1) - PL_bostr;   \
294             PL_regendp[paren] = input - PL_bostr;               \
295         }                                                       \
296         else                                                    \
297             PL_regendp[paren] = -1;                             \
298     }                                                           \
299     if (regmatch(next))                                         \
300         sayYES;                                                 \
301     if (paren && n)                                             \
302         PL_regendp[paren] = -1;                                 \
303 }
304
305
306 /*
307  * pregexec and friends
308  */
309
310 /*
311  - pregexec - match a regexp against a string
312  */
313 I32
314 Perl_pregexec(pTHX_ register regexp *prog, char *stringarg, register char *strend,
315          char *strbeg, I32 minend, SV *screamer, U32 nosave)
316 /* strend: pointer to null at end of string */
317 /* strbeg: real beginning of string */
318 /* minend: end of match must be >=minend after stringarg. */
319 /* nosave: For optimizations. */
320 {
321     return
322         regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
323                       nosave ? 0 : REXEC_COPY_STR);
324 }
325
326 STATIC void
327 S_cache_re(pTHX_ regexp *prog)
328 {
329     PL_regprecomp = prog->precomp;              /* Needed for FAIL. */
330 #ifdef DEBUGGING
331     PL_regprogram = prog->program;
332 #endif
333     PL_regnpar = prog->nparens;
334     PL_regdata = prog->data;
335     PL_reg_re = prog;
336 }
337
338 /*
339  * Need to implement the following flags for reg_anch:
340  *
341  * USE_INTUIT_NOML              - Useful to call re_intuit_start() first
342  * USE_INTUIT_ML
343  * INTUIT_AUTORITATIVE_NOML     - Can trust a positive answer
344  * INTUIT_AUTORITATIVE_ML
345  * INTUIT_ONCE_NOML             - Intuit can match in one location only.
346  * INTUIT_ONCE_ML
347  *
348  * Another flag for this function: SECOND_TIME (so that float substrs
349  * with giant delta may be not rechecked).
350  */
351
352 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
353
354 /* If SCREAM, then SvPVX(sv) should be compatible with strpos and strend.
355    Otherwise, only SvCUR(sv) is used to get strbeg. */
356
357 /* XXXX We assume that strpos is strbeg unless sv. */
358
359 /* XXXX Some places assume that there is a fixed substring.
360         An update may be needed if optimizer marks as "INTUITable"
361         RExen without fixed substrings.  Similarly, it is assumed that
362         lengths of all the strings are no more than minlen, thus they
363         cannot come from lookahead.
364         (Or minlen should take into account lookahead.) */
365
366 /* A failure to find a constant substring means that there is no need to make
367    an expensive call to REx engine, thus we celebrate a failure.  Similarly,
368    finding a substring too deep into the string means that less calls to
369    regtry() should be needed.
370
371    REx compiler's optimizer found 4 possible hints:
372         a) Anchored substring;
373         b) Fixed substring;
374         c) Whether we are anchored (beginning-of-line or \G);
375         d) First node (of those at offset 0) which may distingush positions;
376    We use a)b)d) and multiline-part of c), and try to find a position in the
377    string which does not contradict any of them.
378  */
379
380 /* Most of decisions we do here should have been done at compile time.
381    The nodes of the REx which we used for the search should have been
382    deleted from the finite automaton. */
383
384 char *
385 Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
386                      char *strend, U32 flags, re_scream_pos_data *data)
387 {
388     register I32 start_shift = 0;
389     /* Should be nonnegative! */
390     register I32 end_shift   = 0;
391     register char *s;
392     register SV *check;
393     char *strbeg;
394     char *t;
395     int do_utf8 = sv ? SvUTF8(sv) : 0;  /* if no sv we have to assume bytes */
396     I32 ml_anch;
397     register char *other_last = Nullch; /* other substr checked before this */
398     char *check_at = Nullch;            /* check substr found at this pos */
399 #ifdef DEBUGGING
400     char *i_strpos = strpos;
401     SV *dsv = PERL_DEBUG_PAD_ZERO(0);
402 #endif
403
404     if (prog->reganch & ROPT_UTF8) {
405         DEBUG_r(PerlIO_printf(Perl_debug_log,
406                               "UTF-8 regex...\n"));
407         PL_reg_flags |= RF_utf8;
408     }
409
410     DEBUG_r({
411          char *s   = PL_reg_match_utf8 ?
412                          sv_uni_display(dsv, sv, 60, UNI_DISPLAY_REGEX) :
413                          strpos;
414          int   len = PL_reg_match_utf8 ?
415                          strlen(s) : strend - strpos;
416          if (!PL_colorset)
417               reginitcolors();
418          if (PL_reg_match_utf8)
419              DEBUG_r(PerlIO_printf(Perl_debug_log,
420                                    "UTF-8 target...\n"));
421          PerlIO_printf(Perl_debug_log,
422                        "%sGuessing start of match, REx%s `%s%.60s%s%s' against `%s%.*s%s%s'...\n",
423                        PL_colors[4],PL_colors[5],PL_colors[0],
424                        prog->precomp,
425                        PL_colors[1],
426                        (strlen(prog->precomp) > 60 ? "..." : ""),
427                        PL_colors[0],
428                        (int)(len > 60 ? 60 : len),
429                        s, PL_colors[1],
430                        (len > 60 ? "..." : "")
431               );
432     });
433
434     /* CHR_DIST() would be more correct here but it makes things slow. */
435     if (prog->minlen > strend - strpos) {
436         DEBUG_r(PerlIO_printf(Perl_debug_log,
437                               "String too short... [re_intuit_start]\n"));
438         goto fail;
439     }
440     strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
441     PL_regeol = strend;
442     if (do_utf8) {
443         if (!prog->check_utf8 && prog->check_substr)
444             to_utf8_substr(prog);
445         check = prog->check_utf8;
446     } else {
447         if (!prog->check_substr && prog->check_utf8)
448             to_byte_substr(prog);
449         check = prog->check_substr;
450     }
451    if (check == &PL_sv_undef) {
452         DEBUG_r(PerlIO_printf(Perl_debug_log,
453                 "Non-utf string cannot match utf check string\n"));
454         goto fail;
455     }
456     if (prog->reganch & ROPT_ANCH) {    /* Match at beg-of-str or after \n */
457         ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
458                      || ( (prog->reganch & ROPT_ANCH_BOL)
459                           && !PL_multiline ) ); /* Check after \n? */
460
461         if (!ml_anch) {
462           if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */
463                                   | ROPT_IMPLICIT)) /* not a real BOL */
464                /* SvCUR is not set on references: SvRV and SvPVX overlap */
465                && sv && !SvROK(sv)
466                && (strpos != strbeg)) {
467               DEBUG_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
468               goto fail;
469           }
470           if (prog->check_offset_min == prog->check_offset_max &&
471               !(prog->reganch & ROPT_CANY_SEEN)) {
472             /* Substring at constant offset from beg-of-str... */
473             I32 slen;
474
475             s = HOP3c(strpos, prog->check_offset_min, strend);
476             if (SvTAIL(check)) {
477                 slen = SvCUR(check);    /* >= 1 */
478
479                 if ( strend - s > slen || strend - s < slen - 1
480                      || (strend - s == slen && strend[-1] != '\n')) {
481                     DEBUG_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
482                     goto fail_finish;
483                 }
484                 /* Now should match s[0..slen-2] */
485                 slen--;
486                 if (slen && (*SvPVX(check) != *s
487                              || (slen > 1
488                                  && memNE(SvPVX(check), s, slen)))) {
489                   report_neq:
490                     DEBUG_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
491                     goto fail_finish;
492                 }
493             }
494             else if (*SvPVX(check) != *s
495                      || ((slen = SvCUR(check)) > 1
496                          && memNE(SvPVX(check), s, slen)))
497                 goto report_neq;
498             goto success_at_start;
499           }
500         }
501         /* Match is anchored, but substr is not anchored wrt beg-of-str. */
502         s = strpos;
503         start_shift = prog->check_offset_min; /* okay to underestimate on CC */
504         end_shift = prog->minlen - start_shift -
505             CHR_SVLEN(check) + (SvTAIL(check) != 0);
506         if (!ml_anch) {
507             I32 end = prog->check_offset_max + CHR_SVLEN(check)
508                                          - (SvTAIL(check) != 0);
509             I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
510
511             if (end_shift < eshift)
512                 end_shift = eshift;
513         }
514     }
515     else {                              /* Can match at random position */
516         ml_anch = 0;
517         s = strpos;
518         start_shift = prog->check_offset_min; /* okay to underestimate on CC */
519         /* Should be nonnegative! */
520         end_shift = prog->minlen - start_shift -
521             CHR_SVLEN(check) + (SvTAIL(check) != 0);
522     }
523
524 #ifdef DEBUGGING        /* 7/99: reports of failure (with the older version) */
525     if (end_shift < 0)
526         Perl_croak(aTHX_ "panic: end_shift");
527 #endif
528
529   restart:
530     /* Find a possible match in the region s..strend by looking for
531        the "check" substring in the region corrected by start/end_shift. */
532     if (flags & REXEC_SCREAM) {
533         I32 p = -1;                     /* Internal iterator of scream. */
534         I32 *pp = data ? data->scream_pos : &p;
535
536         if (PL_screamfirst[BmRARE(check)] >= 0
537             || ( BmRARE(check) == '\n'
538                  && (BmPREVIOUS(check) == SvCUR(check) - 1)
539                  && SvTAIL(check) ))
540             s = screaminstr(sv, check,
541                             start_shift + (s - strbeg), end_shift, pp, 0);
542         else
543             goto fail_finish;
544         if (data)
545             *data->scream_olds = s;
546     }
547     else if (prog->reganch & ROPT_CANY_SEEN)
548         s = fbm_instr((U8*)(s + start_shift),
549                       (U8*)(strend - end_shift),
550                       check, PL_multiline ? FBMrf_MULTILINE : 0);
551     else
552         s = fbm_instr(HOP3(s, start_shift, strend),
553                       HOP3(strend, -end_shift, strbeg),
554                       check, PL_multiline ? FBMrf_MULTILINE : 0);
555
556     /* Update the count-of-usability, remove useless subpatterns,
557         unshift s.  */
558
559     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s %s substr `%s%.*s%s'%s%s",
560                           (s ? "Found" : "Did not find"),
561                           (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) ? "anchored" : "floating"),
562                           PL_colors[0],
563                           (int)(SvCUR(check) - (SvTAIL(check)!=0)),
564                           SvPVX(check),
565                           PL_colors[1], (SvTAIL(check) ? "$" : ""),
566                           (s ? " at offset " : "...\n") ) );
567
568     if (!s)
569         goto fail_finish;
570
571     check_at = s;
572
573     /* Finish the diagnostic message */
574     DEBUG_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
575
576     /* Got a candidate.  Check MBOL anchoring, and the *other* substr.
577        Start with the other substr.
578        XXXX no SCREAM optimization yet - and a very coarse implementation
579        XXXX /ttx+/ results in anchored=`ttx', floating=`x'.  floating will
580                 *always* match.  Probably should be marked during compile...
581        Probably it is right to do no SCREAM here...
582      */
583
584     if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8) : (prog->float_substr && prog->anchored_substr)) {
585         /* Take into account the "other" substring. */
586         /* XXXX May be hopelessly wrong for UTF... */
587         if (!other_last)
588             other_last = strpos;
589         if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
590           do_other_anchored:
591             {
592                 char *last = HOP3c(s, -start_shift, strbeg), *last1, *last2;
593                 char *s1 = s;
594                 SV* must;
595
596                 t = s - prog->check_offset_max;
597                 if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
598                     && (!do_utf8
599                         || ((t = reghopmaybe3_c(s, -(prog->check_offset_max), strpos))
600                             && t > strpos)))
601                     /* EMPTY */;
602                 else
603                     t = strpos;
604                 t = HOP3c(t, prog->anchored_offset, strend);
605                 if (t < other_last)     /* These positions already checked */
606                     t = other_last;
607                 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
608                 if (last < last1)
609                     last1 = last;
610  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
611                 /* On end-of-str: see comment below. */
612                 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
613                 if (must == &PL_sv_undef) {
614                     s = (char*)NULL;
615                     DEBUG_r(must = prog->anchored_utf8);        /* for debug */
616                 }
617                 else
618                     s = fbm_instr(
619                         (unsigned char*)t,
620                         HOP3(HOP3(last1, prog->anchored_offset, strend)
621                                 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
622                         must,
623                         PL_multiline ? FBMrf_MULTILINE : 0
624                     );
625                 DEBUG_r(PerlIO_printf(Perl_debug_log,
626                         "%s anchored substr `%s%.*s%s'%s",
627                         (s ? "Found" : "Contradicts"),
628                         PL_colors[0],
629                           (int)(SvCUR(must)
630                           - (SvTAIL(must)!=0)),
631                           SvPVX(must),
632                           PL_colors[1], (SvTAIL(must) ? "$" : "")));
633                 if (!s) {
634                     if (last1 >= last2) {
635                         DEBUG_r(PerlIO_printf(Perl_debug_log,
636                                                 ", giving up...\n"));
637                         goto fail_finish;
638                     }
639                     DEBUG_r(PerlIO_printf(Perl_debug_log,
640                         ", trying floating at offset %ld...\n",
641                         (long)(HOP3c(s1, 1, strend) - i_strpos)));
642                     other_last = HOP3c(last1, prog->anchored_offset+1, strend);
643                     s = HOP3c(last, 1, strend);
644                     goto restart;
645                 }
646                 else {
647                     DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
648                           (long)(s - i_strpos)));
649                     t = HOP3c(s, -prog->anchored_offset, strbeg);
650                     other_last = HOP3c(s, 1, strend);
651                     s = s1;
652                     if (t == strpos)
653                         goto try_at_start;
654                     goto try_at_offset;
655                 }
656             }
657         }
658         else {          /* Take into account the floating substring. */
659             char *last, *last1;
660             char *s1 = s;
661             SV* must;
662
663             t = HOP3c(s, -start_shift, strbeg);
664             last1 = last =
665                 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
666             if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
667                 last = HOP3c(t, prog->float_max_offset, strend);
668             s = HOP3c(t, prog->float_min_offset, strend);
669             if (s < other_last)
670                 s = other_last;
671  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
672             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
673             /* fbm_instr() takes into account exact value of end-of-str
674                if the check is SvTAIL(ed).  Since false positives are OK,
675                and end-of-str is not later than strend we are OK. */
676             if (must == &PL_sv_undef) {
677                 s = (char*)NULL;
678                 DEBUG_r(must = prog->float_utf8);       /* for debug message */
679             }
680             else
681                 s = fbm_instr((unsigned char*)s,
682                               (unsigned char*)last + SvCUR(must)
683                                   - (SvTAIL(must)!=0),
684                               must, PL_multiline ? FBMrf_MULTILINE : 0);
685             DEBUG_r(PerlIO_printf(Perl_debug_log, "%s floating substr `%s%.*s%s'%s",
686                     (s ? "Found" : "Contradicts"),
687                     PL_colors[0],
688                       (int)(SvCUR(must) - (SvTAIL(must)!=0)),
689                       SvPVX(must),
690                       PL_colors[1], (SvTAIL(must) ? "$" : "")));
691             if (!s) {
692                 if (last1 == last) {
693                     DEBUG_r(PerlIO_printf(Perl_debug_log,
694                                             ", giving up...\n"));
695                     goto fail_finish;
696                 }
697                 DEBUG_r(PerlIO_printf(Perl_debug_log,
698                     ", trying anchored starting at offset %ld...\n",
699                     (long)(s1 + 1 - i_strpos)));
700                 other_last = last;
701                 s = HOP3c(t, 1, strend);
702                 goto restart;
703             }
704             else {
705                 DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
706                       (long)(s - i_strpos)));
707                 other_last = s; /* Fix this later. --Hugo */
708                 s = s1;
709                 if (t == strpos)
710                     goto try_at_start;
711                 goto try_at_offset;
712             }
713         }
714     }
715
716     t = s - prog->check_offset_max;
717     if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
718         && (!do_utf8
719             || ((t = reghopmaybe3_c(s, -prog->check_offset_max, strpos))
720                  && t > strpos))) {
721         /* Fixed substring is found far enough so that the match
722            cannot start at strpos. */
723       try_at_offset:
724         if (ml_anch && t[-1] != '\n') {
725             /* Eventually fbm_*() should handle this, but often
726                anchored_offset is not 0, so this check will not be wasted. */
727             /* XXXX In the code below we prefer to look for "^" even in
728                presence of anchored substrings.  And we search even
729                beyond the found float position.  These pessimizations
730                are historical artefacts only.  */
731           find_anchor:
732             while (t < strend - prog->minlen) {
733                 if (*t == '\n') {
734                     if (t < check_at - prog->check_offset_min) {
735                         if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
736                             /* Since we moved from the found position,
737                                we definitely contradict the found anchored
738                                substr.  Due to the above check we do not
739                                contradict "check" substr.
740                                Thus we can arrive here only if check substr
741                                is float.  Redo checking for "other"=="fixed".
742                              */
743                             strpos = t + 1;                     
744                             DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
745                                 PL_colors[0],PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
746                             goto do_other_anchored;
747                         }
748                         /* We don't contradict the found floating substring. */
749                         /* XXXX Why not check for STCLASS? */
750                         s = t + 1;
751                         DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
752                             PL_colors[0],PL_colors[1], (long)(s - i_strpos)));
753                         goto set_useful;
754                     }
755                     /* Position contradicts check-string */
756                     /* XXXX probably better to look for check-string
757                        than for "\n", so one should lower the limit for t? */
758                     DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
759                         PL_colors[0],PL_colors[1], (long)(t + 1 - i_strpos)));
760                     other_last = strpos = s = t + 1;
761                     goto restart;
762                 }
763                 t++;
764             }
765             DEBUG_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
766                         PL_colors[0],PL_colors[1]));
767             goto fail_finish;
768         }
769         else {
770             DEBUG_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
771                         PL_colors[0],PL_colors[1]));
772         }
773         s = t;
774       set_useful:
775         ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr);    /* hooray/5 */
776     }
777     else {
778         /* The found string does not prohibit matching at strpos,
779            - no optimization of calling REx engine can be performed,
780            unless it was an MBOL and we are not after MBOL,
781            or a future STCLASS check will fail this. */
782       try_at_start:
783         /* Even in this situation we may use MBOL flag if strpos is offset
784            wrt the start of the string. */
785         if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
786             && (strpos != strbeg) && strpos[-1] != '\n'
787             /* May be due to an implicit anchor of m{.*foo}  */
788             && !(prog->reganch & ROPT_IMPLICIT))
789         {
790             t = strpos;
791             goto find_anchor;
792         }
793         DEBUG_r( if (ml_anch)
794             PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
795                         (long)(strpos - i_strpos), PL_colors[0],PL_colors[1]);
796         );
797       success_at_start:
798         if (!(prog->reganch & ROPT_NAUGHTY)     /* XXXX If strpos moved? */
799             && (do_utf8 ? (
800                 prog->check_utf8                /* Could be deleted already */
801                 && --BmUSEFUL(prog->check_utf8) < 0
802                 && (prog->check_utf8 == prog->float_utf8)
803             ) : (
804                 prog->check_substr              /* Could be deleted already */
805                 && --BmUSEFUL(prog->check_substr) < 0
806                 && (prog->check_substr == prog->float_substr)
807             )))
808         {
809             /* If flags & SOMETHING - do not do it many times on the same match */
810             DEBUG_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
811             SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
812             if (do_utf8 ? prog->check_substr : prog->check_utf8)
813                 SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
814             prog->check_substr = prog->check_utf8 = Nullsv;     /* disable */
815             prog->float_substr = prog->float_utf8 = Nullsv;     /* clear */
816             check = Nullsv;                     /* abort */
817             s = strpos;
818             /* XXXX This is a remnant of the old implementation.  It
819                     looks wasteful, since now INTUIT can use many
820                     other heuristics. */
821             prog->reganch &= ~RE_USE_INTUIT;
822         }
823         else
824             s = strpos;
825     }
826
827     /* Last resort... */
828     /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
829     if (prog->regstclass) {
830         /* minlen == 0 is possible if regstclass is \b or \B,
831            and the fixed substr is ''$.
832            Since minlen is already taken into account, s+1 is before strend;
833            accidentally, minlen >= 1 guaranties no false positives at s + 1
834            even for \b or \B.  But (minlen? 1 : 0) below assumes that
835            regstclass does not come from lookahead...  */
836         /* If regstclass takes bytelength more than 1: If charlength==1, OK.
837            This leaves EXACTF only, which is dealt with in find_byclass().  */
838         U8* str = (U8*)STRING(prog->regstclass);
839         int cl_l = (PL_regkind[(U8)OP(prog->regstclass)] == EXACT
840                     ? CHR_DIST(str+STR_LEN(prog->regstclass), str)
841                     : 1);
842         char *endpos = (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
843                 ? HOP3c(s, (prog->minlen ? cl_l : 0), strend)
844                 : (prog->float_substr || prog->float_utf8
845                    ? HOP3c(HOP3c(check_at, -start_shift, strbeg),
846                            cl_l, strend)
847                    : strend);
848         char *startpos = strbeg;
849
850         t = s;
851         if (prog->reganch & ROPT_UTF8) {        
852             PL_regdata = prog->data;
853             PL_bostr = startpos;
854         }
855         s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1);
856         if (!s) {
857 #ifdef DEBUGGING
858             char *what = 0;
859 #endif
860             if (endpos == strend) {
861                 DEBUG_r( PerlIO_printf(Perl_debug_log,
862                                 "Could not match STCLASS...\n") );
863                 goto fail;
864             }
865             DEBUG_r( PerlIO_printf(Perl_debug_log,
866                                    "This position contradicts STCLASS...\n") );
867             if ((prog->reganch & ROPT_ANCH) && !ml_anch)
868                 goto fail;
869             /* Contradict one of substrings */
870             if (prog->anchored_substr || prog->anchored_utf8) {
871                 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
872                     DEBUG_r( what = "anchored" );
873                   hop_and_restart:
874                     s = HOP3c(t, 1, strend);
875                     if (s + start_shift + end_shift > strend) {
876                         /* XXXX Should be taken into account earlier? */
877                         DEBUG_r( PerlIO_printf(Perl_debug_log,
878                                                "Could not match STCLASS...\n") );
879                         goto fail;
880                     }
881                     if (!check)
882                         goto giveup;
883                     DEBUG_r( PerlIO_printf(Perl_debug_log,
884                                 "Looking for %s substr starting at offset %ld...\n",
885                                  what, (long)(s + start_shift - i_strpos)) );
886                     goto restart;
887                 }
888                 /* Have both, check_string is floating */
889                 if (t + start_shift >= check_at) /* Contradicts floating=check */
890                     goto retry_floating_check;
891                 /* Recheck anchored substring, but not floating... */
892                 s = check_at;
893                 if (!check)
894                     goto giveup;
895                 DEBUG_r( PerlIO_printf(Perl_debug_log,
896                           "Looking for anchored substr starting at offset %ld...\n",
897                           (long)(other_last - i_strpos)) );
898                 goto do_other_anchored;
899             }
900             /* Another way we could have checked stclass at the
901                current position only: */
902             if (ml_anch) {
903                 s = t = t + 1;
904                 if (!check)
905                     goto giveup;
906                 DEBUG_r( PerlIO_printf(Perl_debug_log,
907                           "Looking for /%s^%s/m starting at offset %ld...\n",
908                           PL_colors[0],PL_colors[1], (long)(t - i_strpos)) );
909                 goto try_at_offset;
910             }
911             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))     /* Could have been deleted */
912                 goto fail;
913             /* Check is floating subtring. */
914           retry_floating_check:
915             t = check_at - start_shift;
916             DEBUG_r( what = "floating" );
917             goto hop_and_restart;
918         }
919         if (t != s) {
920             DEBUG_r(PerlIO_printf(Perl_debug_log,
921                         "By STCLASS: moving %ld --> %ld\n",
922                                   (long)(t - i_strpos), (long)(s - i_strpos))
923                    );
924         }
925         else {
926             DEBUG_r(PerlIO_printf(Perl_debug_log,
927                                   "Does not contradict STCLASS...\n"); 
928                    );
929         }
930     }
931   giveup:
932     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
933                           PL_colors[4], (check ? "Guessed" : "Giving up"),
934                           PL_colors[5], (long)(s - i_strpos)) );
935     return s;
936
937   fail_finish:                          /* Substring not found */
938     if (prog->check_substr || prog->check_utf8)         /* could be removed already */
939         BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
940   fail:
941     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
942                           PL_colors[4],PL_colors[5]));
943     return Nullch;
944 }
945
946 /* We know what class REx starts with.  Try to find this position... */
947 STATIC char *
948 S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *startpos, I32 norun)
949 {
950         I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
951         char *m;
952         STRLEN ln;
953         unsigned int c1;
954         unsigned int c2;
955         char *e;
956         register I32 tmp = 1;   /* Scratch variable? */
957         register bool do_utf8 = PL_reg_match_utf8;
958
959         /* We know what class it must start with. */
960         switch (OP(c)) {
961         case ANYOF:
962             if (do_utf8) {
963                  while (s < strend) {
964                       if ((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
965                           !UTF8_IS_INVARIANT((U8)s[0]) ?
966                           reginclass(c, (U8*)s, 0, do_utf8) :
967                           REGINCLASS(c, (U8*)s)) {
968                            if (tmp && (norun || regtry(prog, s)))
969                                 goto got_it;
970                            else
971                                 tmp = doevery;
972                       }
973                       else 
974                            tmp = 1;
975                       s += UTF8SKIP(s);
976                  }
977             }
978             else {
979                  while (s < strend) {
980                       STRLEN skip = 1;
981
982                       if (REGINCLASS(c, (U8*)s) ||
983                           (ANYOF_FOLD_SHARP_S(c, s, strend) &&
984                            /* The assignment of 2 is intentional:
985                             * for the folded sharp s, the skip is 2. */
986                            (skip = SHARP_S_SKIP))) {
987                            if (tmp && (norun || regtry(prog, s)))
988                                 goto got_it;
989                            else
990                                 tmp = doevery;
991                       }
992                       else 
993                            tmp = 1;
994                       s += skip;
995                  }
996             }
997             break;
998         case CANY:
999             while (s < strend) {
1000                 if (tmp && (norun || regtry(prog, s)))
1001                     goto got_it;
1002                 else
1003                     tmp = doevery;
1004                 s++;
1005             }
1006             break;
1007         case EXACTF:
1008             m = STRING(c);
1009             ln = STR_LEN(c);
1010             if (UTF) {
1011                 STRLEN ulen1, ulen2;
1012                 U8 tmpbuf1[UTF8_MAXLEN_UCLC+1];
1013                 U8 tmpbuf2[UTF8_MAXLEN_UCLC+1];
1014
1015                 to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1016                 to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1017
1018                 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN_UCLC, 
1019                                     0, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1020                 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN_UCLC,
1021                                     0, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1022             }
1023             else {
1024                 c1 = *(U8*)m;
1025                 c2 = PL_fold[c1];
1026             }
1027             goto do_exactf;
1028         case EXACTFL:
1029             m = STRING(c);
1030             ln = STR_LEN(c);
1031             c1 = *(U8*)m;
1032             c2 = PL_fold_locale[c1];
1033           do_exactf:
1034             e = HOP3c(strend, -(I32)ln, s);
1035
1036             if (norun && e < s)
1037                 e = s;                  /* Due to minlen logic of intuit() */
1038
1039             /* The idea in the EXACTF* cases is to first find the
1040              * first character of the EXACTF* node and then, if
1041              * necessary, case-insensitively compare the full
1042              * text of the node.  The c1 and c2 are the first
1043              * characters (though in Unicode it gets a bit
1044              * more complicated because there are more cases
1045              * than just upper and lower: one needs to use
1046              * the so-called folding case for case-insensitive
1047              * matching (called "loose matching" in Unicode).
1048              * ibcmp_utf8() will do just that. */
1049
1050             if (do_utf8) {
1051                 UV c, f;
1052                 U8 tmpbuf [UTF8_MAXLEN+1];
1053                 U8 foldbuf[UTF8_MAXLEN_FOLD+1];
1054                 STRLEN len, foldlen;
1055                 
1056                 if (c1 == c2) {
1057                     while (s <= e) {
1058                         c = utf8n_to_uvchr((U8*)s, UTF8_MAXLEN, &len,
1059                                            ckWARN(WARN_UTF8) ?
1060                                            0 : UTF8_ALLOW_ANY);
1061                         if ( c == c1
1062                              && (ln == len ||
1063                                  ibcmp_utf8(s, (char **)0, 0,  do_utf8,
1064                                             m, (char **)0, ln, (bool)UTF))
1065                              && (norun || regtry(prog, s)) )
1066                             goto got_it;
1067                         else {
1068                              uvchr_to_utf8(tmpbuf, c);
1069                              f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
1070                              if ( f != c
1071                                   && (f == c1 || f == c2)
1072                                   && (ln == foldlen ||
1073                                       !ibcmp_utf8((char *) foldbuf,
1074                                                   (char **)0, foldlen, do_utf8,
1075                                                   m,
1076                                                   (char **)0, ln, (bool)UTF))
1077                                   && (norun || regtry(prog, s)) )
1078                                   goto got_it;
1079                         }
1080                         s += len;
1081                     }
1082                 }
1083                 else {
1084                     while (s <= e) {
1085                       c = utf8n_to_uvchr((U8*)s, UTF8_MAXLEN, &len,
1086                                            ckWARN(WARN_UTF8) ?
1087                                            0 : UTF8_ALLOW_ANY);
1088
1089                         /* Handle some of the three Greek sigmas cases.
1090                          * Note that not all the possible combinations
1091                          * are handled here: some of them are handled
1092                          * by the standard folding rules, and some of
1093                          * them (the character class or ANYOF cases)
1094                          * are handled during compiletime in
1095                          * regexec.c:S_regclass(). */
1096                         if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1097                             c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1098                             c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1099
1100                         if ( (c == c1 || c == c2)
1101                              && (ln == len ||
1102                                  ibcmp_utf8(s, (char **)0, 0,  do_utf8,
1103                                             m, (char **)0, ln, (bool)UTF))
1104                              && (norun || regtry(prog, s)) )
1105                             goto got_it;
1106                         else {
1107                              uvchr_to_utf8(tmpbuf, c);
1108                              f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
1109                              if ( f != c
1110                                   && (f == c1 || f == c2)
1111                                   && (ln == foldlen ||
1112                                       !ibcmp_utf8((char *) foldbuf,
1113                                                   (char **)0, foldlen, do_utf8,
1114                                                   m,
1115                                                   (char **)0, ln, (bool)UTF))
1116                                   && (norun || regtry(prog, s)) )
1117                                   goto got_it;
1118                         }
1119                         s += len;
1120                     }
1121                 }
1122             }
1123             else {
1124                 if (c1 == c2)
1125                     while (s <= e) {
1126                         if ( *(U8*)s == c1
1127                              && (ln == 1 || !(OP(c) == EXACTF
1128                                               ? ibcmp(s, m, ln)
1129                                               : ibcmp_locale(s, m, ln)))
1130                              && (norun || regtry(prog, s)) )
1131                             goto got_it;
1132                         s++;
1133                     }
1134                 else
1135                     while (s <= e) {
1136                         if ( (*(U8*)s == c1 || *(U8*)s == c2)
1137                              && (ln == 1 || !(OP(c) == EXACTF
1138                                               ? ibcmp(s, m, ln)
1139                                               : ibcmp_locale(s, m, ln)))
1140                              && (norun || regtry(prog, s)) )
1141                             goto got_it;
1142                         s++;
1143                     }
1144             }
1145             break;
1146         case BOUNDL:
1147             PL_reg_flags |= RF_tainted;
1148             /* FALL THROUGH */
1149         case BOUND:
1150             if (do_utf8) {
1151                 if (s == PL_bostr)
1152                     tmp = '\n';
1153                 else {
1154                     U8 *r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1155                 
1156                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, 0);
1157                 }
1158                 tmp = ((OP(c) == BOUND ?
1159                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1160                 LOAD_UTF8_CHARCLASS(alnum,"a");
1161                 while (s < strend) {
1162                     if (tmp == !(OP(c) == BOUND ?
1163                                  swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1164                                  isALNUM_LC_utf8((U8*)s)))
1165                     {
1166                         tmp = !tmp;
1167                         if ((norun || regtry(prog, s)))
1168                             goto got_it;
1169                     }
1170                     s += UTF8SKIP(s);
1171                 }
1172             }
1173             else {
1174                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1175                 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1176                 while (s < strend) {
1177                     if (tmp ==
1178                         !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1179                         tmp = !tmp;
1180                         if ((norun || regtry(prog, s)))
1181                             goto got_it;
1182                     }
1183                     s++;
1184                 }
1185             }
1186             if ((!prog->minlen && tmp) && (norun || regtry(prog, s)))
1187                 goto got_it;
1188             break;
1189         case NBOUNDL:
1190             PL_reg_flags |= RF_tainted;
1191             /* FALL THROUGH */
1192         case NBOUND:
1193             if (do_utf8) {
1194                 if (s == PL_bostr)
1195                     tmp = '\n';
1196                 else {
1197                     U8 *r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1198                 
1199                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, 0);
1200                 }
1201                 tmp = ((OP(c) == NBOUND ?
1202                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1203                 LOAD_UTF8_CHARCLASS(alnum,"a");
1204                 while (s < strend) {
1205                     if (tmp == !(OP(c) == NBOUND ?
1206                                  swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1207                                  isALNUM_LC_utf8((U8*)s)))
1208                         tmp = !tmp;
1209                     else if ((norun || regtry(prog, s)))
1210                         goto got_it;
1211                     s += UTF8SKIP(s);
1212                 }
1213             }
1214             else {
1215                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1216                 tmp = ((OP(c) == NBOUND ?
1217                         isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1218                 while (s < strend) {
1219                     if (tmp ==
1220                         !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1221                         tmp = !tmp;
1222                     else if ((norun || regtry(prog, s)))
1223                         goto got_it;
1224                     s++;
1225                 }
1226             }
1227             if ((!prog->minlen && !tmp) && (norun || regtry(prog, s)))
1228                 goto got_it;
1229             break;
1230         case ALNUM:
1231             if (do_utf8) {
1232                 LOAD_UTF8_CHARCLASS(alnum,"a");
1233                 while (s < strend) {
1234                     if (swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1235                         if (tmp && (norun || regtry(prog, s)))
1236                             goto got_it;
1237                         else
1238                             tmp = doevery;
1239                     }
1240                     else
1241                         tmp = 1;
1242                     s += UTF8SKIP(s);
1243                 }
1244             }
1245             else {
1246                 while (s < strend) {
1247                     if (isALNUM(*s)) {
1248                         if (tmp && (norun || regtry(prog, s)))
1249                             goto got_it;
1250                         else
1251                             tmp = doevery;
1252                     }
1253                     else
1254                         tmp = 1;
1255                     s++;
1256                 }
1257             }
1258             break;
1259         case ALNUML:
1260             PL_reg_flags |= RF_tainted;
1261             if (do_utf8) {
1262                 while (s < strend) {
1263                     if (isALNUM_LC_utf8((U8*)s)) {
1264                         if (tmp && (norun || regtry(prog, s)))
1265                             goto got_it;
1266                         else
1267                             tmp = doevery;
1268                     }
1269                     else
1270                         tmp = 1;
1271                     s += UTF8SKIP(s);
1272                 }
1273             }
1274             else {
1275                 while (s < strend) {
1276                     if (isALNUM_LC(*s)) {
1277                         if (tmp && (norun || regtry(prog, s)))
1278                             goto got_it;
1279                         else
1280                             tmp = doevery;
1281                     }
1282                     else
1283                         tmp = 1;
1284                     s++;
1285                 }
1286             }
1287             break;
1288         case NALNUM:
1289             if (do_utf8) {
1290                 LOAD_UTF8_CHARCLASS(alnum,"a");
1291                 while (s < strend) {
1292                     if (!swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1293                         if (tmp && (norun || regtry(prog, s)))
1294                             goto got_it;
1295                         else
1296                             tmp = doevery;
1297                     }
1298                     else
1299                         tmp = 1;
1300                     s += UTF8SKIP(s);
1301                 }
1302             }
1303             else {
1304                 while (s < strend) {
1305                     if (!isALNUM(*s)) {
1306                         if (tmp && (norun || regtry(prog, s)))
1307                             goto got_it;
1308                         else
1309                             tmp = doevery;
1310                     }
1311                     else
1312                         tmp = 1;
1313                     s++;
1314                 }
1315             }
1316             break;
1317         case NALNUML:
1318             PL_reg_flags |= RF_tainted;
1319             if (do_utf8) {
1320                 while (s < strend) {
1321                     if (!isALNUM_LC_utf8((U8*)s)) {
1322                         if (tmp && (norun || regtry(prog, s)))
1323                             goto got_it;
1324                         else
1325                             tmp = doevery;
1326                     }
1327                     else
1328                         tmp = 1;
1329                     s += UTF8SKIP(s);
1330                 }
1331             }
1332             else {
1333                 while (s < strend) {
1334                     if (!isALNUM_LC(*s)) {
1335                         if (tmp && (norun || regtry(prog, s)))
1336                             goto got_it;
1337                         else
1338                             tmp = doevery;
1339                     }
1340                     else
1341                         tmp = 1;
1342                     s++;
1343                 }
1344             }
1345             break;
1346         case SPACE:
1347             if (do_utf8) {
1348                 LOAD_UTF8_CHARCLASS(space," ");
1349                 while (s < strend) {
1350                     if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)) {
1351                         if (tmp && (norun || regtry(prog, s)))
1352                             goto got_it;
1353                         else
1354                             tmp = doevery;
1355                     }
1356                     else
1357                         tmp = 1;
1358                     s += UTF8SKIP(s);
1359                 }
1360             }
1361             else {
1362                 while (s < strend) {
1363                     if (isSPACE(*s)) {
1364                         if (tmp && (norun || regtry(prog, s)))
1365                             goto got_it;
1366                         else
1367                             tmp = doevery;
1368                     }
1369                     else
1370                         tmp = 1;
1371                     s++;
1372                 }
1373             }
1374             break;
1375         case SPACEL:
1376             PL_reg_flags |= RF_tainted;
1377             if (do_utf8) {
1378                 while (s < strend) {
1379                     if (*s == ' ' || isSPACE_LC_utf8((U8*)s)) {
1380                         if (tmp && (norun || regtry(prog, s)))
1381                             goto got_it;
1382                         else
1383                             tmp = doevery;
1384                     }
1385                     else
1386                         tmp = 1;
1387                     s += UTF8SKIP(s);
1388                 }
1389             }
1390             else {
1391                 while (s < strend) {
1392                     if (isSPACE_LC(*s)) {
1393                         if (tmp && (norun || regtry(prog, s)))
1394                             goto got_it;
1395                         else
1396                             tmp = doevery;
1397                     }
1398                     else
1399                         tmp = 1;
1400                     s++;
1401                 }
1402             }
1403             break;
1404         case NSPACE:
1405             if (do_utf8) {
1406                 LOAD_UTF8_CHARCLASS(space," ");
1407                 while (s < strend) {
1408                     if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8))) {
1409                         if (tmp && (norun || regtry(prog, s)))
1410                             goto got_it;
1411                         else
1412                             tmp = doevery;
1413                     }
1414                     else
1415                         tmp = 1;
1416                     s += UTF8SKIP(s);
1417                 }
1418             }
1419             else {
1420                 while (s < strend) {
1421                     if (!isSPACE(*s)) {
1422                         if (tmp && (norun || regtry(prog, s)))
1423                             goto got_it;
1424                         else
1425                             tmp = doevery;
1426                     }
1427                     else
1428                         tmp = 1;
1429                     s++;
1430                 }
1431             }
1432             break;
1433         case NSPACEL:
1434             PL_reg_flags |= RF_tainted;
1435             if (do_utf8) {
1436                 while (s < strend) {
1437                     if (!(*s == ' ' || isSPACE_LC_utf8((U8*)s))) {
1438                         if (tmp && (norun || regtry(prog, s)))
1439                             goto got_it;
1440                         else
1441                             tmp = doevery;
1442                     }
1443                     else
1444                         tmp = 1;
1445                     s += UTF8SKIP(s);
1446                 }
1447             }
1448             else {
1449                 while (s < strend) {
1450                     if (!isSPACE_LC(*s)) {
1451                         if (tmp && (norun || regtry(prog, s)))
1452                             goto got_it;
1453                         else
1454                             tmp = doevery;
1455                     }
1456                     else
1457                         tmp = 1;
1458                     s++;
1459                 }
1460             }
1461             break;
1462         case DIGIT:
1463             if (do_utf8) {
1464                 LOAD_UTF8_CHARCLASS(digit,"0");
1465                 while (s < strend) {
1466                     if (swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1467                         if (tmp && (norun || regtry(prog, s)))
1468                             goto got_it;
1469                         else
1470                             tmp = doevery;
1471                     }
1472                     else
1473                         tmp = 1;
1474                     s += UTF8SKIP(s);
1475                 }
1476             }
1477             else {
1478                 while (s < strend) {
1479                     if (isDIGIT(*s)) {
1480                         if (tmp && (norun || regtry(prog, s)))
1481                             goto got_it;
1482                         else
1483                             tmp = doevery;
1484                     }
1485                     else
1486                         tmp = 1;
1487                     s++;
1488                 }
1489             }
1490             break;
1491         case DIGITL:
1492             PL_reg_flags |= RF_tainted;
1493             if (do_utf8) {
1494                 while (s < strend) {
1495                     if (isDIGIT_LC_utf8((U8*)s)) {
1496                         if (tmp && (norun || regtry(prog, s)))
1497                             goto got_it;
1498                         else
1499                             tmp = doevery;
1500                     }
1501                     else
1502                         tmp = 1;
1503                     s += UTF8SKIP(s);
1504                 }
1505             }
1506             else {
1507                 while (s < strend) {
1508                     if (isDIGIT_LC(*s)) {
1509                         if (tmp && (norun || regtry(prog, s)))
1510                             goto got_it;
1511                         else
1512                             tmp = doevery;
1513                     }
1514                     else
1515                         tmp = 1;
1516                     s++;
1517                 }
1518             }
1519             break;
1520         case NDIGIT:
1521             if (do_utf8) {
1522                 LOAD_UTF8_CHARCLASS(digit,"0");
1523                 while (s < strend) {
1524                     if (!swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1525                         if (tmp && (norun || regtry(prog, s)))
1526                             goto got_it;
1527                         else
1528                             tmp = doevery;
1529                     }
1530                     else
1531                         tmp = 1;
1532                     s += UTF8SKIP(s);
1533                 }
1534             }
1535             else {
1536                 while (s < strend) {
1537                     if (!isDIGIT(*s)) {
1538                         if (tmp && (norun || regtry(prog, s)))
1539                             goto got_it;
1540                         else
1541                             tmp = doevery;
1542                     }
1543                     else
1544                         tmp = 1;
1545                     s++;
1546                 }
1547             }
1548             break;
1549         case NDIGITL:
1550             PL_reg_flags |= RF_tainted;
1551             if (do_utf8) {
1552                 while (s < strend) {
1553                     if (!isDIGIT_LC_utf8((U8*)s)) {
1554                         if (tmp && (norun || regtry(prog, s)))
1555                             goto got_it;
1556                         else
1557                             tmp = doevery;
1558                     }
1559                     else
1560                         tmp = 1;
1561                     s += UTF8SKIP(s);
1562                 }
1563             }
1564             else {
1565                 while (s < strend) {
1566                     if (!isDIGIT_LC(*s)) {
1567                         if (tmp && (norun || regtry(prog, s)))
1568                             goto got_it;
1569                         else
1570                             tmp = doevery;
1571                     }
1572                     else
1573                         tmp = 1;
1574                     s++;
1575                 }
1576             }
1577             break;
1578         default:
1579             Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1580             break;
1581         }
1582         return 0;
1583       got_it:
1584         return s;
1585 }
1586
1587 /*
1588  - regexec_flags - match a regexp against a string
1589  */
1590 I32
1591 Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *strend,
1592               char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1593 /* strend: pointer to null at end of string */
1594 /* strbeg: real beginning of string */
1595 /* minend: end of match must be >=minend after stringarg. */
1596 /* data: May be used for some additional optimizations. */
1597 /* nosave: For optimizations. */
1598 {
1599     register char *s;
1600     register regnode *c;
1601     register char *startpos = stringarg;
1602     I32 minlen;         /* must match at least this many chars */
1603     I32 dontbother = 0; /* how many characters not to try at end */
1604     /* I32 start_shift = 0; */          /* Offset of the start to find
1605                                          constant substr. */            /* CC */
1606     I32 end_shift = 0;                  /* Same for the end. */         /* CC */
1607     I32 scream_pos = -1;                /* Internal iterator of scream. */
1608     char *scream_olds;
1609     SV* oreplsv = GvSV(PL_replgv);
1610     bool do_utf8 = DO_UTF8(sv);
1611 #ifdef DEBUGGING
1612     SV *dsv0 = PERL_DEBUG_PAD_ZERO(0);
1613     SV *dsv1 = PERL_DEBUG_PAD_ZERO(1);
1614 #endif
1615
1616     PL_regcc = 0;
1617
1618     cache_re(prog);
1619 #ifdef DEBUGGING
1620     PL_regnarrate = DEBUG_r_TEST;
1621 #endif
1622
1623     /* Be paranoid... */
1624     if (prog == NULL || startpos == NULL) {
1625         Perl_croak(aTHX_ "NULL regexp parameter");
1626         return 0;
1627     }
1628
1629     minlen = prog->minlen;
1630     if (strend - startpos < minlen) {
1631         DEBUG_r(PerlIO_printf(Perl_debug_log,
1632                               "String too short [regexec_flags]...\n"));
1633         goto phooey;
1634     }
1635
1636     /* Check validity of program. */
1637     if (UCHARAT(prog->program) != REG_MAGIC) {
1638         Perl_croak(aTHX_ "corrupted regexp program");
1639     }
1640
1641     PL_reg_flags = 0;
1642     PL_reg_eval_set = 0;
1643     PL_reg_maxiter = 0;
1644
1645     if (prog->reganch & ROPT_UTF8)
1646         PL_reg_flags |= RF_utf8;
1647
1648     /* Mark beginning of line for ^ and lookbehind. */
1649     PL_regbol = startpos;
1650     PL_bostr  = strbeg;
1651     PL_reg_sv = sv;
1652
1653     /* Mark end of line for $ (and such) */
1654     PL_regeol = strend;
1655
1656     /* see how far we have to get to not match where we matched before */
1657     PL_regtill = startpos+minend;
1658
1659     /* We start without call_cc context.  */
1660     PL_reg_call_cc = 0;
1661
1662     /* If there is a "must appear" string, look for it. */
1663     s = startpos;
1664
1665     if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to have PL_reg_ganch */
1666         MAGIC *mg;
1667
1668         if (flags & REXEC_IGNOREPOS)    /* Means: check only at start */
1669             PL_reg_ganch = startpos;
1670         else if (sv && SvTYPE(sv) >= SVt_PVMG
1671                   && SvMAGIC(sv)
1672                   && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1673                   && mg->mg_len >= 0) {
1674             PL_reg_ganch = strbeg + mg->mg_len; /* Defined pos() */
1675             if (prog->reganch & ROPT_ANCH_GPOS) {
1676                 if (s > PL_reg_ganch)
1677                     goto phooey;
1678                 s = PL_reg_ganch;
1679             }
1680         }
1681         else                            /* pos() not defined */
1682             PL_reg_ganch = strbeg;
1683     }
1684
1685     if (!(flags & REXEC_CHECKED) && (prog->check_substr != Nullsv || prog->check_utf8 != Nullsv)) {
1686         re_scream_pos_data d;
1687
1688         d.scream_olds = &scream_olds;
1689         d.scream_pos = &scream_pos;
1690         s = re_intuit_start(prog, sv, s, strend, flags, &d);
1691         if (!s) {
1692             DEBUG_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1693             goto phooey;        /* not present */
1694         }
1695     }
1696
1697     DEBUG_r({
1698          char *s0   = UTF ?
1699            pv_uni_display(dsv0, (U8*)prog->precomp, prog->prelen, 60,
1700                           UNI_DISPLAY_REGEX) :
1701            prog->precomp;
1702          int   len0 = UTF ? SvCUR(dsv0) : prog->prelen;
1703          char *s1   = do_utf8 ? sv_uni_display(dsv1, sv, 60,
1704                                                UNI_DISPLAY_REGEX) : startpos;
1705          int   len1 = do_utf8 ? SvCUR(dsv1) : strend - startpos;
1706          if (!PL_colorset)
1707              reginitcolors();
1708          PerlIO_printf(Perl_debug_log,
1709                        "%sMatching REx%s `%s%*.*s%s%s' against `%s%.*s%s%s'\n",
1710                        PL_colors[4],PL_colors[5],PL_colors[0],
1711                        len0, len0, s0,
1712                        PL_colors[1],
1713                        len0 > 60 ? "..." : "",
1714                        PL_colors[0],
1715                        (int)(len1 > 60 ? 60 : len1),
1716                        s1, PL_colors[1],
1717                        (len1 > 60 ? "..." : "")
1718               );
1719     });
1720
1721     /* Simplest case:  anchored match need be tried only once. */
1722     /*  [unless only anchor is BOL and multiline is set] */
1723     if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
1724         if (s == startpos && regtry(prog, startpos))
1725             goto got_it;
1726         else if (PL_multiline || (prog->reganch & ROPT_IMPLICIT)
1727                  || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
1728         {
1729             char *end;
1730
1731             if (minlen)
1732                 dontbother = minlen - 1;
1733             end = HOP3c(strend, -dontbother, strbeg) - 1;
1734             /* for multiline we only have to try after newlines */
1735             if (prog->check_substr || prog->check_utf8) {
1736                 if (s == startpos)
1737                     goto after_try;
1738                 while (1) {
1739                     if (regtry(prog, s))
1740                         goto got_it;
1741                   after_try:
1742                     if (s >= end)
1743                         goto phooey;
1744                     if (prog->reganch & RE_USE_INTUIT) {
1745                         s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
1746                         if (!s)
1747                             goto phooey;
1748                     }
1749                     else
1750                         s++;
1751                 }               
1752             } else {
1753                 if (s > startpos)
1754                     s--;
1755                 while (s < end) {
1756                     if (*s++ == '\n') { /* don't need PL_utf8skip here */
1757                         if (regtry(prog, s))
1758                             goto got_it;
1759                     }
1760                 }               
1761             }
1762         }
1763         goto phooey;
1764     } else if (prog->reganch & ROPT_ANCH_GPOS) {
1765         if (regtry(prog, PL_reg_ganch))
1766             goto got_it;
1767         goto phooey;
1768     }
1769
1770     /* Messy cases:  unanchored match. */
1771     if ((prog->anchored_substr || prog->anchored_utf8) && prog->reganch & ROPT_SKIP) {
1772         /* we have /x+whatever/ */
1773         /* it must be a one character string (XXXX Except UTF?) */
1774         char ch;
1775 #ifdef DEBUGGING
1776         int did_match = 0;
1777 #endif
1778         if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1779             do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1780         ch = SvPVX(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
1781
1782         if (do_utf8) {
1783             while (s < strend) {
1784                 if (*s == ch) {
1785                     DEBUG_r( did_match = 1 );
1786                     if (regtry(prog, s)) goto got_it;
1787                     s += UTF8SKIP(s);
1788                     while (s < strend && *s == ch)
1789                         s += UTF8SKIP(s);
1790                 }
1791                 s += UTF8SKIP(s);
1792             }
1793         }
1794         else {
1795             while (s < strend) {
1796                 if (*s == ch) {
1797                     DEBUG_r( did_match = 1 );
1798                     if (regtry(prog, s)) goto got_it;
1799                     s++;
1800                     while (s < strend && *s == ch)
1801                         s++;
1802                 }
1803                 s++;
1804             }
1805         }
1806         DEBUG_r(if (!did_match)
1807                 PerlIO_printf(Perl_debug_log,
1808                                   "Did not find anchored character...\n")
1809                );
1810     }
1811     /*SUPPRESS 560*/
1812     else if (prog->anchored_substr != Nullsv
1813               || prog->anchored_utf8 != Nullsv
1814               || ((prog->float_substr != Nullsv || prog->float_utf8 != Nullsv)
1815                   && prog->float_max_offset < strend - s)) {
1816         SV *must;
1817         I32 back_max;
1818         I32 back_min;
1819         char *last;
1820         char *last1;            /* Last position checked before */
1821 #ifdef DEBUGGING
1822         int did_match = 0;
1823 #endif
1824         if (prog->anchored_substr || prog->anchored_utf8) {
1825             if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1826                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1827             must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
1828             back_max = back_min = prog->anchored_offset;
1829         } else {
1830             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1831                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1832             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
1833             back_max = prog->float_max_offset;
1834             back_min = prog->float_min_offset;
1835         }
1836         if (must == &PL_sv_undef)
1837             /* could not downgrade utf8 check substring, so must fail */
1838             goto phooey;
1839
1840         last = HOP3c(strend,    /* Cannot start after this */
1841                           -(I32)(CHR_SVLEN(must)
1842                                  - (SvTAIL(must) != 0) + back_min), strbeg);
1843
1844         if (s > PL_bostr)
1845             last1 = HOPc(s, -1);
1846         else
1847             last1 = s - 1;      /* bogus */
1848
1849         /* XXXX check_substr already used to find `s', can optimize if
1850            check_substr==must. */
1851         scream_pos = -1;
1852         dontbother = end_shift;
1853         strend = HOPc(strend, -dontbother);
1854         while ( (s <= last) &&
1855                 ((flags & REXEC_SCREAM)
1856                  ? (s = screaminstr(sv, must, HOP3c(s, back_min, strend) - strbeg,
1857                                     end_shift, &scream_pos, 0))
1858                  : (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend),
1859                                   (unsigned char*)strend, must,
1860                                   PL_multiline ? FBMrf_MULTILINE : 0))) ) {
1861             DEBUG_r( did_match = 1 );
1862             if (HOPc(s, -back_max) > last1) {
1863                 last1 = HOPc(s, -back_min);
1864                 s = HOPc(s, -back_max);
1865             }
1866             else {
1867                 char *t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
1868
1869                 last1 = HOPc(s, -back_min);
1870                 s = t;          
1871             }
1872             if (do_utf8) {
1873                 while (s <= last1) {
1874                     if (regtry(prog, s))
1875                         goto got_it;
1876                     s += UTF8SKIP(s);
1877                 }
1878             }
1879             else {
1880                 while (s <= last1) {
1881                     if (regtry(prog, s))
1882                         goto got_it;
1883                     s++;
1884                 }
1885             }
1886         }
1887         DEBUG_r(if (!did_match)
1888                     PerlIO_printf(Perl_debug_log, 
1889                                   "Did not find %s substr `%s%.*s%s'%s...\n",
1890                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
1891                                ? "anchored" : "floating"),
1892                               PL_colors[0],
1893                               (int)(SvCUR(must) - (SvTAIL(must)!=0)),
1894                               SvPVX(must),
1895                                   PL_colors[1], (SvTAIL(must) ? "$" : ""))
1896                );
1897         goto phooey;
1898     }
1899     else if ((c = prog->regstclass)) {
1900         if (minlen) {
1901             I32 op = (U8)OP(prog->regstclass);
1902             /* don't bother with what can't match */
1903             if (PL_regkind[op] != EXACT && op != CANY)
1904                 strend = HOPc(strend, -(minlen - 1));
1905         }
1906         DEBUG_r({
1907             SV *prop = sv_newmortal();
1908             char *s0;
1909             char *s1;
1910             int len0;
1911             int len1;
1912
1913             regprop(prop, c);
1914             s0 = UTF ?
1915               pv_uni_display(dsv0, (U8*)SvPVX(prop), SvCUR(prop), 60,
1916                              UNI_DISPLAY_REGEX) :
1917               SvPVX(prop);
1918             len0 = UTF ? SvCUR(dsv0) : SvCUR(prop);
1919             s1 = UTF ?
1920               sv_uni_display(dsv1, sv, 60, UNI_DISPLAY_REGEX) : s;
1921             len1 = UTF ? SvCUR(dsv1) : strend - s;
1922             PerlIO_printf(Perl_debug_log,
1923                           "Matching stclass `%*.*s' against `%*.*s'\n",
1924                           len0, len0, s0,
1925                           len1, len1, s1);
1926         });
1927         if (find_byclass(prog, c, s, strend, startpos, 0))
1928             goto got_it;
1929         DEBUG_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n"));
1930     }
1931     else {
1932         dontbother = 0;
1933         if (prog->float_substr != Nullsv || prog->float_utf8 != Nullsv) {
1934             /* Trim the end. */
1935             char *last;
1936             SV* float_real;
1937
1938             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1939                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1940             float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
1941
1942             if (flags & REXEC_SCREAM) {
1943                 last = screaminstr(sv, float_real, s - strbeg,
1944                                    end_shift, &scream_pos, 1); /* last one */
1945                 if (!last)
1946                     last = scream_olds; /* Only one occurrence. */
1947             }
1948             else {
1949                 STRLEN len;
1950                 char *little = SvPV(float_real, len);
1951
1952                 if (SvTAIL(float_real)) {
1953                     if (memEQ(strend - len + 1, little, len - 1))
1954                         last = strend - len + 1;
1955                     else if (!PL_multiline)
1956                         last = memEQ(strend - len, little, len)
1957                             ? strend - len : Nullch;
1958                     else
1959                         goto find_last;
1960                 } else {
1961                   find_last:
1962                     if (len)
1963                         last = rninstr(s, strend, little, little + len);
1964                     else
1965                         last = strend;  /* matching `$' */
1966                 }
1967             }
1968             if (last == NULL) {
1969                 DEBUG_r(PerlIO_printf(Perl_debug_log,
1970                                       "%sCan't trim the tail, match fails (should not happen)%s\n",
1971                                       PL_colors[4],PL_colors[5]));
1972                 goto phooey; /* Should not happen! */
1973             }
1974             dontbother = strend - last + prog->float_min_offset;
1975         }
1976         if (minlen && (dontbother < minlen))
1977             dontbother = minlen - 1;
1978         strend -= dontbother;              /* this one's always in bytes! */
1979         /* We don't know much -- general case. */
1980         if (do_utf8) {
1981             for (;;) {
1982                 if (regtry(prog, s))
1983                     goto got_it;
1984                 if (s >= strend)
1985                     break;
1986                 s += UTF8SKIP(s);
1987             };
1988         }
1989         else {
1990             do {
1991                 if (regtry(prog, s))
1992                     goto got_it;
1993             } while (s++ < strend);
1994         }
1995     }
1996
1997     /* Failure. */
1998     goto phooey;
1999
2000 got_it:
2001     RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
2002
2003     if (PL_reg_eval_set) {
2004         /* Preserve the current value of $^R */
2005         if (oreplsv != GvSV(PL_replgv))
2006             sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
2007                                                   restored, the value remains
2008                                                   the same. */
2009         restore_pos(aTHX_ 0);
2010     }
2011
2012     /* make sure $`, $&, $', and $digit will work later */
2013     if ( !(flags & REXEC_NOT_FIRST) ) {
2014         if (RX_MATCH_COPIED(prog)) {
2015             Safefree(prog->subbeg);
2016             RX_MATCH_COPIED_off(prog);
2017         }
2018         if (flags & REXEC_COPY_STR) {
2019             I32 i = PL_regeol - startpos + (stringarg - strbeg);
2020
2021             s = savepvn(strbeg, i);
2022             prog->subbeg = s;
2023             prog->sublen = i;
2024             RX_MATCH_COPIED_on(prog);
2025         }
2026         else {
2027             prog->subbeg = strbeg;
2028             prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
2029         }
2030     }
2031
2032     return 1;
2033
2034 phooey:
2035     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2036                           PL_colors[4],PL_colors[5]));
2037     if (PL_reg_eval_set)
2038         restore_pos(aTHX_ 0);
2039     return 0;
2040 }
2041
2042 /*
2043  - regtry - try match at specific point
2044  */
2045 STATIC I32                      /* 0 failure, 1 success */
2046 S_regtry(pTHX_ regexp *prog, char *startpos)
2047 {
2048     register I32 i;
2049     register I32 *sp;
2050     register I32 *ep;
2051     CHECKPOINT lastcp;
2052
2053 #ifdef DEBUGGING
2054     PL_regindent = 0;   /* XXXX Not good when matches are reenterable... */
2055 #endif
2056     if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
2057         MAGIC *mg;
2058
2059         PL_reg_eval_set = RS_init;
2060         DEBUG_r(DEBUG_s(
2061             PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
2062                           (IV)(PL_stack_sp - PL_stack_base));
2063             ));
2064         SAVEI32(cxstack[cxstack_ix].blk_oldsp);
2065         cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2066         /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
2067         SAVETMPS;
2068         /* Apparently this is not needed, judging by wantarray. */
2069         /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2070            cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2071
2072         if (PL_reg_sv) {
2073             /* Make $_ available to executed code. */
2074             if (PL_reg_sv != DEFSV) {
2075                 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
2076                 SAVESPTR(DEFSV);
2077                 DEFSV = PL_reg_sv;
2078             }
2079         
2080             if (!(SvTYPE(PL_reg_sv) >= SVt_PVMG && SvMAGIC(PL_reg_sv)
2081                   && (mg = mg_find(PL_reg_sv, PERL_MAGIC_regex_global)))) {
2082                 /* prepare for quick setting of pos */
2083                 sv_magic(PL_reg_sv, (SV*)0,
2084                         PERL_MAGIC_regex_global, Nullch, 0);
2085                 mg = mg_find(PL_reg_sv, PERL_MAGIC_regex_global);
2086                 mg->mg_len = -1;
2087             }
2088             PL_reg_magic    = mg;
2089             PL_reg_oldpos   = mg->mg_len;
2090             SAVEDESTRUCTOR_X(restore_pos, 0);
2091         }
2092         if (!PL_reg_curpm) {
2093             Newz(22,PL_reg_curpm, 1, PMOP);
2094 #ifdef USE_ITHREADS
2095             {
2096                 SV* repointer = newSViv(0);
2097                 /* so we know which PL_regex_padav element is PL_reg_curpm */
2098                 SvFLAGS(repointer) |= SVf_BREAK;
2099                 av_push(PL_regex_padav,repointer);
2100                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2101                 PL_regex_pad = AvARRAY(PL_regex_padav);
2102             }
2103 #endif      
2104         }
2105         PM_SETRE(PL_reg_curpm, prog);
2106         PL_reg_oldcurpm = PL_curpm;
2107         PL_curpm = PL_reg_curpm;
2108         if (RX_MATCH_COPIED(prog)) {
2109             /*  Here is a serious problem: we cannot rewrite subbeg,
2110                 since it may be needed if this match fails.  Thus
2111                 $` inside (?{}) could fail... */
2112             PL_reg_oldsaved = prog->subbeg;
2113             PL_reg_oldsavedlen = prog->sublen;
2114             RX_MATCH_COPIED_off(prog);
2115         }
2116         else
2117             PL_reg_oldsaved = Nullch;
2118         prog->subbeg = PL_bostr;
2119         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2120     }
2121     prog->startp[0] = startpos - PL_bostr;
2122     PL_reginput = startpos;
2123     PL_regstartp = prog->startp;
2124     PL_regendp = prog->endp;
2125     PL_reglastparen = &prog->lastparen;
2126     PL_reglastcloseparen = &prog->lastcloseparen;
2127     prog->lastparen = 0;
2128     prog->lastcloseparen = 0;
2129     PL_regsize = 0;
2130     DEBUG_r(PL_reg_starttry = startpos);
2131     if (PL_reg_start_tmpl <= prog->nparens) {
2132         PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2133         if(PL_reg_start_tmp)
2134             Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2135         else
2136             New(22,PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2137     }
2138
2139     /* XXXX What this code is doing here?!!!  There should be no need
2140        to do this again and again, PL_reglastparen should take care of
2141        this!  --ilya*/
2142
2143     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2144      * Actually, the code in regcppop() (which Ilya may be meaning by
2145      * PL_reglastparen), is not needed at all by the test suite
2146      * (op/regexp, op/pat, op/split), but that code is needed, oddly
2147      * enough, for building DynaLoader, or otherwise this
2148      * "Error: '*' not in typemap in DynaLoader.xs, line 164"
2149      * will happen.  Meanwhile, this code *is* needed for the
2150      * above-mentioned test suite tests to succeed.  The common theme
2151      * on those tests seems to be returning null fields from matches.
2152      * --jhi */
2153 #if 1
2154     sp = prog->startp;
2155     ep = prog->endp;
2156     if (prog->nparens) {
2157         for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2158             *++sp = -1;
2159             *++ep = -1;
2160         }
2161     }
2162 #endif
2163     REGCP_SET(lastcp);
2164     if (regmatch(prog->program + 1)) {
2165         prog->endp[0] = PL_reginput - PL_bostr;
2166         return 1;
2167     }
2168     REGCP_UNWIND(lastcp);
2169     return 0;
2170 }
2171
2172 #define RE_UNWIND_BRANCH        1
2173 #define RE_UNWIND_BRANCHJ       2
2174
2175 union re_unwind_t;
2176
2177 typedef struct {                /* XX: makes sense to enlarge it... */
2178     I32 type;
2179     I32 prev;
2180     CHECKPOINT lastcp;
2181 } re_unwind_generic_t;
2182
2183 typedef struct {
2184     I32 type;
2185     I32 prev;
2186     CHECKPOINT lastcp;
2187     I32 lastparen;
2188     regnode *next;
2189     char *locinput;
2190     I32 nextchr;
2191 #ifdef DEBUGGING
2192     int regindent;
2193 #endif
2194 } re_unwind_branch_t;
2195
2196 typedef union re_unwind_t {
2197     I32 type;
2198     re_unwind_generic_t generic;
2199     re_unwind_branch_t branch;
2200 } re_unwind_t;
2201
2202 #define sayYES goto yes
2203 #define sayNO goto no
2204 #define sayNO_ANYOF goto no_anyof
2205 #define sayYES_FINAL goto yes_final
2206 #define sayYES_LOUD  goto yes_loud
2207 #define sayNO_FINAL  goto no_final
2208 #define sayNO_SILENT goto do_no
2209 #define saySAME(x) if (x) goto yes; else goto no
2210
2211 #define REPORT_CODE_OFF 24
2212
2213 /*
2214  - regmatch - main matching routine
2215  *
2216  * Conceptually the strategy is simple:  check to see whether the current
2217  * node matches, call self recursively to see whether the rest matches,
2218  * and then act accordingly.  In practice we make some effort to avoid
2219  * recursion, in particular by going through "ordinary" nodes (that don't
2220  * need to know whether the rest of the match failed) by a loop instead of
2221  * by recursion.
2222  */
2223 /* [lwall] I've hoisted the register declarations to the outer block in order to
2224  * maybe save a little bit of pushing and popping on the stack.  It also takes
2225  * advantage of machines that use a register save mask on subroutine entry.
2226  */
2227 STATIC I32                      /* 0 failure, 1 success */
2228 S_regmatch(pTHX_ regnode *prog)
2229 {
2230     register regnode *scan;     /* Current node. */
2231     regnode *next;              /* Next node. */
2232     regnode *inner;             /* Next node in internal branch. */
2233     register I32 nextchr;       /* renamed nextchr - nextchar colides with
2234                                    function of same name */
2235     register I32 n;             /* no or next */
2236     register I32 ln = 0;        /* len or last */
2237     register char *s = Nullch;  /* operand or save */
2238     register char *locinput = PL_reginput;
2239     register I32 c1 = 0, c2 = 0, paren; /* case fold search, parenth */
2240     int minmod = 0, sw = 0, logical = 0;
2241     I32 unwind = 0;
2242 #if 0
2243     I32 firstcp = PL_savestack_ix;
2244 #endif
2245     register bool do_utf8 = PL_reg_match_utf8;
2246 #ifdef DEBUGGING
2247     SV *dsv0 = PERL_DEBUG_PAD_ZERO(0);
2248     SV *dsv1 = PERL_DEBUG_PAD_ZERO(1);
2249     SV *dsv2 = PERL_DEBUG_PAD_ZERO(2);
2250 #endif
2251
2252 #ifdef DEBUGGING
2253     PL_regindent++;
2254 #endif
2255
2256     /* Note that nextchr is a byte even in UTF */
2257     nextchr = UCHARAT(locinput);
2258     scan = prog;
2259     while (scan != NULL) {
2260
2261         DEBUG_r( {
2262             SV *prop = sv_newmortal();
2263             int docolor = *PL_colors[0];
2264             int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2265             int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
2266             /* The part of the string before starttry has one color
2267                (pref0_len chars), between starttry and current
2268                position another one (pref_len - pref0_len chars),
2269                after the current position the third one.
2270                We assume that pref0_len <= pref_len, otherwise we
2271                decrease pref0_len.  */
2272             int pref_len = (locinput - PL_bostr) > (5 + taill) - l
2273                 ? (5 + taill) - l : locinput - PL_bostr;
2274             int pref0_len;
2275
2276             while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2277                 pref_len++;
2278             pref0_len = pref_len  - (locinput - PL_reg_starttry);
2279             if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
2280                 l = ( PL_regeol - locinput > (5 + taill) - pref_len
2281                       ? (5 + taill) - pref_len : PL_regeol - locinput);
2282             while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2283                 l--;
2284             if (pref0_len < 0)
2285                 pref0_len = 0;
2286             if (pref0_len > pref_len)
2287                 pref0_len = pref_len;
2288             regprop(prop, scan);
2289             {
2290               char *s0 =
2291                 do_utf8 && OP(scan) != CANY ?
2292                 pv_uni_display(dsv0, (U8*)(locinput - pref_len),
2293                                pref0_len, 60, UNI_DISPLAY_REGEX) :
2294                 locinput - pref_len;
2295               int len0 = do_utf8 ? strlen(s0) : pref0_len;
2296               char *s1 = do_utf8 && OP(scan) != CANY ?
2297                 pv_uni_display(dsv1, (U8*)(locinput - pref_len + pref0_len),
2298                                pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) :
2299                 locinput - pref_len + pref0_len;
2300               int len1 = do_utf8 ? strlen(s1) : pref_len - pref0_len;
2301               char *s2 = do_utf8 && OP(scan) != CANY ?
2302                 pv_uni_display(dsv2, (U8*)locinput,
2303                                PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) :
2304                 locinput;
2305               int len2 = do_utf8 ? strlen(s2) : l;
2306               PerlIO_printf(Perl_debug_log,
2307                             "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n",
2308                             (IV)(locinput - PL_bostr),
2309                             PL_colors[4],
2310                             len0, s0,
2311                             PL_colors[5],
2312                             PL_colors[2],
2313                             len1, s1,
2314                             PL_colors[3],
2315                             (docolor ? "" : "> <"),
2316                             PL_colors[0],
2317                             len2, s2,
2318                             PL_colors[1],
2319                             15 - l - pref_len + 1,
2320                             "",
2321                             (IV)(scan - PL_regprogram), PL_regindent*2, "",
2322                             SvPVX(prop));
2323             }
2324         });
2325
2326         next = scan + NEXT_OFF(scan);
2327         if (next == scan)
2328             next = NULL;
2329
2330         switch (OP(scan)) {
2331         case BOL:
2332             if (locinput == PL_bostr || (PL_multiline &&
2333                 (nextchr || locinput < PL_regeol) && locinput[-1] == '\n') )
2334             {
2335                 /* regtill = regbol; */
2336                 break;
2337             }
2338             sayNO;
2339         case MBOL:
2340             if (locinput == PL_bostr ||
2341                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2342             {
2343                 break;
2344             }
2345             sayNO;
2346         case SBOL:
2347             if (locinput == PL_bostr)
2348                 break;
2349             sayNO;
2350         case GPOS:
2351             if (locinput == PL_reg_ganch)
2352                 break;
2353             sayNO;
2354         case EOL:
2355             if (PL_multiline)
2356                 goto meol;
2357             else
2358                 goto seol;
2359         case MEOL:
2360           meol:
2361             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2362                 sayNO;
2363             break;
2364         case SEOL:
2365           seol:
2366             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2367                 sayNO;
2368             if (PL_regeol - locinput > 1)
2369                 sayNO;
2370             break;
2371         case EOS:
2372             if (PL_regeol != locinput)
2373                 sayNO;
2374             break;
2375         case SANY:
2376             if (!nextchr && locinput >= PL_regeol)
2377                 sayNO;
2378             if (do_utf8) {
2379                 locinput += PL_utf8skip[nextchr];
2380                 if (locinput > PL_regeol)
2381                     sayNO;
2382                 nextchr = UCHARAT(locinput);
2383             }
2384             else
2385                 nextchr = UCHARAT(++locinput);
2386             break;
2387         case CANY:
2388             if (!nextchr && locinput >= PL_regeol)
2389                 sayNO;
2390             nextchr = UCHARAT(++locinput);
2391             break;
2392         case REG_ANY:
2393             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2394                 sayNO;
2395             if (do_utf8) {
2396                 locinput += PL_utf8skip[nextchr];
2397                 if (locinput > PL_regeol)
2398                     sayNO;
2399                 nextchr = UCHARAT(locinput);
2400             }
2401             else
2402                 nextchr = UCHARAT(++locinput);
2403             break;
2404         case EXACT:
2405             s = STRING(scan);
2406             ln = STR_LEN(scan);
2407             if (do_utf8 != UTF) {
2408                 /* The target and the pattern have differing utf8ness. */
2409                 char *l = locinput;
2410                 char *e = s + ln;
2411                 STRLEN ulen;
2412
2413                 if (do_utf8) {
2414                     /* The target is utf8, the pattern is not utf8. */
2415                     while (s < e) {
2416                         if (l >= PL_regeol)
2417                              sayNO;
2418                         if (NATIVE_TO_UNI(*(U8*)s) !=
2419                             utf8n_to_uvuni((U8*)l, UTF8_MAXLEN, &ulen,
2420                                            ckWARN(WARN_UTF8) ?
2421                                            0 : UTF8_ALLOW_ANY))
2422                              sayNO;
2423                         l += ulen;
2424                         s ++;
2425                     }
2426                 }
2427                 else {
2428                     /* The target is not utf8, the pattern is utf8. */
2429                     while (s < e) {
2430                         if (l >= PL_regeol)
2431                             sayNO;
2432                         if (NATIVE_TO_UNI(*((U8*)l)) !=
2433                             utf8n_to_uvuni((U8*)s, UTF8_MAXLEN, &ulen,
2434                                            ckWARN(WARN_UTF8) ?
2435                                            0 : UTF8_ALLOW_ANY))
2436                             sayNO;
2437                         s += ulen;
2438                         l ++;
2439                     }
2440                 }
2441                 locinput = l;
2442                 nextchr = UCHARAT(locinput);
2443                 break;
2444             }
2445             /* The target and the pattern have the same utf8ness. */
2446             /* Inline the first character, for speed. */
2447             if (UCHARAT(s) != nextchr)
2448                 sayNO;
2449             if (PL_regeol - locinput < ln)
2450                 sayNO;
2451             if (ln > 1 && memNE(s, locinput, ln))
2452                 sayNO;
2453             locinput += ln;
2454             nextchr = UCHARAT(locinput);
2455             break;
2456         case EXACTFL:
2457             PL_reg_flags |= RF_tainted;
2458             /* FALL THROUGH */
2459         case EXACTF:
2460             s = STRING(scan);
2461             ln = STR_LEN(scan);
2462
2463             if (do_utf8 || UTF) {
2464               /* Either target or the pattern are utf8. */
2465                 char *l = locinput;
2466                 char *e = PL_regeol;
2467
2468                 if (ibcmp_utf8(s, 0,  ln, (bool)UTF,
2469                                l, &e, 0,  do_utf8)) {
2470                      /* One more case for the sharp s:
2471                       * pack("U0U*", 0xDF) =~ /ss/i,
2472                       * the 0xC3 0x9F are the UTF-8
2473                       * byte sequence for the U+00DF. */
2474                      if (!(do_utf8 &&
2475                            toLOWER(s[0]) == 's' &&
2476                            ln >= 2 &&
2477                            toLOWER(s[1]) == 's' &&
2478                            (U8)l[0] == 0xC3 &&
2479                            e - l >= 2 &&
2480                            (U8)l[1] == 0x9F))
2481                           sayNO;
2482                 }
2483                 locinput = e;
2484                 nextchr = UCHARAT(locinput);
2485                 break;
2486             }
2487
2488             /* Neither the target and the pattern are utf8. */
2489
2490             /* Inline the first character, for speed. */
2491             if (UCHARAT(s) != nextchr &&
2492                 UCHARAT(s) != ((OP(scan) == EXACTF)
2493                                ? PL_fold : PL_fold_locale)[nextchr])
2494                 sayNO;
2495             if (PL_regeol - locinput < ln)
2496                 sayNO;
2497             if (ln > 1 && (OP(scan) == EXACTF
2498                            ? ibcmp(s, locinput, ln)
2499                            : ibcmp_locale(s, locinput, ln)))
2500                 sayNO;
2501             locinput += ln;
2502             nextchr = UCHARAT(locinput);
2503             break;
2504         case ANYOF:
2505             if (do_utf8) {
2506                 STRLEN inclasslen = PL_regeol - locinput;
2507
2508                 if (!reginclass(scan, (U8*)locinput, &inclasslen, do_utf8))
2509                     sayNO_ANYOF;
2510                 if (locinput >= PL_regeol)
2511                     sayNO;
2512                 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
2513                 nextchr = UCHARAT(locinput);
2514                 break;
2515             }
2516             else {
2517                 if (nextchr < 0)
2518                     nextchr = UCHARAT(locinput);
2519                 if (!REGINCLASS(scan, (U8*)locinput))
2520                     sayNO_ANYOF;
2521                 if (!nextchr && locinput >= PL_regeol)
2522                     sayNO;
2523                 nextchr = UCHARAT(++locinput);
2524                 break;
2525             }
2526         no_anyof:
2527             /* If we might have the case of the German sharp s
2528              * in a casefolding Unicode character class. */
2529
2530             if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
2531                  locinput += SHARP_S_SKIP;
2532                  nextchr = UCHARAT(locinput);
2533             }
2534             else
2535                  sayNO;
2536             break;
2537         case ALNUML:
2538             PL_reg_flags |= RF_tainted;
2539             /* FALL THROUGH */
2540         case ALNUM:
2541             if (!nextchr)
2542                 sayNO;
2543             if (do_utf8) {
2544                 LOAD_UTF8_CHARCLASS(alnum,"a");
2545                 if (!(OP(scan) == ALNUM
2546                       ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
2547                       : isALNUM_LC_utf8((U8*)locinput)))
2548                 {
2549                     sayNO;
2550                 }
2551                 locinput += PL_utf8skip[nextchr];
2552                 nextchr = UCHARAT(locinput);
2553                 break;
2554             }
2555             if (!(OP(scan) == ALNUM
2556                   ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
2557                 sayNO;
2558             nextchr = UCHARAT(++locinput);
2559             break;
2560         case NALNUML:
2561             PL_reg_flags |= RF_tainted;
2562             /* FALL THROUGH */
2563         case NALNUM:
2564             if (!nextchr && locinput >= PL_regeol)
2565                 sayNO;
2566             if (do_utf8) {
2567                 LOAD_UTF8_CHARCLASS(alnum,"a");
2568                 if (OP(scan) == NALNUM
2569                     ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
2570                     : isALNUM_LC_utf8((U8*)locinput))
2571                 {
2572                     sayNO;
2573                 }
2574                 locinput += PL_utf8skip[nextchr];
2575                 nextchr = UCHARAT(locinput);
2576                 break;
2577             }
2578             if (OP(scan) == NALNUM
2579                 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
2580                 sayNO;
2581             nextchr = UCHARAT(++locinput);
2582             break;
2583         case BOUNDL:
2584         case NBOUNDL:
2585             PL_reg_flags |= RF_tainted;
2586             /* FALL THROUGH */
2587         case BOUND:
2588         case NBOUND:
2589             /* was last char in word? */
2590             if (do_utf8) {
2591                 if (locinput == PL_bostr)
2592                     ln = '\n';
2593                 else {
2594                     U8 *r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
2595                 
2596                     ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, 0);
2597                 }
2598                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
2599                     ln = isALNUM_uni(ln);
2600                     LOAD_UTF8_CHARCLASS(alnum,"a");
2601                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
2602                 }
2603                 else {
2604                     ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
2605                     n = isALNUM_LC_utf8((U8*)locinput);
2606                 }
2607             }
2608             else {
2609                 ln = (locinput != PL_bostr) ?
2610                     UCHARAT(locinput - 1) : '\n';
2611                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
2612                     ln = isALNUM(ln);
2613                     n = isALNUM(nextchr);
2614                 }
2615                 else {
2616                     ln = isALNUM_LC(ln);
2617                     n = isALNUM_LC(nextchr);
2618                 }
2619             }
2620             if (((!ln) == (!n)) == (OP(scan) == BOUND ||
2621                                     OP(scan) == BOUNDL))
2622                     sayNO;
2623             break;
2624         case SPACEL:
2625             PL_reg_flags |= RF_tainted;
2626             /* FALL THROUGH */
2627         case SPACE:
2628             if (!nextchr)
2629                 sayNO;
2630             if (do_utf8) {
2631                 if (UTF8_IS_CONTINUED(nextchr)) {
2632                     LOAD_UTF8_CHARCLASS(space," ");
2633                     if (!(OP(scan) == SPACE
2634                           ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
2635                           : isSPACE_LC_utf8((U8*)locinput)))
2636                     {
2637                         sayNO;
2638                     }
2639                     locinput += PL_utf8skip[nextchr];
2640                     nextchr = UCHARAT(locinput);
2641                     break;
2642                 }
2643                 if (!(OP(scan) == SPACE
2644                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
2645                     sayNO;
2646                 nextchr = UCHARAT(++locinput);
2647             }
2648             else {
2649                 if (!(OP(scan) == SPACE
2650                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
2651                     sayNO;
2652                 nextchr = UCHARAT(++locinput);
2653             }
2654             break;
2655         case NSPACEL:
2656             PL_reg_flags |= RF_tainted;
2657             /* FALL THROUGH */
2658         case NSPACE:
2659             if (!nextchr && locinput >= PL_regeol)
2660                 sayNO;
2661             if (do_utf8) {
2662                 LOAD_UTF8_CHARCLASS(space," ");
2663                 if (OP(scan) == NSPACE
2664                     ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
2665                     : isSPACE_LC_utf8((U8*)locinput))
2666                 {
2667                     sayNO;
2668                 }
2669                 locinput += PL_utf8skip[nextchr];
2670                 nextchr = UCHARAT(locinput);
2671                 break;
2672             }
2673             if (OP(scan) == NSPACE
2674                 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
2675                 sayNO;
2676             nextchr = UCHARAT(++locinput);
2677             break;
2678         case DIGITL:
2679             PL_reg_flags |= RF_tainted;
2680             /* FALL THROUGH */
2681         case DIGIT:
2682             if (!nextchr)
2683                 sayNO;
2684             if (do_utf8) {
2685                 LOAD_UTF8_CHARCLASS(digit,"0");
2686                 if (!(OP(scan) == DIGIT
2687                       ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
2688                       : isDIGIT_LC_utf8((U8*)locinput)))
2689                 {
2690                     sayNO;
2691                 }
2692                 locinput += PL_utf8skip[nextchr];
2693                 nextchr = UCHARAT(locinput);
2694                 break;
2695             }
2696             if (!(OP(scan) == DIGIT
2697                   ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
2698                 sayNO;
2699             nextchr = UCHARAT(++locinput);
2700             break;
2701         case NDIGITL:
2702             PL_reg_flags |= RF_tainted;
2703             /* FALL THROUGH */
2704         case NDIGIT:
2705             if (!nextchr && locinput >= PL_regeol)
2706                 sayNO;
2707             if (do_utf8) {
2708                 LOAD_UTF8_CHARCLASS(digit,"0");
2709                 if (OP(scan) == NDIGIT
2710                     ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
2711                     : isDIGIT_LC_utf8((U8*)locinput))
2712                 {
2713                     sayNO;
2714                 }
2715                 locinput += PL_utf8skip[nextchr];
2716                 nextchr = UCHARAT(locinput);
2717                 break;
2718             }
2719             if (OP(scan) == NDIGIT
2720                 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
2721                 sayNO;
2722             nextchr = UCHARAT(++locinput);
2723             break;
2724         case CLUMP:
2725             if (locinput >= PL_regeol)
2726                 sayNO;
2727             if  (do_utf8) {
2728                 LOAD_UTF8_CHARCLASS(mark,"~");
2729                 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
2730                     sayNO;
2731                 locinput += PL_utf8skip[nextchr];
2732                 while (locinput < PL_regeol &&
2733                        swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
2734                     locinput += UTF8SKIP(locinput);
2735                 if (locinput > PL_regeol)
2736                     sayNO;
2737             } 
2738             else
2739                locinput++;
2740             nextchr = UCHARAT(locinput);
2741             break;
2742         case REFFL:
2743             PL_reg_flags |= RF_tainted;
2744             /* FALL THROUGH */
2745         case REF:
2746         case REFF:
2747             n = ARG(scan);  /* which paren pair */
2748             ln = PL_regstartp[n];
2749             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
2750             if ((I32)*PL_reglastparen < n || ln == -1)
2751                 sayNO;                  /* Do not match unless seen CLOSEn. */
2752             if (ln == PL_regendp[n])
2753                 break;
2754
2755             s = PL_bostr + ln;
2756             if (do_utf8 && OP(scan) != REF) {   /* REF can do byte comparison */
2757                 char *l = locinput;
2758                 char *e = PL_bostr + PL_regendp[n];
2759                 /*
2760                  * Note that we can't do the "other character" lookup trick as
2761                  * in the 8-bit case (no pun intended) because in Unicode we
2762                  * have to map both upper and title case to lower case.
2763                  */
2764                 if (OP(scan) == REFF) {
2765                     STRLEN ulen1, ulen2;
2766                     U8 tmpbuf1[UTF8_MAXLEN_UCLC+1];
2767                     U8 tmpbuf2[UTF8_MAXLEN_UCLC+1];
2768                     while (s < e) {
2769                         if (l >= PL_regeol)
2770                             sayNO;
2771                         toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
2772                         toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
2773                         if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
2774                             sayNO;
2775                         s += ulen1;
2776                         l += ulen2;
2777                     }
2778                 }
2779                 locinput = l;
2780                 nextchr = UCHARAT(locinput);
2781                 break;
2782             }
2783
2784             /* Inline the first character, for speed. */
2785             if (UCHARAT(s) != nextchr &&
2786                 (OP(scan) == REF ||
2787                  (UCHARAT(s) != ((OP(scan) == REFF
2788                                   ? PL_fold : PL_fold_locale)[nextchr]))))
2789                 sayNO;
2790             ln = PL_regendp[n] - ln;
2791             if (locinput + ln > PL_regeol)
2792                 sayNO;
2793             if (ln > 1 && (OP(scan) == REF
2794                            ? memNE(s, locinput, ln)
2795                            : (OP(scan) == REFF
2796                               ? ibcmp(s, locinput, ln)
2797                               : ibcmp_locale(s, locinput, ln))))
2798                 sayNO;
2799             locinput += ln;
2800             nextchr = UCHARAT(locinput);
2801             break;
2802
2803         case NOTHING:
2804         case TAIL:
2805             break;
2806         case BACK:
2807             break;
2808         case EVAL:
2809         {
2810             dSP;
2811             OP_4tree *oop = PL_op;
2812             COP *ocurcop = PL_curcop;
2813             PAD *old_comppad;
2814             SV *ret;
2815         
2816             n = ARG(scan);
2817             PL_op = (OP_4tree*)PL_regdata->data[n];
2818             DEBUG_r( PerlIO_printf(Perl_debug_log, "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
2819             PAD_SAVE_LOCAL(old_comppad, (PAD*)PL_regdata->data[n + 2]);
2820             PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
2821
2822             {
2823                 SV **before = SP;
2824                 CALLRUNOPS(aTHX);                       /* Scalar context. */
2825                 SPAGAIN;
2826                 if (SP == before)
2827                     ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
2828                 else {
2829                     ret = POPs;
2830                     PUTBACK;
2831                 }
2832             }
2833
2834             PL_op = oop;
2835             PAD_RESTORE_LOCAL(old_comppad);
2836             PL_curcop = ocurcop;
2837             if (logical) {
2838                 if (logical == 2) {     /* Postponed subexpression. */
2839                     regexp *re;
2840                     MAGIC *mg = Null(MAGIC*);
2841                     re_cc_state state;
2842                     CHECKPOINT cp, lastcp;
2843                     int toggleutf;
2844
2845                     if(SvROK(ret) || SvRMAGICAL(ret)) {
2846                         SV *sv = SvROK(ret) ? SvRV(ret) : ret;
2847
2848                         if(SvMAGICAL(sv))
2849                             mg = mg_find(sv, PERL_MAGIC_qr);
2850                     }
2851                     if (mg) {
2852                         re = (regexp *)mg->mg_obj;
2853                         (void)ReREFCNT_inc(re);
2854                     }
2855                     else {
2856                         STRLEN len;
2857                         char *t = SvPV(ret, len);
2858                         PMOP pm;
2859                         char *oprecomp = PL_regprecomp;
2860                         I32 osize = PL_regsize;
2861                         I32 onpar = PL_regnpar;
2862
2863                         Zero(&pm, 1, PMOP);
2864                         if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
2865                         re = CALLREGCOMP(aTHX_ t, t + len, &pm);
2866                         if (!(SvFLAGS(ret)
2867                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)))
2868                             sv_magic(ret,(SV*)ReREFCNT_inc(re),
2869                                         PERL_MAGIC_qr,0,0);
2870                         PL_regprecomp = oprecomp;
2871                         PL_regsize = osize;
2872                         PL_regnpar = onpar;
2873                     }
2874                     DEBUG_r(
2875                         PerlIO_printf(Perl_debug_log,
2876                                       "Entering embedded `%s%.60s%s%s'\n",
2877                                       PL_colors[0],
2878                                       re->precomp,
2879                                       PL_colors[1],
2880                                       (strlen(re->precomp) > 60 ? "..." : ""))
2881                         );
2882                     state.node = next;
2883                     state.prev = PL_reg_call_cc;
2884                     state.cc = PL_regcc;
2885                     state.re = PL_reg_re;
2886
2887                     PL_regcc = 0;
2888                 
2889                     cp = regcppush(0);  /* Save *all* the positions. */
2890                     REGCP_SET(lastcp);
2891                     cache_re(re);
2892                     state.ss = PL_savestack_ix;
2893                     *PL_reglastparen = 0;
2894                     *PL_reglastcloseparen = 0;
2895                     PL_reg_call_cc = &state;
2896                     PL_reginput = locinput;
2897                     toggleutf = ((PL_reg_flags & RF_utf8) != 0) ^
2898                                 ((re->reganch & ROPT_UTF8) != 0);
2899                     if (toggleutf) PL_reg_flags ^= RF_utf8;
2900
2901                     /* XXXX This is too dramatic a measure... */
2902                     PL_reg_maxiter = 0;
2903
2904                     if (regmatch(re->program + 1)) {
2905                         /* Even though we succeeded, we need to restore
2906                            global variables, since we may be wrapped inside
2907                            SUSPEND, thus the match may be not finished yet. */
2908
2909                         /* XXXX Do this only if SUSPENDed? */
2910                         PL_reg_call_cc = state.prev;
2911                         PL_regcc = state.cc;
2912                         PL_reg_re = state.re;
2913                         cache_re(PL_reg_re);
2914                         if (toggleutf) PL_reg_flags ^= RF_utf8;
2915
2916                         /* XXXX This is too dramatic a measure... */
2917                         PL_reg_maxiter = 0;
2918
2919                         /* These are needed even if not SUSPEND. */
2920                         ReREFCNT_dec(re);
2921                         regcpblow(cp);
2922                         sayYES;
2923                     }
2924                     ReREFCNT_dec(re);
2925                     REGCP_UNWIND(lastcp);
2926                     regcppop();
2927                     PL_reg_call_cc = state.prev;
2928                     PL_regcc = state.cc;
2929                     PL_reg_re = state.re;
2930                     cache_re(PL_reg_re);
2931                     if (toggleutf) PL_reg_flags ^= RF_utf8;
2932
2933                     /* XXXX This is too dramatic a measure... */
2934                     PL_reg_maxiter = 0;
2935
2936                     logical = 0;
2937                     sayNO;
2938                 }
2939                 sw = SvTRUE(ret);
2940                 logical = 0;
2941             }
2942             else
2943                 sv_setsv(save_scalar(PL_replgv), ret);
2944             break;
2945         }
2946         case OPEN:
2947             n = ARG(scan);  /* which paren pair */
2948             PL_reg_start_tmp[n] = locinput;
2949             if (n > PL_regsize)
2950                 PL_regsize = n;
2951             break;
2952         case CLOSE:
2953             n = ARG(scan);  /* which paren pair */
2954             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
2955             PL_regendp[n] = locinput - PL_bostr;
2956             if (n > (I32)*PL_reglastparen)
2957                 *PL_reglastparen = n;
2958             *PL_reglastcloseparen = n;
2959             break;
2960         case GROUPP:
2961             n = ARG(scan);  /* which paren pair */
2962             sw = ((I32)*PL_reglastparen >= n && PL_regendp[n] != -1);
2963             break;
2964         case IFTHEN:
2965             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
2966             if (sw)
2967                 next = NEXTOPER(NEXTOPER(scan));
2968             else {
2969                 next = scan + ARG(scan);
2970                 if (OP(next) == IFTHEN) /* Fake one. */
2971                     next = NEXTOPER(NEXTOPER(next));
2972             }
2973             break;
2974         case LOGICAL:
2975             logical = scan->flags;
2976             break;
2977 /*******************************************************************
2978  PL_regcc contains infoblock about the innermost (...)* loop, and
2979  a pointer to the next outer infoblock.
2980
2981  Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
2982
2983    1) After matching X, regnode for CURLYX is processed;
2984
2985    2) This regnode creates infoblock on the stack, and calls
2986       regmatch() recursively with the starting point at WHILEM node;
2987
2988    3) Each hit of WHILEM node tries to match A and Z (in the order
2989       depending on the current iteration, min/max of {min,max} and
2990       greediness).  The information about where are nodes for "A"
2991       and "Z" is read from the infoblock, as is info on how many times "A"
2992       was already matched, and greediness.
2993
2994    4) After A matches, the same WHILEM node is hit again.
2995
2996    5) Each time WHILEM is hit, PL_regcc is the infoblock created by CURLYX
2997       of the same pair.  Thus when WHILEM tries to match Z, it temporarily
2998       resets PL_regcc, since this Y(A)*Z can be a part of some other loop:
2999       as in (Y(A)*Z)*.  If Z matches, the automaton will hit the WHILEM node
3000       of the external loop.
3001
3002  Currently present infoblocks form a tree with a stem formed by PL_curcc
3003  and whatever it mentions via ->next, and additional attached trees
3004  corresponding to temporarily unset infoblocks as in "5" above.
3005
3006  In the following picture infoblocks for outer loop of
3007  (Y(A)*?Z)*?T are denoted O, for inner I.  NULL starting block
3008  is denoted by x.  The matched string is YAAZYAZT.  Temporarily postponed
3009  infoblocks are drawn below the "reset" infoblock.
3010
3011  In fact in the picture below we do not show failed matches for Z and T
3012  by WHILEM blocks.  [We illustrate minimal matches, since for them it is
3013  more obvious *why* one needs to *temporary* unset infoblocks.]
3014
3015   Matched       REx position    InfoBlocks      Comment
3016                 (Y(A)*?Z)*?T    x
3017                 Y(A)*?Z)*?T     x <- O
3018   Y             (A)*?Z)*?T      x <- O
3019   Y             A)*?Z)*?T       x <- O <- I
3020   YA            )*?Z)*?T        x <- O <- I
3021   YA            A)*?Z)*?T       x <- O <- I
3022   YAA           )*?Z)*?T        x <- O <- I
3023   YAA           Z)*?T           x <- O          # Temporary unset I
3024                                      I
3025
3026   YAAZ          Y(A)*?Z)*?T     x <- O
3027                                      I
3028
3029   YAAZY         (A)*?Z)*?T      x <- O
3030                                      I
3031
3032   YAAZY         A)*?Z)*?T       x <- O <- I
3033                                      I
3034
3035   YAAZYA        )*?Z)*?T        x <- O <- I     
3036                                      I
3037
3038   YAAZYA        Z)*?T           x <- O          # Temporary unset I
3039                                      I,I
3040
3041   YAAZYAZ       )*?T            x <- O
3042                                      I,I
3043
3044   YAAZYAZ       T               x               # Temporary unset O
3045                                 O
3046                                 I,I
3047
3048   YAAZYAZT                      x
3049                                 O
3050                                 I,I
3051  *******************************************************************/
3052         case CURLYX: {
3053                 CURCUR cc;
3054                 CHECKPOINT cp = PL_savestack_ix;
3055                 /* No need to save/restore up to this paren */
3056                 I32 parenfloor = scan->flags;
3057
3058                 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
3059                     next += ARG(next);
3060                 cc.oldcc = PL_regcc;
3061                 PL_regcc = &cc;
3062                 /* XXXX Probably it is better to teach regpush to support
3063                    parenfloor > PL_regsize... */
3064                 if (parenfloor > (I32)*PL_reglastparen)
3065                     parenfloor = *PL_reglastparen; /* Pessimization... */
3066                 cc.parenfloor = parenfloor;
3067                 cc.cur = -1;
3068                 cc.min = ARG1(scan);
3069                 cc.max  = ARG2(scan);
3070                 cc.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3071                 cc.next = next;
3072                 cc.minmod = minmod;
3073                 cc.lastloc = 0;
3074                 PL_reginput = locinput;
3075                 n = regmatch(PREVOPER(next));   /* start on the WHILEM */
3076                 regcpblow(cp);
3077                 PL_regcc = cc.oldcc;
3078                 saySAME(n);
3079             }
3080             /* NOT REACHED */
3081         case WHILEM: {
3082                 /*
3083                  * This is really hard to understand, because after we match
3084                  * what we're trying to match, we must make sure the rest of
3085                  * the REx is going to match for sure, and to do that we have
3086                  * to go back UP the parse tree by recursing ever deeper.  And
3087                  * if it fails, we have to reset our parent's current state
3088                  * that we can try again after backing off.
3089                  */
3090
3091                 CHECKPOINT cp, lastcp;
3092                 CURCUR* cc = PL_regcc;
3093                 char *lastloc = cc->lastloc; /* Detection of 0-len. */
3094                 
3095                 n = cc->cur + 1;        /* how many we know we matched */
3096                 PL_reginput = locinput;
3097
3098                 DEBUG_r(
3099                     PerlIO_printf(Perl_debug_log,
3100                                   "%*s  %ld out of %ld..%ld  cc=%"UVxf"\n",
3101                                   REPORT_CODE_OFF+PL_regindent*2, "",
3102                                   (long)n, (long)cc->min,
3103                                   (long)cc->max, PTR2UV(cc))
3104                     );
3105
3106                 /* If degenerate scan matches "", assume scan done. */
3107
3108                 if (locinput == cc->lastloc && n >= cc->min) {
3109                     PL_regcc = cc->oldcc;
3110                     if (PL_regcc)
3111                         ln = PL_regcc->cur;
3112                     DEBUG_r(
3113                         PerlIO_printf(Perl_debug_log,
3114                            "%*s  empty match detected, try continuation...\n",
3115                            REPORT_CODE_OFF+PL_regindent*2, "")
3116                         );
3117                     if (regmatch(cc->next))
3118                         sayYES;
3119                     if (PL_regcc)
3120                         PL_regcc->cur = ln;
3121                     PL_regcc = cc;
3122                     sayNO;
3123                 }
3124
3125                 /* First just match a string of min scans. */
3126
3127                 if (n < cc->min) {
3128                     cc->cur = n;
3129                     cc->lastloc = locinput;
3130                     if (regmatch(cc->scan))
3131                         sayYES;
3132                     cc->cur = n - 1;
3133                     cc->lastloc = lastloc;
3134                     sayNO;
3135                 }
3136
3137                 if (scan->flags) {
3138                     /* Check whether we already were at this position.
3139                         Postpone detection until we know the match is not
3140                         *that* much linear. */
3141                 if (!PL_reg_maxiter) {
3142                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
3143                     PL_reg_leftiter = PL_reg_maxiter;
3144                 }
3145                 if (PL_reg_leftiter-- == 0) {
3146                     I32 size = (PL_reg_maxiter + 7)/8;
3147                     if (PL_reg_poscache) {
3148                         if ((I32)PL_reg_poscache_size < size) {
3149                             Renew(PL_reg_poscache, size, char);
3150                             PL_reg_poscache_size = size;
3151                         }
3152                         Zero(PL_reg_poscache, size, char);
3153                     }
3154                     else {
3155                         PL_reg_poscache_size = size;
3156                         Newz(29, PL_reg_poscache, size, char);
3157                     }
3158                     DEBUG_r(
3159                         PerlIO_printf(Perl_debug_log,
3160               "%sDetected a super-linear match, switching on caching%s...\n",
3161                                       PL_colors[4], PL_colors[5])
3162                         );
3163                 }
3164                 if (PL_reg_leftiter < 0) {
3165                     I32 o = locinput - PL_bostr, b;
3166
3167                     o = (scan->flags & 0xf) - 1 + o * (scan->flags>>4);
3168                     b = o % 8;
3169                     o /= 8;
3170                     if (PL_reg_poscache[o] & (1<<b)) {
3171                     DEBUG_r(
3172                         PerlIO_printf(Perl_debug_log,
3173                                       "%*s  already tried at this position...\n",
3174                                       REPORT_CODE_OFF+PL_regindent*2, "")
3175                         );
3176                         sayNO_SILENT;
3177                     }
3178                     PL_reg_poscache[o] |= (1<<b);
3179                 }
3180                 }
3181
3182                 /* Prefer next over scan for minimal matching. */
3183
3184                 if (cc->minmod) {
3185                     PL_regcc = cc->oldcc;
3186                     if (PL_regcc)
3187                         ln = PL_regcc->cur;
3188                     cp = regcppush(cc->parenfloor);
3189                     REGCP_SET(lastcp);
3190                     if (regmatch(cc->next)) {
3191                         regcpblow(cp);
3192                         sayYES; /* All done. */
3193                     }
3194                     REGCP_UNWIND(lastcp);
3195                     regcppop();
3196                     if (PL_regcc)
3197                         PL_regcc->cur = ln;
3198                     PL_regcc = cc;
3199
3200                     if (n >= cc->max) { /* Maximum greed exceeded? */
3201                         if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3202                             && !(PL_reg_flags & RF_warned)) {
3203                             PL_reg_flags |= RF_warned;
3204                             Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3205                                  "Complex regular subexpression recursion",
3206                                  REG_INFTY - 1);
3207                         }
3208                         sayNO;
3209                     }
3210
3211                     DEBUG_r(
3212                         PerlIO_printf(Perl_debug_log,
3213                                       "%*s  trying longer...\n",
3214                                       REPORT_CODE_OFF+PL_regindent*2, "")
3215                         );
3216                     /* Try scanning more and see if it helps. */
3217                     PL_reginput = locinput;
3218                     cc->cur = n;
3219                     cc->lastloc = locinput;
3220                     cp = regcppush(cc->parenfloor);
3221                     REGCP_SET(lastcp);
3222                     if (regmatch(cc->scan)) {
3223                         regcpblow(cp);
3224                         sayYES;
3225                     }
3226                     REGCP_UNWIND(lastcp);
3227                     regcppop();
3228                     cc->cur = n - 1;
3229                     cc->lastloc = lastloc;
3230                     sayNO;
3231                 }
3232
3233                 /* Prefer scan over next for maximal matching. */
3234
3235                 if (n < cc->max) {      /* More greed allowed? */
3236                     cp = regcppush(cc->parenfloor);
3237                     cc->cur = n;
3238                     cc->lastloc = locinput;
3239                     REGCP_SET(lastcp);
3240                     if (regmatch(cc->scan)) {
3241                         regcpblow(cp);
3242                         sayYES;
3243                     }
3244                     REGCP_UNWIND(lastcp);
3245                     regcppop();         /* Restore some previous $<digit>s? */
3246                     PL_reginput = locinput;
3247                     DEBUG_r(
3248                         PerlIO_printf(Perl_debug_log,
3249                                       "%*s  failed, try continuation...\n",
3250                                       REPORT_CODE_OFF+PL_regindent*2, "")
3251                         );
3252                 }
3253                 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3254                         && !(PL_reg_flags & RF_warned)) {
3255                     PL_reg_flags |= RF_warned;
3256                     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3257                          "Complex regular subexpression recursion",
3258                          REG_INFTY - 1);
3259                 }
3260
3261                 /* Failed deeper matches of scan, so see if this one works. */
3262                 PL_regcc = cc->oldcc;
3263                 if (PL_regcc)
3264                     ln = PL_regcc->cur;
3265                 if (regmatch(cc->next))
3266                     sayYES;
3267                 if (PL_regcc)
3268                     PL_regcc->cur = ln;
3269                 PL_regcc = cc;
3270                 cc->cur = n - 1;
3271                 cc->lastloc = lastloc;
3272                 sayNO;
3273             }
3274             /* NOT REACHED */
3275         case BRANCHJ:
3276             next = scan + ARG(scan);
3277             if (next == scan)
3278                 next = NULL;
3279             inner = NEXTOPER(NEXTOPER(scan));
3280             goto do_branch;
3281         case BRANCH:
3282             inner = NEXTOPER(scan);
3283           do_branch:
3284             {
3285                 c1 = OP(scan);
3286                 if (OP(next) != c1)     /* No choice. */
3287                     next = inner;       /* Avoid recursion. */
3288                 else {
3289                     I32 lastparen = *PL_reglastparen;
3290                     I32 unwind1;
3291                     re_unwind_branch_t *uw;
3292
3293                     /* Put unwinding data on stack */
3294                     unwind1 = SSNEWt(1,re_unwind_branch_t);
3295                     uw = SSPTRt(unwind1,re_unwind_branch_t);
3296                     uw->prev = unwind;
3297                     unwind = unwind1;
3298                     uw->type = ((c1 == BRANCH)
3299                                 ? RE_UNWIND_BRANCH
3300                                 : RE_UNWIND_BRANCHJ);
3301                     uw->lastparen = lastparen;
3302                     uw->next = next;
3303                     uw->locinput = locinput;
3304                     uw->nextchr = nextchr;
3305 #ifdef DEBUGGING
3306                     uw->regindent = ++PL_regindent;
3307 #endif
3308
3309                     REGCP_SET(uw->lastcp);
3310
3311                     /* Now go into the first branch */
3312                     next = inner;
3313                 }
3314             }
3315             break;
3316         case MINMOD:
3317             minmod = 1;
3318             break;
3319         case CURLYM:
3320         {
3321             I32 l = 0;
3322             CHECKPOINT lastcp;
3323         
3324             /* We suppose that the next guy does not need
3325                backtracking: in particular, it is of constant length,
3326                and has no parenths to influence future backrefs. */
3327             ln = ARG1(scan);  /* min to match */
3328             n  = ARG2(scan);  /* max to match */
3329             paren = scan->flags;
3330             if (paren) {
3331                 if (paren > PL_regsize)
3332                     PL_regsize = paren;
3333                 if (paren > (I32)*PL_reglastparen)
3334                     *PL_reglastparen = paren;
3335             }
3336             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3337             if (paren)
3338                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
3339             PL_reginput = locinput;
3340             if (minmod) {
3341                 minmod = 0;
3342                 if (ln && regrepeat_hard(scan, ln, &l) < ln)
3343                     sayNO;
3344                 /* if we matched something zero-length we don't need to
3345                    backtrack - capturing parens are already defined, so
3346                    the caveat in the maximal case doesn't apply
3347
3348                    XXXX if ln == 0, we can redo this check first time
3349                    through the following loop
3350                 */
3351                 if (ln && l == 0)
3352                     n = ln;     /* don't backtrack */
3353                 locinput = PL_reginput;
3354                 if (HAS_TEXT(next) || JUMPABLE(next)) {
3355                     regnode *text_node = next;
3356
3357                     if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
3358
3359                     if (! HAS_TEXT(text_node)) c1 = c2 = -1000;
3360                     else {
3361                         if (PL_regkind[(U8)OP(text_node)] == REF) {
3362                             I32 n, ln;
3363                             n = ARG(text_node);  /* which paren pair */
3364                             ln = PL_regstartp[n];
3365                             /* assume yes if we haven't seen CLOSEn */
3366                             if (
3367                                 (I32)*PL_reglastparen < n ||
3368                                 ln == -1 ||
3369                                 ln == PL_regendp[n]
3370                             ) {
3371                                 c1 = c2 = -1000;
3372                                 goto assume_ok_MM;
3373                             }
3374                             c1 = *(PL_bostr + ln);
3375                         }
3376                         else { c1 = (U8)*STRING(text_node); }
3377                         if (OP(text_node) == EXACTF || OP(text_node) == REFF)
3378                             c2 = PL_fold[c1];
3379                         else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
3380                             c2 = PL_fold_locale[c1];
3381                         else
3382                             c2 = c1;
3383                     }
3384                 }
3385                 else
3386                     c1 = c2 = -1000;
3387             assume_ok_MM:
3388                 REGCP_SET(lastcp);
3389                 /* This may be improved if l == 0.  */
3390                 while (n >= ln || (n == REG_INFTY && ln > 0 && l)) { /* ln overflow ? */
3391                     /* If it could work, try it. */
3392                     if (c1 == -1000 ||
3393                         UCHARAT(PL_reginput) == c1 ||
3394                         UCHARAT(PL_reginput) == c2)
3395                     {
3396                         if (paren) {
3397                             if (ln) {
3398                                 PL_regstartp[paren] =
3399                                     HOPc(PL_reginput, -l) - PL_bostr;
3400                                 PL_regendp[paren] = PL_reginput - PL_bostr;
3401                             }
3402                             else
3403                                 PL_regendp[paren] = -1;
3404                         }
3405                         if (regmatch(next))
3406                             sayYES;
3407                         REGCP_UNWIND(lastcp);
3408                     }
3409                     /* Couldn't or didn't -- move forward. */
3410                     PL_reginput = locinput;
3411                     if (regrepeat_hard(scan, 1, &l)) {
3412                         ln++;
3413                         locinput = PL_reginput;
3414                     }
3415                     else
3416                         sayNO;
3417                 }
3418             }
3419             else {
3420                 n = regrepeat_hard(scan, n, &l);
3421                 /* if we matched something zero-length we don't need to
3422                    backtrack, unless the minimum count is zero and we
3423                    are capturing the result - in that case the capture
3424                    being defined or not may affect later execution
3425                 */
3426                 if (n != 0 && l == 0 && !(paren && ln == 0))
3427                     ln = n;     /* don't backtrack */
3428                 locinput = PL_reginput;
3429                 DEBUG_r(
3430                     PerlIO_printf(Perl_debug_log,
3431                                   "%*s  matched %"IVdf" times, len=%"IVdf"...\n",
3432                                   (int)(REPORT_CODE_OFF+PL_regindent*2), "",
3433                                   (IV) n, (IV)l)
3434                     );
3435                 if (n >= ln) {
3436                     if (HAS_TEXT(next) || JUMPABLE(next)) {
3437                         regnode *text_node = next;
3438
3439                         if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
3440
3441                         if (! HAS_TEXT(text_node)) c1 = c2 = -1000;
3442                         else {
3443                             if (PL_regkind[(U8)OP(text_node)] == REF) {
3444                                 I32 n, ln;
3445                                 n = ARG(text_node);  /* which paren pair */
3446                                 ln = PL_regstartp[n];
3447                                 /* assume yes if we haven't seen CLOSEn */
3448                                 if (
3449                                     (I32)*PL_reglastparen < n ||
3450                                     ln == -1 ||
3451                                     ln == PL_regendp[n]
3452                                 ) {
3453                                     c1 = c2 = -1000;
3454                                     goto assume_ok_REG;
3455                                 }
3456                                 c1 = *(PL_bostr + ln);
3457                             }
3458                             else { c1 = (U8)*STRING(text_node); }
3459
3460                             if (OP(text_node) == EXACTF || OP(text_node) == REFF)
3461                                 c2 = PL_fold[c1];
3462                             else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
3463                                 c2 = PL_fold_locale[c1];
3464                             else
3465                                 c2 = c1;
3466                         }
3467                     }
3468                     else
3469                         c1 = c2 = -1000;
3470                 }
3471             assume_ok_REG:
3472                 REGCP_SET(lastcp);
3473                 while (n >= ln) {
3474                     /* If it could work, try it. */
3475                     if (c1 == -1000 ||
3476                         UCHARAT(PL_reginput) == c1 ||
3477                         UCHARAT(PL_reginput) == c2)
3478                     {
3479                         DEBUG_r(
3480                                 PerlIO_printf(Perl_debug_log,
3481                                               "%*s  trying tail with n=%"IVdf"...\n",
3482                                               (int)(REPORT_CODE_OFF+PL_regindent*2), "", (IV)n)
3483                             );
3484                         if (paren) {
3485                             if (n) {
3486                                 PL_regstartp[paren] = HOPc(PL_reginput, -l) - PL_bostr;
3487                                 PL_regendp[paren] = PL_reginput - PL_bostr;
3488                             }
3489                             else
3490                                 PL_regendp[paren] = -1;
3491                         }
3492                         if (regmatch(next))
3493                             sayYES;
3494                         REGCP_UNWIND(lastcp);
3495                     }
3496                     /* Couldn't or didn't -- back up. */
3497                     n--;
3498                     locinput = HOPc(locinput, -l);
3499                     PL_reginput = locinput;
3500                 }
3501             }
3502             sayNO;
3503             break;
3504         }
3505         case CURLYN:
3506             paren = scan->flags;        /* Which paren to set */
3507             if (paren > PL_regsize)
3508                 PL_regsize = paren;
3509             if (paren > (I32)*PL_reglastparen)
3510                 *PL_reglastparen = paren;
3511             ln = ARG1(scan);  /* min to match */
3512             n  = ARG2(scan);  /* max to match */
3513             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
3514             goto repeat;
3515         case CURLY:
3516             paren = 0;
3517             ln = ARG1(scan);  /* min to match */
3518             n  = ARG2(scan);  /* max to match */
3519             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3520             goto repeat;
3521         case STAR:
3522             ln = 0;
3523             n = REG_INFTY;
3524             scan = NEXTOPER(scan);
3525             paren = 0;
3526             goto repeat;
3527         case PLUS:
3528             ln = 1;
3529             n = REG_INFTY;
3530             scan = NEXTOPER(scan);
3531             paren = 0;
3532           repeat:
3533             /*
3534             * Lookahead to avoid useless match attempts
3535             * when we know what character comes next.
3536             */
3537
3538             /*
3539             * Used to only do .*x and .*?x, but now it allows
3540             * for )'s, ('s and (?{ ... })'s to be in the way
3541             * of the quantifier and the EXACT-like node.  -- japhy
3542             */
3543
3544             if (HAS_TEXT(next) || JUMPABLE(next)) {
3545                 U8 *s;
3546                 regnode *text_node = next;
3547
3548                 if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
3549
3550                 if (! HAS_TEXT(text_node)) c1 = c2 = -1000;
3551                 else {
3552                     if (PL_regkind[(U8)OP(text_node)] == REF) {
3553                         I32 n, ln;
3554                         n = ARG(text_node);  /* which paren pair */
3555                         ln = PL_regstartp[n];
3556                         /* assume yes if we haven't seen CLOSEn */
3557                         if (
3558                             (I32)*PL_reglastparen < n ||
3559                             ln == -1 ||
3560                             ln == PL_regendp[n]
3561                         ) {
3562                             c1 = c2 = -1000;
3563                             goto assume_ok_easy;
3564                         }
3565                         s = (U8*)PL_bostr + ln;
3566                     }
3567                     else { s = (U8*)STRING(text_node); }
3568
3569                     if (!UTF) {
3570                         c2 = c1 = *s;
3571                         if (OP(text_node) == EXACTF || OP(text_node) == REFF)
3572                             c2 = PL_fold[c1];
3573                         else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
3574                             c2 = PL_fold_locale[c1];
3575                     }
3576                     else { /* UTF */
3577                         if (OP(text_node) == EXACTF || OP(text_node) == REFF) {
3578                              STRLEN ulen1, ulen2;
3579                              U8 tmpbuf1[UTF8_MAXLEN_UCLC+1];
3580                              U8 tmpbuf2[UTF8_MAXLEN_UCLC+1];
3581
3582                              to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
3583                              to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
3584
3585                              c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXLEN, 0,
3586                                                  ckWARN(WARN_UTF8) ?
3587                                                  0 : UTF8_ALLOW_ANY);
3588                              c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXLEN, 0,
3589                                                  ckWARN(WARN_UTF8) ?
3590                                                  0 : UTF8_ALLOW_ANY);
3591                         }
3592                         else {
3593                             c2 = c1 = utf8n_to_uvchr(s, UTF8_MAXLEN, 0,
3594                                                      ckWARN(WARN_UTF8) ?
3595                                                      0 : UTF8_ALLOW_ANY);
3596                         }
3597                     }
3598                 }
3599             }
3600             else
3601                 c1 = c2 = -1000;
3602         assume_ok_easy:
3603             PL_reginput = locinput;
3604             if (minmod) {
3605                 CHECKPOINT lastcp;
3606                 minmod = 0;
3607                 if (ln && regrepeat(scan, ln) < ln)
3608                     sayNO;
3609                 locinput = PL_reginput;
3610                 REGCP_SET(lastcp);
3611                 if (c1 != -1000) {
3612                     char *e; /* Should not check after this */
3613                     char *old = locinput;
3614                     int count = 0;
3615
3616                     if  (n == REG_INFTY) {
3617                         e = PL_regeol - 1;
3618                         if (do_utf8)
3619                             while (UTF8_IS_CONTINUATION(*(U8*)e))
3620                                 e--;
3621                     }
3622                     else if (do_utf8) {
3623                         int m = n - ln;
3624                         for (e = locinput;
3625                              m >0 && e + UTF8SKIP(e) <= PL_regeol; m--)
3626                             e += UTF8SKIP(e);
3627                     }
3628                     else {
3629                         e = locinput + n - ln;
3630                         if (e >= PL_regeol)
3631                             e = PL_regeol - 1;
3632                     }
3633                     while (1) {
3634                         /* Find place 'next' could work */
3635                         if (!do_utf8) {
3636                             if (c1 == c2) {
3637                                 while (locinput <= e &&
3638                                        UCHARAT(locinput) != c1)
3639                                     locinput++;
3640                             } else {
3641                                 while (locinput <= e
3642                                        && UCHARAT(locinput) != c1
3643                                        && UCHARAT(locinput) != c2)
3644                                     locinput++;
3645                             }
3646                             count = locinput - old;
3647                         }
3648                         else {
3649                             STRLEN len;
3650                             if (c1 == c2) {
3651                                 /* count initialised to
3652                                  * utf8_distance(old, locinput) */
3653                                 while (locinput <= e &&
3654                                        utf8n_to_uvchr((U8*)locinput,
3655                                                       UTF8_MAXLEN, &len,
3656                                                       ckWARN(WARN_UTF8) ?
3657                                                       0 : UTF8_ALLOW_ANY) != (UV)c1) {
3658                                     locinput += len;
3659                                     count++;
3660                                 }
3661                             } else {
3662                                 /* count initialised to
3663                                  * utf8_distance(old, locinput) */
3664                                 while (locinput <= e) {
3665                                     UV c = utf8n_to_uvchr((U8*)locinput,
3666                                                           UTF8_MAXLEN, &len,
3667                                                           ckWARN(WARN_UTF8) ?
3668                                                           0 : UTF8_ALLOW_ANY);
3669                                     if (c == (UV)c1 || c == (UV)c2)
3670                                         break;
3671                                     locinput += len;
3672                                     count++;
3673                                 }
3674                             }
3675                         }
3676                         if (locinput > e)
3677                             sayNO;
3678                         /* PL_reginput == old now */
3679                         if (locinput != old) {
3680                             ln = 1;     /* Did some */
3681                             if (regrepeat(scan, count) < count)
3682                                 sayNO;
3683                         }
3684                         /* PL_reginput == locinput now */
3685                         TRYPAREN(paren, ln, locinput);
3686                         PL_reginput = locinput; /* Could be reset... */
3687                         REGCP_UNWIND(lastcp);
3688                         /* Couldn't or didn't -- move forward. */
3689                         old = locinput;
3690                         if (do_utf8)
3691                             locinput += UTF8SKIP(locinput);
3692                         else
3693                             locinput++;
3694                         count = 1;
3695                     }
3696                 }
3697                 else
3698                 while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */
3699                     UV c;
3700                     if (c1 != -1000) {
3701                         if (do_utf8)
3702                             c = utf8n_to_uvchr((U8*)PL_reginput,
3703                                                UTF8_MAXLEN, 0,
3704                                                ckWARN(WARN_UTF8) ?
3705                                                0 : UTF8_ALLOW_ANY);
3706                         else
3707                             c = UCHARAT(PL_reginput);
3708                         /* If it could work, try it. */
3709                         if (c == (UV)c1 || c == (UV)c2)
3710                         {
3711                             TRYPAREN(paren, ln, PL_reginput);
3712                             REGCP_UNWIND(lastcp);
3713                         }
3714                     }
3715                     /* If it could work, try it. */
3716                     else if (c1 == -1000)
3717                     {
3718                         TRYPAREN(paren, ln, PL_reginput);
3719                         REGCP_UNWIND(lastcp);
3720                     }
3721                     /* Couldn't or didn't -- move forward. */
3722                     PL_reginput = locinput;
3723                     if (regrepeat(scan, 1)) {
3724                         ln++;
3725                         locinput = PL_reginput;
3726                     }
3727                     else
3728                         sayNO;
3729                 }
3730             }
3731             else {
3732                 CHECKPOINT lastcp;
3733                 n = regrepeat(scan, n);
3734                 locinput = PL_reginput;
3735                 if (ln < n && PL_regkind[(U8)OP(next)] == EOL &&
3736                     ((!PL_multiline && OP(next) != MEOL) ||
3737                         OP(next) == SEOL || OP(next) == EOS))
3738                 {
3739                     ln = n;                     /* why back off? */
3740                     /* ...because $ and \Z can match before *and* after
3741                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
3742                        We should back off by one in this case. */
3743                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
3744                         ln--;
3745                 }
3746                 REGCP_SET(lastcp);
3747                 if (paren) {
3748                     UV c = 0;
3749                     while (n >= ln) {
3750                         if (c1 != -1000) {
3751                             if (do_utf8)
3752                                 c = utf8n_to_uvchr((U8*)PL_reginput,
3753                                                    UTF8_MAXLEN, 0,
3754                                                    ckWARN(WARN_UTF8) ?
3755                                                    0 : UTF8_ALLOW_ANY);
3756                             else
3757                                 c = UCHARAT(PL_reginput);
3758                         }
3759                         /* If it could work, try it. */
3760                         if (c1 == -1000 || c == (UV)c1 || c == (UV)c2)
3761                             {
3762                                 TRYPAREN(paren, n, PL_reginput);
3763                                 REGCP_UNWIND(lastcp);
3764                             }
3765                         /* Couldn't or didn't -- back up. */
3766                         n--;
3767                         PL_reginput = locinput = HOPc(locinput, -1);
3768                     }
3769                 }
3770                 else {
3771                     UV c = 0;
3772                     while (n >= ln) {
3773                         if (c1 != -1000) {
3774                             if (do_utf8)
3775                                 c = utf8n_to_uvchr((U8*)PL_reginput,
3776                                                    UTF8_MAXLEN, 0,
3777                                                    ckWARN(WARN_UTF8) ?
3778                                                    0 : UTF8_ALLOW_ANY);
3779                             else
3780                                 c = UCHARAT(PL_reginput);
3781                         }
3782                         /* If it could work, try it. */
3783                         if (c1 == -1000 || c == (UV)c1 || c == (UV)c2)
3784                             {
3785                                 TRYPAREN(paren, n, PL_reginput);
3786                                 REGCP_UNWIND(lastcp);
3787                             }
3788                         /* Couldn't or didn't -- back up. */
3789                         n--;
3790                         PL_reginput = locinput = HOPc(locinput, -1);
3791                     }
3792                 }
3793             }
3794             sayNO;
3795             break;
3796         case END:
3797             if (PL_reg_call_cc) {
3798                 re_cc_state *cur_call_cc = PL_reg_call_cc;
3799                 CURCUR *cctmp = PL_regcc;
3800                 regexp *re = PL_reg_re;
3801                 CHECKPOINT cp, lastcp;
3802                 
3803                 cp = regcppush(0);      /* Save *all* the positions. */
3804                 REGCP_SET(lastcp);
3805                 regcp_set_to(PL_reg_call_cc->ss); /* Restore parens of
3806                                                     the caller. */
3807                 PL_reginput = locinput; /* Make position available to
3808                                            the callcc. */
3809                 cache_re(PL_reg_call_cc->re);
3810                 PL_regcc = PL_reg_call_cc->cc;
3811                 PL_reg_call_cc = PL_reg_call_cc->prev;
3812                 if (regmatch(cur_call_cc->node)) {
3813                     PL_reg_call_cc = cur_call_cc;
3814                     regcpblow(cp);
3815                     sayYES;
3816                 }
3817                 REGCP_UNWIND(lastcp);
3818                 regcppop();
3819                 PL_reg_call_cc = cur_call_cc;
3820                 PL_regcc = cctmp;
3821                 PL_reg_re = re;
3822                 cache_re(re);
3823
3824                 DEBUG_r(
3825                     PerlIO_printf(Perl_debug_log,
3826                                   "%*s  continuation failed...\n",
3827                                   REPORT_CODE_OFF+PL_regindent*2, "")
3828                     );
3829                 sayNO_SILENT;
3830             }
3831             if (locinput < PL_regtill) {
3832                 DEBUG_r(PerlIO_printf(Perl_debug_log,
3833                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
3834                                       PL_colors[4],
3835                                       (long)(locinput - PL_reg_starttry),
3836                                       (long)(PL_regtill - PL_reg_starttry),
3837                                       PL_colors[5]));
3838                 sayNO_FINAL;            /* Cannot match: too short. */
3839             }
3840             PL_reginput = locinput;     /* put where regtry can find it */
3841             sayYES_FINAL;               /* Success! */
3842         case SUCCEED:
3843             PL_reginput = locinput;     /* put where regtry can find it */
3844             sayYES_LOUD;                /* Success! */
3845         case SUSPEND:
3846             n = 1;
3847             PL_reginput = locinput;
3848             goto do_ifmatch;    
3849         case UNLESSM:
3850             n = 0;
3851             if (scan->flags) {
3852                 s = HOPBACKc(locinput, scan->flags);
3853                 if (!s)
3854                     goto say_yes;
3855                 PL_reginput = s;
3856             }
3857             else
3858                 PL_reginput = locinput;
3859             goto do_ifmatch;
3860         case IFMATCH:
3861             n = 1;
3862             if (scan->flags) {
3863                 s = HOPBACKc(locinput, scan->flags);
3864                 if (!s)
3865                     goto say_no;
3866                 PL_reginput = s;
3867             }
3868             else
3869                 PL_reginput = locinput;
3870
3871           do_ifmatch:
3872             inner = NEXTOPER(NEXTOPER(scan));
3873             if (regmatch(inner) != n) {
3874               say_no:
3875                 if (logical) {
3876                     logical = 0;
3877                     sw = 0;
3878                     goto do_longjump;
3879                 }
3880                 else
3881                     sayNO;
3882             }
3883           say_yes:
3884             if (logical) {
3885                 logical = 0;
3886                 sw = 1;
3887             }
3888             if (OP(scan) == SUSPEND) {
3889                 locinput = PL_reginput;
3890                 nextchr = UCHARAT(locinput);
3891             }
3892             /* FALL THROUGH. */
3893         case LONGJMP:
3894           do_longjump:
3895             next = scan + ARG(scan);
3896             if (next == scan)
3897                 next = NULL;
3898             break;
3899         default:
3900             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
3901                           PTR2UV(scan), OP(scan));
3902             Perl_croak(aTHX_ "regexp memory corruption");
3903         }
3904       reenter:
3905         scan = next;
3906     }
3907
3908     /*
3909     * We get here only if there's trouble -- normally "case END" is
3910     * the terminating point.
3911     */
3912     Perl_croak(aTHX_ "corrupted regexp pointers");
3913     /*NOTREACHED*/
3914     sayNO;
3915
3916 yes_loud:
3917     DEBUG_r(
3918         PerlIO_printf(Perl_debug_log,
3919                       "%*s  %scould match...%s\n",
3920                       REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],PL_colors[5])
3921         );
3922     goto yes;
3923 yes_final:
3924     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
3925                           PL_colors[4],PL_colors[5]));
3926 yes:
3927 #ifdef DEBUGGING
3928     PL_regindent--;
3929 #endif
3930
3931 #if 0                                   /* Breaks $^R */
3932     if (unwind)
3933         regcpblow(firstcp);
3934 #endif
3935     return 1;
3936
3937 no:
3938     DEBUG_r(
3939         PerlIO_printf(Perl_debug_log,
3940                       "%*s  %sfailed...%s\n",
3941                       REPORT_CODE_OFF+PL_regindent*2, "",PL_colors[4],PL_colors[5])
3942         );
3943     goto do_no;
3944 no_final:
3945 do_no:
3946     if (unwind) {
3947         re_unwind_t *uw = SSPTRt(unwind,re_unwind_t);
3948
3949         switch (uw->type) {
3950         case RE_UNWIND_BRANCH:
3951         case RE_UNWIND_BRANCHJ:
3952         {
3953             re_unwind_branch_t *uwb = &(uw->branch);
3954             I32 lastparen = uwb->lastparen;
3955         
3956             REGCP_UNWIND(uwb->lastcp);
3957             for (n = *PL_reglastparen; n > lastparen; n--)
3958                 PL_regendp[n] = -1;
3959             *PL_reglastparen = n;
3960             scan = next = uwb->next;
3961             if ( !scan ||
3962                  OP(scan) != (uwb->type == RE_UNWIND_BRANCH
3963                               ? BRANCH : BRANCHJ) ) {           /* Failure */
3964                 unwind = uwb->prev;
3965 #ifdef DEBUGGING
3966                 PL_regindent--;
3967 #endif
3968                 goto do_no;
3969             }
3970             /* Have more choice yet.  Reuse the same uwb.  */
3971             /*SUPPRESS 560*/
3972             if ((n = (uwb->type == RE_UNWIND_BRANCH
3973                       ? NEXT_OFF(next) : ARG(next))))
3974                 next += n;
3975             else
3976                 next = NULL;    /* XXXX Needn't unwinding in this case... */
3977             uwb->next = next;
3978             next = NEXTOPER(scan);
3979             if (uwb->type == RE_UNWIND_BRANCHJ)
3980                 next = NEXTOPER(next);
3981             locinput = uwb->locinput;
3982             nextchr = uwb->nextchr;
3983 #ifdef DEBUGGING
3984             PL_regindent = uwb->regindent;
3985 #endif
3986
3987             goto reenter;
3988         }
3989         /* NOT REACHED */
3990         default:
3991             Perl_croak(aTHX_ "regexp unwind memory corruption");
3992         }
3993         /* NOT REACHED */
3994     }
3995 #ifdef DEBUGGING
3996     PL_regindent--;
3997 #endif
3998     return 0;
3999 }
4000
4001 /*
4002  - regrepeat - repeatedly match something simple, report how many
4003  */
4004 /*
4005  * [This routine now assumes that it will only match on things of length 1.
4006  * That was true before, but now we assume scan - reginput is the count,
4007  * rather than incrementing count on every character.  [Er, except utf8.]]
4008  */
4009 STATIC I32
4010 S_regrepeat(pTHX_ regnode *p, I32 max)
4011 {
4012     register char *scan;
4013     register I32 c;
4014     register char *loceol = PL_regeol;
4015     register I32 hardcount = 0;
4016     register bool do_utf8 = PL_reg_match_utf8;
4017
4018     scan = PL_reginput;
4019     if (max == REG_INFTY)
4020         max = I32_MAX;
4021     else if (max < loceol - scan)
4022       loceol = scan + max;
4023     switch (OP(p)) {
4024     case REG_ANY:
4025         if (do_utf8) {
4026             loceol = PL_regeol;
4027             while (scan < loceol && hardcount < max && *scan != '\n') {
4028                 scan += UTF8SKIP(scan);
4029                 hardcount++;
4030             }
4031         } else {
4032             while (scan < loceol && *scan != '\n')
4033                 scan++;
4034         }
4035         break;
4036     case SANY:
4037         if (do_utf8) {
4038             loceol = PL_regeol;
4039             while (scan < loceol && hardcount < max) {
4040                 scan += UTF8SKIP(scan);
4041                 hardcount++;
4042             }
4043         }
4044         else
4045             scan = loceol;
4046         break;
4047     case CANY:
4048         scan = loceol;
4049         break;
4050     case EXACT:         /* length of string is 1 */
4051         c = (U8)*STRING(p);
4052         while (scan < loceol && UCHARAT(scan) == c)
4053             scan++;
4054         break;
4055     case EXACTF:        /* length of string is 1 */
4056         c = (U8)*STRING(p);
4057         while (scan < loceol &&
4058                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
4059             scan++;
4060         break;
4061     case EXACTFL:       /* length of string is 1 */
4062         PL_reg_flags |= RF_tainted;
4063         c = (U8)*STRING(p);
4064         while (scan < loceol &&
4065                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
4066             scan++;
4067         break;
4068     case ANYOF:
4069         if (do_utf8) {
4070             loceol = PL_regeol;
4071             while (hardcount < max && scan < loceol) {
4072                  bool cont = FALSE;
4073                  if (ANYOF_FLAGS(p) & ANYOF_UNICODE) {
4074                       if (reginclass(p, (U8*)scan, 0, do_utf8))
4075                            cont = TRUE;
4076                  }
4077                  else {
4078                       U8 c = (U8)scan[0];
4079
4080                       if (UTF8_IS_INVARIANT(c)) {
4081                            if (ANYOF_BITMAP_TEST(p, c))
4082                                 cont = TRUE;
4083                       }
4084                       else {
4085                            if (reginclass(p, (U8*)scan, 0, do_utf8))
4086                                 cont = TRUE;
4087                       }
4088                 }
4089                 if (!cont)
4090                      break;
4091                 scan += UTF8SKIP(scan);
4092                 hardcount++;
4093             }
4094         } else {
4095             while (scan < loceol && REGINCLASS(p, (U8*)scan))
4096                 scan++;
4097         }
4098         break;
4099     case ALNUM:
4100         if (do_utf8) {
4101             loceol = PL_regeol;
4102             LOAD_UTF8_CHARCLASS(alnum,"a");
4103             while (hardcount < max && scan < loceol &&
4104                    swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
4105                 scan += UTF8SKIP(scan);
4106                 hardcount++;
4107             }
4108         } else {
4109             while (scan < loceol && isALNUM(*scan))
4110                 scan++;
4111         }
4112         break;
4113     case ALNUML:
4114         PL_reg_flags |= RF_tainted;
4115         if (do_utf8) {
4116             loceol = PL_regeol;
4117             while (hardcount < max && scan < loceol &&
4118                    isALNUM_LC_utf8((U8*)scan)) {
4119                 scan += UTF8SKIP(scan);
4120                 hardcount++;
4121             }
4122         } else {
4123             while (scan < loceol && isALNUM_LC(*scan))
4124                 scan++;
4125         }
4126         break;
4127     case NALNUM:
4128         if (do_utf8) {
4129             loceol = PL_regeol;
4130             LOAD_UTF8_CHARCLASS(alnum,"a");
4131             while (hardcount < max && scan < loceol &&
4132                    !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
4133                 scan += UTF8SKIP(scan);
4134                 hardcount++;
4135             }
4136         } else {
4137             while (scan < loceol && !isALNUM(*scan))
4138                 scan++;
4139         }
4140         break;
4141     case NALNUML:
4142         PL_reg_flags |= RF_tainted;
4143         if (do_utf8) {
4144             loceol = PL_regeol;
4145             while (hardcount < max && scan < loceol &&
4146                    !isALNUM_LC_utf8((U8*)scan)) {
4147                 scan += UTF8SKIP(scan);
4148                 hardcount++;
4149             }
4150         } else {
4151             while (scan < loceol && !isALNUM_LC(*scan))
4152                 scan++;
4153         }
4154         break;
4155     case SPACE:
4156         if (do_utf8) {
4157             loceol = PL_regeol;
4158             LOAD_UTF8_CHARCLASS(space," ");
4159             while (hardcount < max && scan < loceol &&
4160                    (*scan == ' ' ||
4161                     swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
4162                 scan += UTF8SKIP(scan);
4163                 hardcount++;
4164             }
4165         } else {
4166             while (scan < loceol && isSPACE(*scan))
4167                 scan++;
4168         }
4169         break;
4170     case SPACEL:
4171         PL_reg_flags |= RF_tainted;
4172         if (do_utf8) {
4173             loceol = PL_regeol;
4174             while (hardcount < max && scan < loceol &&
4175                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
4176                 scan += UTF8SKIP(scan);
4177                 hardcount++;
4178             }
4179         } else {
4180             while (scan < loceol && isSPACE_LC(*scan))
4181                 scan++;
4182         }
4183         break;
4184     case NSPACE:
4185         if (do_utf8) {
4186             loceol = PL_regeol;
4187             LOAD_UTF8_CHARCLASS(space," ");
4188             while (hardcount < max && scan < loceol &&
4189                    !(*scan == ' ' ||
4190                      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
4191                 scan += UTF8SKIP(scan);
4192                 hardcount++;
4193             }
4194         } else {
4195             while (scan < loceol && !isSPACE(*scan))
4196                 scan++;
4197             break;
4198         }
4199     case NSPACEL:
4200         PL_reg_flags |= RF_tainted;
4201         if (do_utf8) {
4202             loceol = PL_regeol;
4203             while (hardcount < max && scan < loceol &&
4204                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
4205                 scan += UTF8SKIP(scan);
4206                 hardcount++;
4207             }
4208         } else {
4209             while (scan < loceol && !isSPACE_LC(*scan))
4210                 scan++;
4211         }
4212         break;
4213     case DIGIT:
4214         if (do_utf8) {
4215             loceol = PL_regeol;
4216             LOAD_UTF8_CHARCLASS(digit,"0");
4217             while (hardcount < max && scan < loceol &&
4218                    swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
4219                 scan += UTF8SKIP(scan);
4220                 hardcount++;
4221             }
4222         } else {
4223             while (scan < loceol && isDIGIT(*scan))
4224                 scan++;
4225         }
4226         break;
4227     case NDIGIT:
4228         if (do_utf8) {
4229             loceol = PL_regeol;
4230             LOAD_UTF8_CHARCLASS(digit,"0");
4231             while (hardcount < max && scan < loceol &&
4232                    !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
4233                 scan += UTF8SKIP(scan);
4234                 hardcount++;
4235             }
4236         } else {
4237             while (scan < loceol && !isDIGIT(*scan))
4238                 scan++;
4239         }
4240         break;
4241     default:            /* Called on something of 0 width. */
4242         break;          /* So match right here or not at all. */
4243     }
4244
4245     if (hardcount)
4246         c = hardcount;
4247     else
4248         c = scan - PL_reginput;
4249     PL_reginput = scan;
4250
4251     DEBUG_r(
4252         {
4253                 SV *prop = sv_newmortal();
4254
4255                 regprop(prop, p);
4256                 PerlIO_printf(Perl_debug_log,
4257                               "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
4258                               REPORT_CODE_OFF+1, "", SvPVX(prop),(IV)c,(IV)max);
4259         });
4260
4261     return(c);
4262 }
4263
4264 /*
4265  - regrepeat_hard - repeatedly match something, report total lenth and length
4266  *
4267  * The repeater is supposed to have constant length.
4268  */
4269
4270 STATIC I32
4271 S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
4272 {
4273     register char *scan = Nullch;
4274     register char *start;
4275     register char *loceol = PL_regeol;
4276     I32 l = 0;
4277     I32 count = 0, res = 1;
4278
4279     if (!max)
4280         return 0;
4281
4282     start = PL_reginput;
4283     if (PL_reg_match_utf8) {
4284         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
4285             if (!count++) {
4286                 l = 0;
4287                 while (start < PL_reginput) {
4288                     l++;
4289                     start += UTF8SKIP(start);
4290                 }
4291                 *lp = l;
4292                 if (l == 0)
4293                     return max;
4294             }
4295             if (count == max)
4296                 return count;
4297         }
4298     }
4299     else {
4300         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
4301             if (!count++) {
4302                 *lp = l = PL_reginput - start;
4303                 if (max != REG_INFTY && l*max < loceol - scan)
4304                     loceol = scan + l*max;
4305                 if (l == 0)
4306                     return max;
4307             }
4308         }
4309     }
4310     if (!res)
4311         PL_reginput = scan;
4312
4313     return count;
4314 }
4315
4316 /*
4317 - regclass_swash - prepare the utf8 swash
4318 */
4319
4320 SV *
4321 Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** listsvp, SV **altsvp)
4322 {
4323     SV *sw  = NULL;
4324     SV *si  = NULL;
4325     SV *alt = NULL;
4326
4327     if (PL_regdata && PL_regdata->count) {
4328         U32 n = ARG(node);
4329
4330         if (PL_regdata->what[n] == 's') {
4331             SV *rv = (SV*)PL_regdata->data[n];
4332             AV *av = (AV*)SvRV((SV*)rv);
4333             SV **ary = AvARRAY(av);
4334             SV **a, **b;
4335         
4336             /* See the end of regcomp.c:S_reglass() for
4337              * documentation of these array elements. */
4338
4339             si = *ary;
4340             a  = SvTYPE(ary[1]) == SVt_RV   ? &ary[1] : 0;
4341             b  = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : 0;
4342
4343             if (a)
4344                 sw = *a;
4345             else if (si && doinit) {
4346                 sw = swash_init("utf8", "", si, 1, 0);
4347                 (void)av_store(av, 1, sw);
4348             }
4349             if (b)
4350                 alt = *b;
4351         }
4352     }
4353         
4354     if (listsvp)
4355         *listsvp = si;
4356     if (altsvp)
4357         *altsvp  = alt;
4358
4359     return sw;
4360 }
4361
4362 /*
4363  - reginclass - determine if a character falls into a character class
4364  
4365   The n is the ANYOF regnode, the p is the target string, lenp
4366   is pointer to the maximum length of how far to go in the p
4367   (if the lenp is zero, UTF8SKIP(p) is used),
4368   do_utf8 tells whether the target string is in UTF-8.
4369
4370  */
4371
4372 STATIC bool
4373 S_reginclass(pTHX_ register regnode *n, register U8* p, STRLEN* lenp, register bool do_utf8)
4374 {
4375     char flags = ANYOF_FLAGS(n);
4376     bool match = FALSE;
4377     UV c = *p;
4378     STRLEN len = 0;
4379     STRLEN plen;
4380
4381     if (do_utf8 && !UTF8_IS_INVARIANT(c))
4382          c = utf8n_to_uvchr(p, UTF8_MAXLEN, &len,
4383                             ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
4384
4385     plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
4386     if (do_utf8 || (flags & ANYOF_UNICODE)) {
4387         if (lenp)
4388             *lenp = 0;
4389         if (do_utf8 && !ANYOF_RUNTIME(n)) {
4390             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
4391                 match = TRUE;
4392         }
4393         if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
4394             match = TRUE;
4395         if (!match) {
4396             AV *av;
4397             SV *sw = regclass_swash(n, TRUE, 0, (SV**)&av);
4398         
4399             if (sw) {
4400                 if (swash_fetch(sw, p, do_utf8))
4401                     match = TRUE;
4402                 else if (flags & ANYOF_FOLD) {
4403                     if (!match && lenp && av) {
4404                         I32 i;
4405                       
4406                         for (i = 0; i <= av_len(av); i++) {
4407                             SV* sv = *av_fetch(av, i, FALSE);
4408                             STRLEN len;
4409                             char *s = SvPV(sv, len);
4410                         
4411                             if (len <= plen && memEQ(s, (char*)p, len)) {
4412                                 *lenp = len;
4413                                 match = TRUE;
4414                                 break;
4415                             }
4416                         }
4417                     }
4418                     if (!match) {
4419                         U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
4420                         STRLEN tmplen;
4421
4422                         to_utf8_fold(p, tmpbuf, &tmplen);
4423                         if (swash_fetch(sw, tmpbuf, do_utf8))
4424                             match = TRUE;
4425                     }
4426                 }
4427             }
4428         }
4429         if (match && lenp && *lenp == 0)
4430             *lenp = UNISKIP(NATIVE_TO_UNI(c));
4431     }
4432     if (!match && c < 256) {
4433         if (ANYOF_BITMAP_TEST(n, c))
4434             match = TRUE;
4435         else if (flags & ANYOF_FOLD) {
4436             U8 f;
4437
4438             if (flags & ANYOF_LOCALE) {
4439                 PL_reg_flags |= RF_tainted;
4440                 f = PL_fold_locale[c];
4441             }
4442             else
4443                 f = PL_fold[c];
4444             if (f != c && ANYOF_BITMAP_TEST(n, f))
4445                 match = TRUE;
4446         }
4447         
4448         if (!match && (flags & ANYOF_CLASS)) {
4449             PL_reg_flags |= RF_tainted;
4450             if (
4451                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
4452                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
4453                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
4454                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
4455                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
4456                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
4457                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
4458                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
4459                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
4460                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
4461                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
4462                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
4463                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
4464                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
4465                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
4466                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
4467                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
4468                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
4469                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
4470                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
4471                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
4472                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
4473                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
4474                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
4475                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
4476                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
4477                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
4478                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
4479                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
4480                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
4481                 ) /* How's that for a conditional? */
4482             {
4483                 match = TRUE;
4484             }
4485         }
4486     }
4487
4488     return (flags & ANYOF_INVERT) ? !match : match;
4489 }
4490
4491 STATIC U8 *
4492 S_reghop(pTHX_ U8 *s, I32 off)
4493 {
4494     return S_reghop3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
4495 }
4496
4497 STATIC U8 *
4498 S_reghop3(pTHX_ U8 *s, I32 off, U8* lim)
4499 {
4500     if (off >= 0) {
4501         while (off-- && s < lim) {
4502             /* XXX could check well-formedness here */
4503             s += UTF8SKIP(s);
4504         }
4505     }
4506     else {
4507         while (off++) {
4508             if (s > lim) {
4509                 s--;
4510                 if (UTF8_IS_CONTINUED(*s)) {
4511                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
4512                         s--;
4513                 }
4514                 /* XXX could check well-formedness here */
4515             }
4516         }
4517     }
4518     return s;
4519 }
4520
4521 STATIC U8 *
4522 S_reghopmaybe(pTHX_ U8 *s, I32 off)
4523 {
4524     return S_reghopmaybe3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
4525 }
4526
4527 STATIC U8 *
4528 S_reghopmaybe3(pTHX_ U8* s, I32 off, U8* lim)
4529 {
4530     if (off >= 0) {
4531         while (off-- && s < lim) {
4532             /* XXX could check well-formedness here */
4533             s += UTF8SKIP(s);
4534         }
4535         if (off >= 0)
4536             return 0;
4537     }
4538     else {
4539         while (off++) {
4540             if (s > lim) {
4541                 s--;
4542                 if (UTF8_IS_CONTINUED(*s)) {
4543                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
4544                         s--;
4545                 }
4546                 /* XXX could check well-formedness here */
4547             }
4548             else
4549                 break;
4550         }
4551         if (off <= 0)
4552             return 0;
4553     }
4554     return s;
4555 }
4556
4557 static void
4558 restore_pos(pTHX_ void *arg)
4559 {
4560     if (PL_reg_eval_set) {
4561         if (PL_reg_oldsaved) {
4562             PL_reg_re->subbeg = PL_reg_oldsaved;
4563             PL_reg_re->sublen = PL_reg_oldsavedlen;
4564             RX_MATCH_COPIED_on(PL_reg_re);
4565         }
4566         PL_reg_magic->mg_len = PL_reg_oldpos;
4567         PL_reg_eval_set = 0;
4568         PL_curpm = PL_reg_oldcurpm;
4569     }   
4570 }
4571
4572 STATIC void
4573 S_to_utf8_substr(pTHX_ register regexp *prog)
4574 {
4575     SV* sv;
4576     if (prog->float_substr && !prog->float_utf8) {
4577         prog->float_utf8 = sv = NEWSV(117, 0);
4578         SvSetSV(sv, prog->float_substr);
4579         sv_utf8_upgrade(sv);
4580         if (SvTAIL(prog->float_substr))
4581             SvTAIL_on(sv);
4582         if (prog->float_substr == prog->check_substr)
4583             prog->check_utf8 = sv;
4584     }
4585     if (prog->anchored_substr && !prog->anchored_utf8) {
4586         prog->anchored_utf8 = sv = NEWSV(118, 0);
4587         SvSetSV(sv, prog->anchored_substr);
4588         sv_utf8_upgrade(sv);
4589         if (SvTAIL(prog->anchored_substr))
4590             SvTAIL_on(sv);
4591         if (prog->anchored_substr == prog->check_substr)
4592             prog->check_utf8 = sv;
4593     }
4594 }
4595
4596 STATIC void
4597 S_to_byte_substr(pTHX_ register regexp *prog)
4598 {
4599     SV* sv;
4600     if (prog->float_utf8 && !prog->float_substr) {
4601         prog->float_substr = sv = NEWSV(117, 0);
4602         SvSetSV(sv, prog->float_utf8);
4603         if (sv_utf8_downgrade(sv, TRUE)) {
4604             if (SvTAIL(prog->float_utf8))
4605                 SvTAIL_on(sv);
4606         } else {
4607             SvREFCNT_dec(sv);
4608             prog->float_substr = sv = &PL_sv_undef;
4609         }
4610         if (prog->float_utf8 == prog->check_utf8)
4611             prog->check_substr = sv;
4612     }
4613     if (prog->anchored_utf8 && !prog->anchored_substr) {
4614         prog->anchored_substr = sv = NEWSV(118, 0);
4615         SvSetSV(sv, prog->anchored_utf8);
4616         if (sv_utf8_downgrade(sv, TRUE)) {
4617             if (SvTAIL(prog->anchored_utf8))
4618                 SvTAIL_on(sv);
4619         } else {
4620             SvREFCNT_dec(sv);
4621             prog->anchored_substr = sv = &PL_sv_undef;
4622         }
4623         if (prog->anchored_utf8 == prog->check_utf8)
4624             prog->check_substr = sv;
4625     }
4626 }