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