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