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