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