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