Typo fix, by John P. Linderman
[p5sagit/p5-mst-13.2.git] / regcomp.c
1 /*    regcomp.c
2  */
3
4 /*
5  * "A fair jaw-cracker dwarf-language must be."  --Samwise Gamgee
6  */
7
8 /* This file contains functions for compiling a regular expression.  See
9  * also regexec.c which funnily enough, contains functions for executing
10  * a regular expression.
11  *
12  * This file is also copied at build time to ext/re/re_comp.c, where
13  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
14  * This causes the main functions to be compiled under new names and with
15  * debugging support added, which makes "use re 'debug'" work.
16  */
17
18 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
19  * confused with the original package (see point 3 below).  Thanks, Henry!
20  */
21
22 /* Additional note: this code is very heavily munged from Henry's version
23  * in places.  In some spots I've traded clarity for efficiency, so don't
24  * blame Henry for some of the lack of readability.
25  */
26
27 /* The names of the functions have been changed from regcomp and
28  * regexec to  pregcomp and pregexec in order to avoid conflicts
29  * with the POSIX routines of the same names.
30 */
31
32 #ifdef PERL_EXT_RE_BUILD
33 #include "re_top.h"
34 #endif
35
36 /*
37  * pregcomp and pregexec -- regsub and regerror are not used in perl
38  *
39  *      Copyright (c) 1986 by University of Toronto.
40  *      Written by Henry Spencer.  Not derived from licensed software.
41  *
42  *      Permission is granted to anyone to use this software for any
43  *      purpose on any computer system, and to redistribute it freely,
44  *      subject to the following restrictions:
45  *
46  *      1. The author is not responsible for the consequences of use of
47  *              this software, no matter how awful, even if they arise
48  *              from defects in it.
49  *
50  *      2. The origin of this software must not be misrepresented, either
51  *              by explicit claim or by omission.
52  *
53  *      3. Altered versions must be plainly marked as such, and must not
54  *              be misrepresented as being the original software.
55  *
56  *
57  ****    Alterations to Henry's code are...
58  ****
59  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
60  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
61  ****
62  ****    You may distribute under the terms of either the GNU General Public
63  ****    License or the Artistic License, as specified in the README file.
64
65  *
66  * Beware that some of this code is subtly aware of the way operator
67  * precedence is structured in regular expressions.  Serious changes in
68  * regular-expression syntax might require a total rethink.
69  */
70 #include "EXTERN.h"
71 #define PERL_IN_REGCOMP_C
72 #include "perl.h"
73
74 #ifndef PERL_IN_XSUB_RE
75 #  include "INTERN.h"
76 #endif
77
78 #define REG_COMP_C
79 #ifdef PERL_IN_XSUB_RE
80 #  include "re_comp.h"
81 #else
82 #  include "regcomp.h"
83 #endif
84
85 #ifdef op
86 #undef op
87 #endif /* op */
88
89 #ifdef MSDOS
90 #  if defined(BUGGY_MSC6)
91  /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
92 #    pragma optimize("a",off)
93  /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
94 #    pragma optimize("w",on )
95 #  endif /* BUGGY_MSC6 */
96 #endif /* MSDOS */
97
98 #ifndef STATIC
99 #define STATIC  static
100 #endif
101
102 typedef struct RExC_state_t {
103     U32         flags;                  /* are we folding, multilining? */
104     char        *precomp;               /* uncompiled string. */
105     regexp      *rx;                    /* perl core regexp structure */
106     regexp_internal     *rxi;           /* internal data for regexp object pprivate field */        
107     char        *start;                 /* Start of input for compile */
108     char        *end;                   /* End of input for compile */
109     char        *parse;                 /* Input-scan pointer. */
110     I32         whilem_seen;            /* number of WHILEM in this expr */
111     regnode     *emit_start;            /* Start of emitted-code area */
112     regnode     *emit;                  /* Code-emit pointer; &regdummy = don't = compiling */
113     I32         naughty;                /* How bad is this pattern? */
114     I32         sawback;                /* Did we see \1, ...? */
115     U32         seen;
116     I32         size;                   /* Code size. */
117     I32         npar;                   /* Capture buffer count, (OPEN). */
118     I32         cpar;                   /* Capture buffer count, (CLOSE). */
119     I32         nestroot;               /* root parens we are in - used by accept */
120     I32         extralen;
121     I32         seen_zerolen;
122     I32         seen_evals;
123     regnode     **open_parens;          /* pointers to open parens */
124     regnode     **close_parens;         /* pointers to close parens */
125     regnode     *opend;                 /* END node in program */
126     I32         utf8;
127     HV          *charnames;             /* cache of named sequences */
128     HV          *paren_names;           /* Paren names */
129     
130     regnode     **recurse;              /* Recurse regops */
131     I32         recurse_count;          /* Number of recurse regops */
132 #if ADD_TO_REGEXEC
133     char        *starttry;              /* -Dr: where regtry was called. */
134 #define RExC_starttry   (pRExC_state->starttry)
135 #endif
136 #ifdef DEBUGGING
137     const char  *lastparse;
138     I32         lastnum;
139     AV          *paren_name_list;       /* idx -> name */
140 #define RExC_lastparse  (pRExC_state->lastparse)
141 #define RExC_lastnum    (pRExC_state->lastnum)
142 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
143 #endif
144 } RExC_state_t;
145
146 #define RExC_flags      (pRExC_state->flags)
147 #define RExC_precomp    (pRExC_state->precomp)
148 #define RExC_rx         (pRExC_state->rx)
149 #define RExC_rxi        (pRExC_state->rxi)
150 #define RExC_start      (pRExC_state->start)
151 #define RExC_end        (pRExC_state->end)
152 #define RExC_parse      (pRExC_state->parse)
153 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
154 #ifdef RE_TRACK_PATTERN_OFFSETS
155 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the others */
156 #endif
157 #define RExC_emit       (pRExC_state->emit)
158 #define RExC_emit_start (pRExC_state->emit_start)
159 #define RExC_naughty    (pRExC_state->naughty)
160 #define RExC_sawback    (pRExC_state->sawback)
161 #define RExC_seen       (pRExC_state->seen)
162 #define RExC_size       (pRExC_state->size)
163 #define RExC_npar       (pRExC_state->npar)
164 #define RExC_nestroot   (pRExC_state->nestroot)
165 #define RExC_extralen   (pRExC_state->extralen)
166 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
167 #define RExC_seen_evals (pRExC_state->seen_evals)
168 #define RExC_utf8       (pRExC_state->utf8)
169 #define RExC_charnames  (pRExC_state->charnames)
170 #define RExC_open_parens        (pRExC_state->open_parens)
171 #define RExC_close_parens       (pRExC_state->close_parens)
172 #define RExC_opend      (pRExC_state->opend)
173 #define RExC_paren_names        (pRExC_state->paren_names)
174 #define RExC_recurse    (pRExC_state->recurse)
175 #define RExC_recurse_count      (pRExC_state->recurse_count)
176
177
178 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
179 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
180         ((*s) == '{' && regcurly(s)))
181
182 #ifdef SPSTART
183 #undef SPSTART          /* dratted cpp namespace... */
184 #endif
185 /*
186  * Flags to be passed up and down.
187  */
188 #define WORST           0       /* Worst case. */
189 #define HASWIDTH        0x1     /* Known to match non-null strings. */
190 #define SIMPLE          0x2     /* Simple enough to be STAR/PLUS operand. */
191 #define SPSTART         0x4     /* Starts with * or +. */
192 #define TRYAGAIN        0x8     /* Weeded out a declaration. */
193
194 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
195
196 /* whether trie related optimizations are enabled */
197 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
198 #define TRIE_STUDY_OPT
199 #define FULL_TRIE_STUDY
200 #define TRIE_STCLASS
201 #endif
202
203
204
205 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
206 #define PBITVAL(paren) (1 << ((paren) & 7))
207 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
208 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
209 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
210
211
212 /* About scan_data_t.
213
214   During optimisation we recurse through the regexp program performing
215   various inplace (keyhole style) optimisations. In addition study_chunk
216   and scan_commit populate this data structure with information about
217   what strings MUST appear in the pattern. We look for the longest 
218   string that must appear for at a fixed location, and we look for the
219   longest string that may appear at a floating location. So for instance
220   in the pattern:
221   
222     /FOO[xX]A.*B[xX]BAR/
223     
224   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
225   strings (because they follow a .* construct). study_chunk will identify
226   both FOO and BAR as being the longest fixed and floating strings respectively.
227   
228   The strings can be composites, for instance
229   
230      /(f)(o)(o)/
231      
232   will result in a composite fixed substring 'foo'.
233   
234   For each string some basic information is maintained:
235   
236   - offset or min_offset
237     This is the position the string must appear at, or not before.
238     It also implicitly (when combined with minlenp) tells us how many
239     character must match before the string we are searching.
240     Likewise when combined with minlenp and the length of the string
241     tells us how many characters must appear after the string we have 
242     found.
243   
244   - max_offset
245     Only used for floating strings. This is the rightmost point that
246     the string can appear at. Ifset to I32 max it indicates that the
247     string can occur infinitely far to the right.
248   
249   - minlenp
250     A pointer to the minimum length of the pattern that the string 
251     was found inside. This is important as in the case of positive 
252     lookahead or positive lookbehind we can have multiple patterns 
253     involved. Consider
254     
255     /(?=FOO).*F/
256     
257     The minimum length of the pattern overall is 3, the minimum length
258     of the lookahead part is 3, but the minimum length of the part that
259     will actually match is 1. So 'FOO's minimum length is 3, but the 
260     minimum length for the F is 1. This is important as the minimum length
261     is used to determine offsets in front of and behind the string being 
262     looked for.  Since strings can be composites this is the length of the
263     pattern at the time it was commited with a scan_commit. Note that
264     the length is calculated by study_chunk, so that the minimum lengths
265     are not known until the full pattern has been compiled, thus the 
266     pointer to the value.
267   
268   - lookbehind
269   
270     In the case of lookbehind the string being searched for can be
271     offset past the start point of the final matching string. 
272     If this value was just blithely removed from the min_offset it would
273     invalidate some of the calculations for how many chars must match
274     before or after (as they are derived from min_offset and minlen and
275     the length of the string being searched for). 
276     When the final pattern is compiled and the data is moved from the
277     scan_data_t structure into the regexp structure the information
278     about lookbehind is factored in, with the information that would 
279     have been lost precalculated in the end_shift field for the 
280     associated string.
281
282   The fields pos_min and pos_delta are used to store the minimum offset
283   and the delta to the maximum offset at the current point in the pattern.    
284
285 */
286
287 typedef struct scan_data_t {
288     /*I32 len_min;      unused */
289     /*I32 len_delta;    unused */
290     I32 pos_min;
291     I32 pos_delta;
292     SV *last_found;
293     I32 last_end;           /* min value, <0 unless valid. */
294     I32 last_start_min;
295     I32 last_start_max;
296     SV **longest;           /* Either &l_fixed, or &l_float. */
297     SV *longest_fixed;      /* longest fixed string found in pattern */
298     I32 offset_fixed;       /* offset where it starts */
299     I32 *minlen_fixed;      /* pointer to the minlen relevent to the string */
300     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
301     SV *longest_float;      /* longest floating string found in pattern */
302     I32 offset_float_min;   /* earliest point in string it can appear */
303     I32 offset_float_max;   /* latest point in string it can appear */
304     I32 *minlen_float;      /* pointer to the minlen relevent to the string */
305     I32 lookbehind_float;   /* is the position of the string modified by LB */
306     I32 flags;
307     I32 whilem_c;
308     I32 *last_closep;
309     struct regnode_charclass_class *start_class;
310 } scan_data_t;
311
312 /*
313  * Forward declarations for pregcomp()'s friends.
314  */
315
316 static const scan_data_t zero_scan_data =
317   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
318
319 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
320 #define SF_BEFORE_SEOL          0x0001
321 #define SF_BEFORE_MEOL          0x0002
322 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
323 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
324
325 #ifdef NO_UNARY_PLUS
326 #  define SF_FIX_SHIFT_EOL      (0+2)
327 #  define SF_FL_SHIFT_EOL               (0+4)
328 #else
329 #  define SF_FIX_SHIFT_EOL      (+2)
330 #  define SF_FL_SHIFT_EOL               (+4)
331 #endif
332
333 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
334 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
335
336 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
337 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
338 #define SF_IS_INF               0x0040
339 #define SF_HAS_PAR              0x0080
340 #define SF_IN_PAR               0x0100
341 #define SF_HAS_EVAL             0x0200
342 #define SCF_DO_SUBSTR           0x0400
343 #define SCF_DO_STCLASS_AND      0x0800
344 #define SCF_DO_STCLASS_OR       0x1000
345 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
346 #define SCF_WHILEM_VISITED_POS  0x2000
347
348 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
349 #define SCF_SEEN_ACCEPT         0x8000 
350
351 #define UTF (RExC_utf8 != 0)
352 #define LOC ((RExC_flags & RXf_PMf_LOCALE) != 0)
353 #define FOLD ((RExC_flags & RXf_PMf_FOLD) != 0)
354
355 #define OOB_UNICODE             12345678
356 #define OOB_NAMEDCLASS          -1
357
358 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
359 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
360
361
362 /* length of regex to show in messages that don't mark a position within */
363 #define RegexLengthToShowInErrorMessages 127
364
365 /*
366  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
367  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
368  * op/pragma/warn/regcomp.
369  */
370 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
371 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
372
373 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
374
375 /*
376  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
377  * arg. Show regex, up to a maximum length. If it's too long, chop and add
378  * "...".
379  */
380 #define _FAIL(code) STMT_START {                                        \
381     const char *ellipses = "";                                          \
382     IV len = RExC_end - RExC_precomp;                                   \
383                                                                         \
384     if (!SIZE_ONLY)                                                     \
385         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);                      \
386     if (len > RegexLengthToShowInErrorMessages) {                       \
387         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
388         len = RegexLengthToShowInErrorMessages - 10;                    \
389         ellipses = "...";                                               \
390     }                                                                   \
391     code;                                                               \
392 } STMT_END
393
394 #define FAIL(msg) _FAIL(                            \
395     Perl_croak(aTHX_ "%s in regex m/%.*s%s/",       \
396             msg, (int)len, RExC_precomp, ellipses))
397
398 #define FAIL2(msg,arg) _FAIL(                       \
399     Perl_croak(aTHX_ msg " in regex m/%.*s%s/",     \
400             arg, (int)len, RExC_precomp, ellipses))
401
402 /*
403  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
404  */
405 #define Simple_vFAIL(m) STMT_START {                                    \
406     const IV offset = RExC_parse - RExC_precomp;                        \
407     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
408             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
409 } STMT_END
410
411 /*
412  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
413  */
414 #define vFAIL(m) STMT_START {                           \
415     if (!SIZE_ONLY)                                     \
416         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);      \
417     Simple_vFAIL(m);                                    \
418 } STMT_END
419
420 /*
421  * Like Simple_vFAIL(), but accepts two arguments.
422  */
423 #define Simple_vFAIL2(m,a1) STMT_START {                        \
424     const IV offset = RExC_parse - RExC_precomp;                        \
425     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,                   \
426             (int)offset, RExC_precomp, RExC_precomp + offset);  \
427 } STMT_END
428
429 /*
430  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
431  */
432 #define vFAIL2(m,a1) STMT_START {                       \
433     if (!SIZE_ONLY)                                     \
434         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);      \
435     Simple_vFAIL2(m, a1);                               \
436 } STMT_END
437
438
439 /*
440  * Like Simple_vFAIL(), but accepts three arguments.
441  */
442 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
443     const IV offset = RExC_parse - RExC_precomp;                \
444     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,               \
445             (int)offset, RExC_precomp, RExC_precomp + offset);  \
446 } STMT_END
447
448 /*
449  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
450  */
451 #define vFAIL3(m,a1,a2) STMT_START {                    \
452     if (!SIZE_ONLY)                                     \
453         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);      \
454     Simple_vFAIL3(m, a1, a2);                           \
455 } STMT_END
456
457 /*
458  * Like Simple_vFAIL(), but accepts four arguments.
459  */
460 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
461     const IV offset = RExC_parse - RExC_precomp;                \
462     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,           \
463             (int)offset, RExC_precomp, RExC_precomp + offset);  \
464 } STMT_END
465
466 #define vWARN(loc,m) STMT_START {                                       \
467     const IV offset = loc - RExC_precomp;                               \
468     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION,      \
469             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
470 } STMT_END
471
472 #define vWARNdep(loc,m) STMT_START {                                    \
473     const IV offset = loc - RExC_precomp;                               \
474     Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),          \
475             "%s" REPORT_LOCATION,                                       \
476             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
477 } STMT_END
478
479
480 #define vWARN2(loc, m, a1) STMT_START {                                 \
481     const IV offset = loc - RExC_precomp;                               \
482     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
483             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
484 } STMT_END
485
486 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
487     const IV offset = loc - RExC_precomp;                               \
488     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
489             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
490 } STMT_END
491
492 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
493     const IV offset = loc - RExC_precomp;                               \
494     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
495             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
496 } STMT_END
497
498 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
499     const IV offset = loc - RExC_precomp;                               \
500     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
501             a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
502 } STMT_END
503
504
505 /* Allow for side effects in s */
506 #define REGC(c,s) STMT_START {                  \
507     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
508 } STMT_END
509
510 /* Macros for recording node offsets.   20001227 mjd@plover.com 
511  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
512  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
513  * Element 0 holds the number n.
514  * Position is 1 indexed.
515  */
516 #ifndef RE_TRACK_PATTERN_OFFSETS
517 #define Set_Node_Offset_To_R(node,byte)
518 #define Set_Node_Offset(node,byte)
519 #define Set_Cur_Node_Offset
520 #define Set_Node_Length_To_R(node,len)
521 #define Set_Node_Length(node,len)
522 #define Set_Node_Cur_Length(node)
523 #define Node_Offset(n) 
524 #define Node_Length(n) 
525 #define Set_Node_Offset_Length(node,offset,len)
526 #define ProgLen(ri) ri->u.proglen
527 #define SetProgLen(ri,x) ri->u.proglen = x
528 #else
529 #define ProgLen(ri) ri->u.offsets[0]
530 #define SetProgLen(ri,x) ri->u.offsets[0] = x
531 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
532     if (! SIZE_ONLY) {                                                  \
533         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
534                     __LINE__, (int)(node), (int)(byte)));               \
535         if((node) < 0) {                                                \
536             Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
537         } else {                                                        \
538             RExC_offsets[2*(node)-1] = (byte);                          \
539         }                                                               \
540     }                                                                   \
541 } STMT_END
542
543 #define Set_Node_Offset(node,byte) \
544     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
545 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
546
547 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
548     if (! SIZE_ONLY) {                                                  \
549         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
550                 __LINE__, (int)(node), (int)(len)));                    \
551         if((node) < 0) {                                                \
552             Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
553         } else {                                                        \
554             RExC_offsets[2*(node)] = (len);                             \
555         }                                                               \
556     }                                                                   \
557 } STMT_END
558
559 #define Set_Node_Length(node,len) \
560     Set_Node_Length_To_R((node)-RExC_emit_start, len)
561 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
562 #define Set_Node_Cur_Length(node) \
563     Set_Node_Length(node, RExC_parse - parse_start)
564
565 /* Get offsets and lengths */
566 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
567 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
568
569 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
570     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
571     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
572 } STMT_END
573 #endif
574
575 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
576 #define EXPERIMENTAL_INPLACESCAN
577 #endif /*RE_TRACK_PATTERN_OFFSETS*/
578
579 #define DEBUG_STUDYDATA(str,data,depth)                              \
580 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
581     PerlIO_printf(Perl_debug_log,                                    \
582         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
583         " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s",       \
584         (int)(depth)*2, "",                                          \
585         (IV)((data)->pos_min),                                       \
586         (IV)((data)->pos_delta),                                     \
587         (UV)((data)->flags),                                         \
588         (IV)((data)->whilem_c),                                      \
589         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
590         is_inf ? "INF " : ""                                         \
591     );                                                               \
592     if ((data)->last_found)                                          \
593         PerlIO_printf(Perl_debug_log,                                \
594             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
595             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
596             SvPVX_const((data)->last_found),                         \
597             (IV)((data)->last_end),                                  \
598             (IV)((data)->last_start_min),                            \
599             (IV)((data)->last_start_max),                            \
600             ((data)->longest &&                                      \
601              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
602             SvPVX_const((data)->longest_fixed),                      \
603             (IV)((data)->offset_fixed),                              \
604             ((data)->longest &&                                      \
605              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
606             SvPVX_const((data)->longest_float),                      \
607             (IV)((data)->offset_float_min),                          \
608             (IV)((data)->offset_float_max)                           \
609         );                                                           \
610     PerlIO_printf(Perl_debug_log,"\n");                              \
611 });
612
613 static void clear_re(pTHX_ void *r);
614
615 /* Mark that we cannot extend a found fixed substring at this point.
616    Update the longest found anchored substring and the longest found
617    floating substrings if needed. */
618
619 STATIC void
620 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
621 {
622     const STRLEN l = CHR_SVLEN(data->last_found);
623     const STRLEN old_l = CHR_SVLEN(*data->longest);
624     GET_RE_DEBUG_FLAGS_DECL;
625
626     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
627         SvSetMagicSV(*data->longest, data->last_found);
628         if (*data->longest == data->longest_fixed) {
629             data->offset_fixed = l ? data->last_start_min : data->pos_min;
630             if (data->flags & SF_BEFORE_EOL)
631                 data->flags
632                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
633             else
634                 data->flags &= ~SF_FIX_BEFORE_EOL;
635             data->minlen_fixed=minlenp; 
636             data->lookbehind_fixed=0;
637         }
638         else { /* *data->longest == data->longest_float */
639             data->offset_float_min = l ? data->last_start_min : data->pos_min;
640             data->offset_float_max = (l
641                                       ? data->last_start_max
642                                       : data->pos_min + data->pos_delta);
643             if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
644                 data->offset_float_max = I32_MAX;
645             if (data->flags & SF_BEFORE_EOL)
646                 data->flags
647                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
648             else
649                 data->flags &= ~SF_FL_BEFORE_EOL;
650             data->minlen_float=minlenp;
651             data->lookbehind_float=0;
652         }
653     }
654     SvCUR_set(data->last_found, 0);
655     {
656         SV * const sv = data->last_found;
657         if (SvUTF8(sv) && SvMAGICAL(sv)) {
658             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
659             if (mg)
660                 mg->mg_len = 0;
661         }
662     }
663     data->last_end = -1;
664     data->flags &= ~SF_BEFORE_EOL;
665     DEBUG_STUDYDATA("commit: ",data,0);
666 }
667
668 /* Can match anything (initialization) */
669 STATIC void
670 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
671 {
672     ANYOF_CLASS_ZERO(cl);
673     ANYOF_BITMAP_SETALL(cl);
674     cl->flags = ANYOF_EOS|ANYOF_UNICODE_ALL;
675     if (LOC)
676         cl->flags |= ANYOF_LOCALE;
677 }
678
679 /* Can match anything (initialization) */
680 STATIC int
681 S_cl_is_anything(const struct regnode_charclass_class *cl)
682 {
683     int value;
684
685     for (value = 0; value <= ANYOF_MAX; value += 2)
686         if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
687             return 1;
688     if (!(cl->flags & ANYOF_UNICODE_ALL))
689         return 0;
690     if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
691         return 0;
692     return 1;
693 }
694
695 /* Can match anything (initialization) */
696 STATIC void
697 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
698 {
699     Zero(cl, 1, struct regnode_charclass_class);
700     cl->type = ANYOF;
701     cl_anything(pRExC_state, cl);
702 }
703
704 STATIC void
705 S_cl_init_zero(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
706 {
707     Zero(cl, 1, struct regnode_charclass_class);
708     cl->type = ANYOF;
709     cl_anything(pRExC_state, cl);
710     if (LOC)
711         cl->flags |= ANYOF_LOCALE;
712 }
713
714 /* 'And' a given class with another one.  Can create false positives */
715 /* We assume that cl is not inverted */
716 STATIC void
717 S_cl_and(struct regnode_charclass_class *cl,
718         const struct regnode_charclass_class *and_with)
719 {
720
721     assert(and_with->type == ANYOF);
722     if (!(and_with->flags & ANYOF_CLASS)
723         && !(cl->flags & ANYOF_CLASS)
724         && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
725         && !(and_with->flags & ANYOF_FOLD)
726         && !(cl->flags & ANYOF_FOLD)) {
727         int i;
728
729         if (and_with->flags & ANYOF_INVERT)
730             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
731                 cl->bitmap[i] &= ~and_with->bitmap[i];
732         else
733             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
734                 cl->bitmap[i] &= and_with->bitmap[i];
735     } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
736     if (!(and_with->flags & ANYOF_EOS))
737         cl->flags &= ~ANYOF_EOS;
738
739     if (cl->flags & ANYOF_UNICODE_ALL && and_with->flags & ANYOF_UNICODE &&
740         !(and_with->flags & ANYOF_INVERT)) {
741         cl->flags &= ~ANYOF_UNICODE_ALL;
742         cl->flags |= ANYOF_UNICODE;
743         ARG_SET(cl, ARG(and_with));
744     }
745     if (!(and_with->flags & ANYOF_UNICODE_ALL) &&
746         !(and_with->flags & ANYOF_INVERT))
747         cl->flags &= ~ANYOF_UNICODE_ALL;
748     if (!(and_with->flags & (ANYOF_UNICODE|ANYOF_UNICODE_ALL)) &&
749         !(and_with->flags & ANYOF_INVERT))
750         cl->flags &= ~ANYOF_UNICODE;
751 }
752
753 /* 'OR' a given class with another one.  Can create false positives */
754 /* We assume that cl is not inverted */
755 STATIC void
756 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
757 {
758     if (or_with->flags & ANYOF_INVERT) {
759         /* We do not use
760          * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
761          *   <= (B1 | !B2) | (CL1 | !CL2)
762          * which is wasteful if CL2 is small, but we ignore CL2:
763          *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
764          * XXXX Can we handle case-fold?  Unclear:
765          *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
766          *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
767          */
768         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
769              && !(or_with->flags & ANYOF_FOLD)
770              && !(cl->flags & ANYOF_FOLD) ) {
771             int i;
772
773             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
774                 cl->bitmap[i] |= ~or_with->bitmap[i];
775         } /* XXXX: logic is complicated otherwise */
776         else {
777             cl_anything(pRExC_state, cl);
778         }
779     } else {
780         /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
781         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
782              && (!(or_with->flags & ANYOF_FOLD)
783                  || (cl->flags & ANYOF_FOLD)) ) {
784             int i;
785
786             /* OR char bitmap and class bitmap separately */
787             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
788                 cl->bitmap[i] |= or_with->bitmap[i];
789             if (or_with->flags & ANYOF_CLASS) {
790                 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
791                     cl->classflags[i] |= or_with->classflags[i];
792                 cl->flags |= ANYOF_CLASS;
793             }
794         }
795         else { /* XXXX: logic is complicated, leave it along for a moment. */
796             cl_anything(pRExC_state, cl);
797         }
798     }
799     if (or_with->flags & ANYOF_EOS)
800         cl->flags |= ANYOF_EOS;
801
802     if (cl->flags & ANYOF_UNICODE && or_with->flags & ANYOF_UNICODE &&
803         ARG(cl) != ARG(or_with)) {
804         cl->flags |= ANYOF_UNICODE_ALL;
805         cl->flags &= ~ANYOF_UNICODE;
806     }
807     if (or_with->flags & ANYOF_UNICODE_ALL) {
808         cl->flags |= ANYOF_UNICODE_ALL;
809         cl->flags &= ~ANYOF_UNICODE;
810     }
811 }
812
813 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
814 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
815 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
816 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
817
818
819 #ifdef DEBUGGING
820 /*
821    dump_trie(trie,widecharmap,revcharmap)
822    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
823    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
824
825    These routines dump out a trie in a somewhat readable format.
826    The _interim_ variants are used for debugging the interim
827    tables that are used to generate the final compressed
828    representation which is what dump_trie expects.
829
830    Part of the reason for their existance is to provide a form
831    of documentation as to how the different representations function.
832
833 */
834
835 /*
836   Dumps the final compressed table form of the trie to Perl_debug_log.
837   Used for debugging make_trie().
838 */
839  
840 STATIC void
841 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
842             AV *revcharmap, U32 depth)
843 {
844     U32 state;
845     SV *sv=sv_newmortal();
846     int colwidth= widecharmap ? 6 : 4;
847     GET_RE_DEBUG_FLAGS_DECL;
848
849
850     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
851         (int)depth * 2 + 2,"",
852         "Match","Base","Ofs" );
853
854     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
855         SV ** const tmp = av_fetch( revcharmap, state, 0);
856         if ( tmp ) {
857             PerlIO_printf( Perl_debug_log, "%*s", 
858                 colwidth,
859                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
860                             PL_colors[0], PL_colors[1],
861                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
862                             PERL_PV_ESCAPE_FIRSTCHAR 
863                 ) 
864             );
865         }
866     }
867     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
868         (int)depth * 2 + 2,"");
869
870     for( state = 0 ; state < trie->uniquecharcount ; state++ )
871         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
872     PerlIO_printf( Perl_debug_log, "\n");
873
874     for( state = 1 ; state < trie->statecount ; state++ ) {
875         const U32 base = trie->states[ state ].trans.base;
876
877         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
878
879         if ( trie->states[ state ].wordnum ) {
880             PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
881         } else {
882             PerlIO_printf( Perl_debug_log, "%6s", "" );
883         }
884
885         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
886
887         if ( base ) {
888             U32 ofs = 0;
889
890             while( ( base + ofs  < trie->uniquecharcount ) ||
891                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
892                      && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
893                     ofs++;
894
895             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
896
897             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
898                 if ( ( base + ofs >= trie->uniquecharcount ) &&
899                      ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
900                      trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
901                 {
902                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
903                     colwidth,
904                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
905                 } else {
906                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
907                 }
908             }
909
910             PerlIO_printf( Perl_debug_log, "]");
911
912         }
913         PerlIO_printf( Perl_debug_log, "\n" );
914     }
915 }    
916 /*
917   Dumps a fully constructed but uncompressed trie in list form.
918   List tries normally only are used for construction when the number of 
919   possible chars (trie->uniquecharcount) is very high.
920   Used for debugging make_trie().
921 */
922 STATIC void
923 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
924                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
925                          U32 depth)
926 {
927     U32 state;
928     SV *sv=sv_newmortal();
929     int colwidth= widecharmap ? 6 : 4;
930     GET_RE_DEBUG_FLAGS_DECL;
931     /* print out the table precompression.  */
932     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
933         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
934         "------:-----+-----------------\n" );
935     
936     for( state=1 ; state < next_alloc ; state ++ ) {
937         U16 charid;
938     
939         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
940             (int)depth * 2 + 2,"", (UV)state  );
941         if ( ! trie->states[ state ].wordnum ) {
942             PerlIO_printf( Perl_debug_log, "%5s| ","");
943         } else {
944             PerlIO_printf( Perl_debug_log, "W%4x| ",
945                 trie->states[ state ].wordnum
946             );
947         }
948         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
949             SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
950             if ( tmp ) {
951                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
952                     colwidth,
953                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
954                             PL_colors[0], PL_colors[1],
955                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
956                             PERL_PV_ESCAPE_FIRSTCHAR 
957                     ) ,
958                     TRIE_LIST_ITEM(state,charid).forid,
959                     (UV)TRIE_LIST_ITEM(state,charid).newstate
960                 );
961                 if (!(charid % 10)) 
962                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
963                         (int)((depth * 2) + 14), "");
964             }
965         }
966         PerlIO_printf( Perl_debug_log, "\n");
967     }
968 }    
969
970 /*
971   Dumps a fully constructed but uncompressed trie in table form.
972   This is the normal DFA style state transition table, with a few 
973   twists to facilitate compression later. 
974   Used for debugging make_trie().
975 */
976 STATIC void
977 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
978                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
979                           U32 depth)
980 {
981     U32 state;
982     U16 charid;
983     SV *sv=sv_newmortal();
984     int colwidth= widecharmap ? 6 : 4;
985     GET_RE_DEBUG_FLAGS_DECL;
986     
987     /*
988        print out the table precompression so that we can do a visual check
989        that they are identical.
990      */
991     
992     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
993
994     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
995         SV ** const tmp = av_fetch( revcharmap, charid, 0);
996         if ( tmp ) {
997             PerlIO_printf( Perl_debug_log, "%*s", 
998                 colwidth,
999                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1000                             PL_colors[0], PL_colors[1],
1001                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1002                             PERL_PV_ESCAPE_FIRSTCHAR 
1003                 ) 
1004             );
1005         }
1006     }
1007
1008     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1009
1010     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1011         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1012     }
1013
1014     PerlIO_printf( Perl_debug_log, "\n" );
1015
1016     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1017
1018         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ", 
1019             (int)depth * 2 + 2,"",
1020             (UV)TRIE_NODENUM( state ) );
1021
1022         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1023             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1024             if (v)
1025                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1026             else
1027                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1028         }
1029         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1030             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1031         } else {
1032             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1033             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1034         }
1035     }
1036 }
1037
1038 #endif
1039
1040 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1041   startbranch: the first branch in the whole branch sequence
1042   first      : start branch of sequence of branch-exact nodes.
1043                May be the same as startbranch
1044   last       : Thing following the last branch.
1045                May be the same as tail.
1046   tail       : item following the branch sequence
1047   count      : words in the sequence
1048   flags      : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1049   depth      : indent depth
1050
1051 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1052
1053 A trie is an N'ary tree where the branches are determined by digital
1054 decomposition of the key. IE, at the root node you look up the 1st character and
1055 follow that branch repeat until you find the end of the branches. Nodes can be
1056 marked as "accepting" meaning they represent a complete word. Eg:
1057
1058   /he|she|his|hers/
1059
1060 would convert into the following structure. Numbers represent states, letters
1061 following numbers represent valid transitions on the letter from that state, if
1062 the number is in square brackets it represents an accepting state, otherwise it
1063 will be in parenthesis.
1064
1065       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1066       |    |
1067       |   (2)
1068       |    |
1069      (1)   +-i->(6)-+-s->[7]
1070       |
1071       +-s->(3)-+-h->(4)-+-e->[5]
1072
1073       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1074
1075 This shows that when matching against the string 'hers' we will begin at state 1
1076 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1077 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1078 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1079 single traverse. We store a mapping from accepting to state to which word was
1080 matched, and then when we have multiple possibilities we try to complete the
1081 rest of the regex in the order in which they occured in the alternation.
1082
1083 The only prior NFA like behaviour that would be changed by the TRIE support is
1084 the silent ignoring of duplicate alternations which are of the form:
1085
1086  / (DUPE|DUPE) X? (?{ ... }) Y /x
1087
1088 Thus EVAL blocks follwing a trie may be called a different number of times with
1089 and without the optimisation. With the optimisations dupes will be silently
1090 ignored. This inconsistant behaviour of EVAL type nodes is well established as
1091 the following demonstrates:
1092
1093  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1094
1095 which prints out 'word' three times, but
1096
1097  'words'=~/(word|word|word)(?{ print $1 })S/
1098
1099 which doesnt print it out at all. This is due to other optimisations kicking in.
1100
1101 Example of what happens on a structural level:
1102
1103 The regexp /(ac|ad|ab)+/ will produce the folowing debug output:
1104
1105    1: CURLYM[1] {1,32767}(18)
1106    5:   BRANCH(8)
1107    6:     EXACT <ac>(16)
1108    8:   BRANCH(11)
1109    9:     EXACT <ad>(16)
1110   11:   BRANCH(14)
1111   12:     EXACT <ab>(16)
1112   16:   SUCCEED(0)
1113   17:   NOTHING(18)
1114   18: END(0)
1115
1116 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1117 and should turn into:
1118
1119    1: CURLYM[1] {1,32767}(18)
1120    5:   TRIE(16)
1121         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1122           <ac>
1123           <ad>
1124           <ab>
1125   16:   SUCCEED(0)
1126   17:   NOTHING(18)
1127   18: END(0)
1128
1129 Cases where tail != last would be like /(?foo|bar)baz/:
1130
1131    1: BRANCH(4)
1132    2:   EXACT <foo>(8)
1133    4: BRANCH(7)
1134    5:   EXACT <bar>(8)
1135    7: TAIL(8)
1136    8: EXACT <baz>(10)
1137   10: END(0)
1138
1139 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1140 and would end up looking like:
1141
1142     1: TRIE(8)
1143       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1144         <foo>
1145         <bar>
1146    7: TAIL(8)
1147    8: EXACT <baz>(10)
1148   10: END(0)
1149
1150     d = uvuni_to_utf8_flags(d, uv, 0);
1151
1152 is the recommended Unicode-aware way of saying
1153
1154     *(d++) = uv;
1155 */
1156
1157 #define TRIE_STORE_REVCHAR                                                 \
1158     STMT_START {                                                           \
1159         SV *tmp = newSVpvs("");                                            \
1160         if (UTF) SvUTF8_on(tmp);                                           \
1161         Perl_sv_catpvf( aTHX_ tmp, "%c", (int)uvc );                       \
1162         av_push( revcharmap, tmp );                                        \
1163     } STMT_END
1164
1165 #define TRIE_READ_CHAR STMT_START {                                           \
1166     wordlen++;                                                                \
1167     if ( UTF ) {                                                              \
1168         if ( folder ) {                                                       \
1169             if ( foldlen > 0 ) {                                              \
1170                uvc = utf8n_to_uvuni( scan, UTF8_MAXLEN, &len, uniflags );     \
1171                foldlen -= len;                                                \
1172                scan += len;                                                   \
1173                len = 0;                                                       \
1174             } else {                                                          \
1175                 uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1176                 uvc = to_uni_fold( uvc, foldbuf, &foldlen );                  \
1177                 foldlen -= UNISKIP( uvc );                                    \
1178                 scan = foldbuf + UNISKIP( uvc );                              \
1179             }                                                                 \
1180         } else {                                                              \
1181             uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1182         }                                                                     \
1183     } else {                                                                  \
1184         uvc = (U32)*uc;                                                       \
1185         len = 1;                                                              \
1186     }                                                                         \
1187 } STMT_END
1188
1189
1190
1191 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1192     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1193         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1194         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1195     }                                                           \
1196     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1197     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1198     TRIE_LIST_CUR( state )++;                                   \
1199 } STMT_END
1200
1201 #define TRIE_LIST_NEW(state) STMT_START {                       \
1202     Newxz( trie->states[ state ].trans.list,               \
1203         4, reg_trie_trans_le );                                 \
1204      TRIE_LIST_CUR( state ) = 1;                                \
1205      TRIE_LIST_LEN( state ) = 4;                                \
1206 } STMT_END
1207
1208 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1209     U16 dupe= trie->states[ state ].wordnum;                    \
1210     regnode * const noper_next = regnext( noper );              \
1211                                                                 \
1212     if (trie->wordlen)                                          \
1213         trie->wordlen[ curword ] = wordlen;                     \
1214     DEBUG_r({                                                   \
1215         /* store the word for dumping */                        \
1216         SV* tmp;                                                \
1217         if (OP(noper) != NOTHING)                               \
1218             tmp = newSVpvn(STRING(noper), STR_LEN(noper));      \
1219         else                                                    \
1220             tmp = newSVpvn( "", 0 );                            \
1221         if ( UTF ) SvUTF8_on( tmp );                            \
1222         av_push( trie_words, tmp );                             \
1223     });                                                         \
1224                                                                 \
1225     curword++;                                                  \
1226                                                                 \
1227     if ( noper_next < tail ) {                                  \
1228         if (!trie->jump)                                        \
1229             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1230         trie->jump[curword] = (U16)(noper_next - convert);      \
1231         if (!jumper)                                            \
1232             jumper = noper_next;                                \
1233         if (!nextbranch)                                        \
1234             nextbranch= regnext(cur);                           \
1235     }                                                           \
1236                                                                 \
1237     if ( dupe ) {                                               \
1238         /* So it's a dupe. This means we need to maintain a   */\
1239         /* linked-list from the first to the next.            */\
1240         /* we only allocate the nextword buffer when there    */\
1241         /* a dupe, so first time we have to do the allocation */\
1242         if (!trie->nextword)                                    \
1243             trie->nextword = (U16 *)                                    \
1244                 PerlMemShared_calloc( word_count + 1, sizeof(U16));     \
1245         while ( trie->nextword[dupe] )                          \
1246             dupe= trie->nextword[dupe];                         \
1247         trie->nextword[dupe]= curword;                          \
1248     } else {                                                    \
1249         /* we haven't inserted this word yet.                */ \
1250         trie->states[ state ].wordnum = curword;                \
1251     }                                                           \
1252 } STMT_END
1253
1254
1255 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
1256      ( ( base + charid >=  ucharcount                                   \
1257          && base + charid < ubound                                      \
1258          && state == trie->trans[ base - ucharcount + charid ].check    \
1259          && trie->trans[ base - ucharcount + charid ].next )            \
1260            ? trie->trans[ base - ucharcount + charid ].next             \
1261            : ( state==1 ? special : 0 )                                 \
1262       )
1263
1264 #define MADE_TRIE       1
1265 #define MADE_JUMP_TRIE  2
1266 #define MADE_EXACT_TRIE 4
1267
1268 STATIC I32
1269 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1270 {
1271     dVAR;
1272     /* first pass, loop through and scan words */
1273     reg_trie_data *trie;
1274     HV *widecharmap = NULL;
1275     AV *revcharmap = newAV();
1276     regnode *cur;
1277     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1278     STRLEN len = 0;
1279     UV uvc = 0;
1280     U16 curword = 0;
1281     U32 next_alloc = 0;
1282     regnode *jumper = NULL;
1283     regnode *nextbranch = NULL;
1284     regnode *convert = NULL;
1285     /* we just use folder as a flag in utf8 */
1286     const U8 * const folder = ( flags == EXACTF
1287                        ? PL_fold
1288                        : ( flags == EXACTFL
1289                            ? PL_fold_locale
1290                            : NULL
1291                          )
1292                      );
1293
1294 #ifdef DEBUGGING
1295     const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1296     AV *trie_words = NULL;
1297     /* along with revcharmap, this only used during construction but both are
1298      * useful during debugging so we store them in the struct when debugging.
1299      */
1300 #else
1301     const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1302     STRLEN trie_charcount=0;
1303 #endif
1304     SV *re_trie_maxbuff;
1305     GET_RE_DEBUG_FLAGS_DECL;
1306 #ifndef DEBUGGING
1307     PERL_UNUSED_ARG(depth);
1308 #endif
1309
1310     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1311     trie->refcount = 1;
1312     trie->startstate = 1;
1313     trie->wordcount = word_count;
1314     RExC_rxi->data->data[ data_slot ] = (void*)trie;
1315     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1316     if (!(UTF && folder))
1317         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1318     DEBUG_r({
1319         trie_words = newAV();
1320     });
1321
1322     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1323     if (!SvIOK(re_trie_maxbuff)) {
1324         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1325     }
1326     DEBUG_OPTIMISE_r({
1327                 PerlIO_printf( Perl_debug_log,
1328                   "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1329                   (int)depth * 2 + 2, "", 
1330                   REG_NODE_NUM(startbranch),REG_NODE_NUM(first), 
1331                   REG_NODE_NUM(last), REG_NODE_NUM(tail),
1332                   (int)depth);
1333     });
1334    
1335    /* Find the node we are going to overwrite */
1336     if ( first == startbranch && OP( last ) != BRANCH ) {
1337         /* whole branch chain */
1338         convert = first;
1339     } else {
1340         /* branch sub-chain */
1341         convert = NEXTOPER( first );
1342     }
1343         
1344     /*  -- First loop and Setup --
1345
1346        We first traverse the branches and scan each word to determine if it
1347        contains widechars, and how many unique chars there are, this is
1348        important as we have to build a table with at least as many columns as we
1349        have unique chars.
1350
1351        We use an array of integers to represent the character codes 0..255
1352        (trie->charmap) and we use a an HV* to store unicode characters. We use the
1353        native representation of the character value as the key and IV's for the
1354        coded index.
1355
1356        *TODO* If we keep track of how many times each character is used we can
1357        remap the columns so that the table compression later on is more
1358        efficient in terms of memory by ensuring most common value is in the
1359        middle and the least common are on the outside.  IMO this would be better
1360        than a most to least common mapping as theres a decent chance the most
1361        common letter will share a node with the least common, meaning the node
1362        will not be compressable. With a middle is most common approach the worst
1363        case is when we have the least common nodes twice.
1364
1365      */
1366
1367     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1368         regnode * const noper = NEXTOPER( cur );
1369         const U8 *uc = (U8*)STRING( noper );
1370         const U8 * const e  = uc + STR_LEN( noper );
1371         STRLEN foldlen = 0;
1372         U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1373         const U8 *scan = (U8*)NULL;
1374         U32 wordlen      = 0;         /* required init */
1375         STRLEN chars=0;
1376
1377         if (OP(noper) == NOTHING) {
1378             trie->minlen= 0;
1379             continue;
1380         }
1381         if (trie->bitmap) {
1382             TRIE_BITMAP_SET(trie,*uc);
1383             if ( folder ) TRIE_BITMAP_SET(trie,folder[ *uc ]);            
1384         }
1385         for ( ; uc < e ; uc += len ) {
1386             TRIE_CHARCOUNT(trie)++;
1387             TRIE_READ_CHAR;
1388             chars++;
1389             if ( uvc < 256 ) {
1390                 if ( !trie->charmap[ uvc ] ) {
1391                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1392                     if ( folder )
1393                         trie->charmap[ folder[ uvc ] ] = trie->charmap[ uvc ];
1394                     TRIE_STORE_REVCHAR;
1395                 }
1396             } else {
1397                 SV** svpp;
1398                 if ( !widecharmap )
1399                     widecharmap = newHV();
1400
1401                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1402
1403                 if ( !svpp )
1404                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1405
1406                 if ( !SvTRUE( *svpp ) ) {
1407                     sv_setiv( *svpp, ++trie->uniquecharcount );
1408                     TRIE_STORE_REVCHAR;
1409                 }
1410             }
1411         }
1412         if( cur == first ) {
1413             trie->minlen=chars;
1414             trie->maxlen=chars;
1415         } else if (chars < trie->minlen) {
1416             trie->minlen=chars;
1417         } else if (chars > trie->maxlen) {
1418             trie->maxlen=chars;
1419         }
1420
1421     } /* end first pass */
1422     DEBUG_TRIE_COMPILE_r(
1423         PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1424                 (int)depth * 2 + 2,"",
1425                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1426                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1427                 (int)trie->minlen, (int)trie->maxlen )
1428     );
1429     trie->wordlen = (U32 *) PerlMemShared_calloc( word_count, sizeof(U32) );
1430
1431     /*
1432         We now know what we are dealing with in terms of unique chars and
1433         string sizes so we can calculate how much memory a naive
1434         representation using a flat table  will take. If it's over a reasonable
1435         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1436         conservative but potentially much slower representation using an array
1437         of lists.
1438
1439         At the end we convert both representations into the same compressed
1440         form that will be used in regexec.c for matching with. The latter
1441         is a form that cannot be used to construct with but has memory
1442         properties similar to the list form and access properties similar
1443         to the table form making it both suitable for fast searches and
1444         small enough that its feasable to store for the duration of a program.
1445
1446         See the comment in the code where the compressed table is produced
1447         inplace from the flat tabe representation for an explanation of how
1448         the compression works.
1449
1450     */
1451
1452
1453     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1454         /*
1455             Second Pass -- Array Of Lists Representation
1456
1457             Each state will be represented by a list of charid:state records
1458             (reg_trie_trans_le) the first such element holds the CUR and LEN
1459             points of the allocated array. (See defines above).
1460
1461             We build the initial structure using the lists, and then convert
1462             it into the compressed table form which allows faster lookups
1463             (but cant be modified once converted).
1464         */
1465
1466         STRLEN transcount = 1;
1467
1468         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1469             "%*sCompiling trie using list compiler\n",
1470             (int)depth * 2 + 2, ""));
1471         
1472         trie->states = (reg_trie_state *)
1473             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1474                                   sizeof(reg_trie_state) );
1475         TRIE_LIST_NEW(1);
1476         next_alloc = 2;
1477
1478         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1479
1480             regnode * const noper = NEXTOPER( cur );
1481             U8 *uc           = (U8*)STRING( noper );
1482             const U8 * const e = uc + STR_LEN( noper );
1483             U32 state        = 1;         /* required init */
1484             U16 charid       = 0;         /* sanity init */
1485             U8 *scan         = (U8*)NULL; /* sanity init */
1486             STRLEN foldlen   = 0;         /* required init */
1487             U32 wordlen      = 0;         /* required init */
1488             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1489
1490             if (OP(noper) != NOTHING) {
1491                 for ( ; uc < e ; uc += len ) {
1492
1493                     TRIE_READ_CHAR;
1494
1495                     if ( uvc < 256 ) {
1496                         charid = trie->charmap[ uvc ];
1497                     } else {
1498                         SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1499                         if ( !svpp ) {
1500                             charid = 0;
1501                         } else {
1502                             charid=(U16)SvIV( *svpp );
1503                         }
1504                     }
1505                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1506                     if ( charid ) {
1507
1508                         U16 check;
1509                         U32 newstate = 0;
1510
1511                         charid--;
1512                         if ( !trie->states[ state ].trans.list ) {
1513                             TRIE_LIST_NEW( state );
1514                         }
1515                         for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1516                             if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1517                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1518                                 break;
1519                             }
1520                         }
1521                         if ( ! newstate ) {
1522                             newstate = next_alloc++;
1523                             TRIE_LIST_PUSH( state, charid, newstate );
1524                             transcount++;
1525                         }
1526                         state = newstate;
1527                     } else {
1528                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1529                     }
1530                 }
1531             }
1532             TRIE_HANDLE_WORD(state);
1533
1534         } /* end second pass */
1535
1536         /* next alloc is the NEXT state to be allocated */
1537         trie->statecount = next_alloc; 
1538         trie->states = (reg_trie_state *)
1539             PerlMemShared_realloc( trie->states,
1540                                    next_alloc
1541                                    * sizeof(reg_trie_state) );
1542
1543         /* and now dump it out before we compress it */
1544         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1545                                                          revcharmap, next_alloc,
1546                                                          depth+1)
1547         );
1548
1549         trie->trans = (reg_trie_trans *)
1550             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1551         {
1552             U32 state;
1553             U32 tp = 0;
1554             U32 zp = 0;
1555
1556
1557             for( state=1 ; state < next_alloc ; state ++ ) {
1558                 U32 base=0;
1559
1560                 /*
1561                 DEBUG_TRIE_COMPILE_MORE_r(
1562                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1563                 );
1564                 */
1565
1566                 if (trie->states[state].trans.list) {
1567                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1568                     U16 maxid=minid;
1569                     U16 idx;
1570
1571                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1572                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1573                         if ( forid < minid ) {
1574                             minid=forid;
1575                         } else if ( forid > maxid ) {
1576                             maxid=forid;
1577                         }
1578                     }
1579                     if ( transcount < tp + maxid - minid + 1) {
1580                         transcount *= 2;
1581                         trie->trans = (reg_trie_trans *)
1582                             PerlMemShared_realloc( trie->trans,
1583                                                      transcount
1584                                                      * sizeof(reg_trie_trans) );
1585                         Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1586                     }
1587                     base = trie->uniquecharcount + tp - minid;
1588                     if ( maxid == minid ) {
1589                         U32 set = 0;
1590                         for ( ; zp < tp ; zp++ ) {
1591                             if ( ! trie->trans[ zp ].next ) {
1592                                 base = trie->uniquecharcount + zp - minid;
1593                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1594                                 trie->trans[ zp ].check = state;
1595                                 set = 1;
1596                                 break;
1597                             }
1598                         }
1599                         if ( !set ) {
1600                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1601                             trie->trans[ tp ].check = state;
1602                             tp++;
1603                             zp = tp;
1604                         }
1605                     } else {
1606                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1607                             const U32 tid = base -  trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1608                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1609                             trie->trans[ tid ].check = state;
1610                         }
1611                         tp += ( maxid - minid + 1 );
1612                     }
1613                     Safefree(trie->states[ state ].trans.list);
1614                 }
1615                 /*
1616                 DEBUG_TRIE_COMPILE_MORE_r(
1617                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1618                 );
1619                 */
1620                 trie->states[ state ].trans.base=base;
1621             }
1622             trie->lasttrans = tp + 1;
1623         }
1624     } else {
1625         /*
1626            Second Pass -- Flat Table Representation.
1627
1628            we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1629            We know that we will need Charcount+1 trans at most to store the data
1630            (one row per char at worst case) So we preallocate both structures
1631            assuming worst case.
1632
1633            We then construct the trie using only the .next slots of the entry
1634            structs.
1635
1636            We use the .check field of the first entry of the node  temporarily to
1637            make compression both faster and easier by keeping track of how many non
1638            zero fields are in the node.
1639
1640            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1641            transition.
1642
1643            There are two terms at use here: state as a TRIE_NODEIDX() which is a
1644            number representing the first entry of the node, and state as a
1645            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1646            TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1647            are 2 entrys per node. eg:
1648
1649              A B       A B
1650           1. 2 4    1. 3 7
1651           2. 0 3    3. 0 5
1652           3. 0 0    5. 0 0
1653           4. 0 0    7. 0 0
1654
1655            The table is internally in the right hand, idx form. However as we also
1656            have to deal with the states array which is indexed by nodenum we have to
1657            use TRIE_NODENUM() to convert.
1658
1659         */
1660         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1661             "%*sCompiling trie using table compiler\n",
1662             (int)depth * 2 + 2, ""));
1663
1664         trie->trans = (reg_trie_trans *)
1665             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
1666                                   * trie->uniquecharcount + 1,
1667                                   sizeof(reg_trie_trans) );
1668         trie->states = (reg_trie_state *)
1669             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1670                                   sizeof(reg_trie_state) );
1671         next_alloc = trie->uniquecharcount + 1;
1672
1673
1674         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1675
1676             regnode * const noper   = NEXTOPER( cur );
1677             const U8 *uc     = (U8*)STRING( noper );
1678             const U8 * const e = uc + STR_LEN( noper );
1679
1680             U32 state        = 1;         /* required init */
1681
1682             U16 charid       = 0;         /* sanity init */
1683             U32 accept_state = 0;         /* sanity init */
1684             U8 *scan         = (U8*)NULL; /* sanity init */
1685
1686             STRLEN foldlen   = 0;         /* required init */
1687             U32 wordlen      = 0;         /* required init */
1688             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1689
1690             if ( OP(noper) != NOTHING ) {
1691                 for ( ; uc < e ; uc += len ) {
1692
1693                     TRIE_READ_CHAR;
1694
1695                     if ( uvc < 256 ) {
1696                         charid = trie->charmap[ uvc ];
1697                     } else {
1698                         SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1699                         charid = svpp ? (U16)SvIV(*svpp) : 0;
1700                     }
1701                     if ( charid ) {
1702                         charid--;
1703                         if ( !trie->trans[ state + charid ].next ) {
1704                             trie->trans[ state + charid ].next = next_alloc;
1705                             trie->trans[ state ].check++;
1706                             next_alloc += trie->uniquecharcount;
1707                         }
1708                         state = trie->trans[ state + charid ].next;
1709                     } else {
1710                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1711                     }
1712                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1713                 }
1714             }
1715             accept_state = TRIE_NODENUM( state );
1716             TRIE_HANDLE_WORD(accept_state);
1717
1718         } /* end second pass */
1719
1720         /* and now dump it out before we compress it */
1721         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
1722                                                           revcharmap,
1723                                                           next_alloc, depth+1));
1724
1725         {
1726         /*
1727            * Inplace compress the table.*
1728
1729            For sparse data sets the table constructed by the trie algorithm will
1730            be mostly 0/FAIL transitions or to put it another way mostly empty.
1731            (Note that leaf nodes will not contain any transitions.)
1732
1733            This algorithm compresses the tables by eliminating most such
1734            transitions, at the cost of a modest bit of extra work during lookup:
1735
1736            - Each states[] entry contains a .base field which indicates the
1737            index in the state[] array wheres its transition data is stored.
1738
1739            - If .base is 0 there are no  valid transitions from that node.
1740
1741            - If .base is nonzero then charid is added to it to find an entry in
1742            the trans array.
1743
1744            -If trans[states[state].base+charid].check!=state then the
1745            transition is taken to be a 0/Fail transition. Thus if there are fail
1746            transitions at the front of the node then the .base offset will point
1747            somewhere inside the previous nodes data (or maybe even into a node
1748            even earlier), but the .check field determines if the transition is
1749            valid.
1750
1751            XXX - wrong maybe?
1752            The following process inplace converts the table to the compressed
1753            table: We first do not compress the root node 1,and mark its all its
1754            .check pointers as 1 and set its .base pointer as 1 as well. This
1755            allows to do a DFA construction from the compressed table later, and
1756            ensures that any .base pointers we calculate later are greater than
1757            0.
1758
1759            - We set 'pos' to indicate the first entry of the second node.
1760
1761            - We then iterate over the columns of the node, finding the first and
1762            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
1763            and set the .check pointers accordingly, and advance pos
1764            appropriately and repreat for the next node. Note that when we copy
1765            the next pointers we have to convert them from the original
1766            NODEIDX form to NODENUM form as the former is not valid post
1767            compression.
1768
1769            - If a node has no transitions used we mark its base as 0 and do not
1770            advance the pos pointer.
1771
1772            - If a node only has one transition we use a second pointer into the
1773            structure to fill in allocated fail transitions from other states.
1774            This pointer is independent of the main pointer and scans forward
1775            looking for null transitions that are allocated to a state. When it
1776            finds one it writes the single transition into the "hole".  If the
1777            pointer doesnt find one the single transition is appended as normal.
1778
1779            - Once compressed we can Renew/realloc the structures to release the
1780            excess space.
1781
1782            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
1783            specifically Fig 3.47 and the associated pseudocode.
1784
1785            demq
1786         */
1787         const U32 laststate = TRIE_NODENUM( next_alloc );
1788         U32 state, charid;
1789         U32 pos = 0, zp=0;
1790         trie->statecount = laststate;
1791
1792         for ( state = 1 ; state < laststate ; state++ ) {
1793             U8 flag = 0;
1794             const U32 stateidx = TRIE_NODEIDX( state );
1795             const U32 o_used = trie->trans[ stateidx ].check;
1796             U32 used = trie->trans[ stateidx ].check;
1797             trie->trans[ stateidx ].check = 0;
1798
1799             for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
1800                 if ( flag || trie->trans[ stateidx + charid ].next ) {
1801                     if ( trie->trans[ stateidx + charid ].next ) {
1802                         if (o_used == 1) {
1803                             for ( ; zp < pos ; zp++ ) {
1804                                 if ( ! trie->trans[ zp ].next ) {
1805                                     break;
1806                                 }
1807                             }
1808                             trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
1809                             trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
1810                             trie->trans[ zp ].check = state;
1811                             if ( ++zp > pos ) pos = zp;
1812                             break;
1813                         }
1814                         used--;
1815                     }
1816                     if ( !flag ) {
1817                         flag = 1;
1818                         trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
1819                     }
1820                     trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
1821                     trie->trans[ pos ].check = state;
1822                     pos++;
1823                 }
1824             }
1825         }
1826         trie->lasttrans = pos + 1;
1827         trie->states = (reg_trie_state *)
1828             PerlMemShared_realloc( trie->states, laststate
1829                                    * sizeof(reg_trie_state) );
1830         DEBUG_TRIE_COMPILE_MORE_r(
1831                 PerlIO_printf( Perl_debug_log,
1832                     "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
1833                     (int)depth * 2 + 2,"",
1834                     (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
1835                     (IV)next_alloc,
1836                     (IV)pos,
1837                     ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
1838             );
1839
1840         } /* end table compress */
1841     }
1842     DEBUG_TRIE_COMPILE_MORE_r(
1843             PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
1844                 (int)depth * 2 + 2, "",
1845                 (UV)trie->statecount,
1846                 (UV)trie->lasttrans)
1847     );
1848     /* resize the trans array to remove unused space */
1849     trie->trans = (reg_trie_trans *)
1850         PerlMemShared_realloc( trie->trans, trie->lasttrans
1851                                * sizeof(reg_trie_trans) );
1852
1853     /* and now dump out the compressed format */
1854     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
1855
1856     {   /* Modify the program and insert the new TRIE node*/ 
1857         U8 nodetype =(U8)(flags & 0xFF);
1858         char *str=NULL;
1859         
1860 #ifdef DEBUGGING
1861         regnode *optimize = NULL;
1862 #ifdef RE_TRACK_PATTERN_OFFSETS
1863
1864         U32 mjd_offset = 0;
1865         U32 mjd_nodelen = 0;
1866 #endif /* RE_TRACK_PATTERN_OFFSETS */
1867 #endif /* DEBUGGING */
1868         /*
1869            This means we convert either the first branch or the first Exact,
1870            depending on whether the thing following (in 'last') is a branch
1871            or not and whther first is the startbranch (ie is it a sub part of
1872            the alternation or is it the whole thing.)
1873            Assuming its a sub part we conver the EXACT otherwise we convert
1874            the whole branch sequence, including the first.
1875          */
1876         /* Find the node we are going to overwrite */
1877         if ( first != startbranch || OP( last ) == BRANCH ) {
1878             /* branch sub-chain */
1879             NEXT_OFF( first ) = (U16)(last - first);
1880 #ifdef RE_TRACK_PATTERN_OFFSETS
1881             DEBUG_r({
1882                 mjd_offset= Node_Offset((convert));
1883                 mjd_nodelen= Node_Length((convert));
1884             });
1885 #endif
1886             /* whole branch chain */
1887         }
1888 #ifdef RE_TRACK_PATTERN_OFFSETS
1889         else {
1890             DEBUG_r({
1891                 const  regnode *nop = NEXTOPER( convert );
1892                 mjd_offset= Node_Offset((nop));
1893                 mjd_nodelen= Node_Length((nop));
1894             });
1895         }
1896         DEBUG_OPTIMISE_r(
1897             PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
1898                 (int)depth * 2 + 2, "",
1899                 (UV)mjd_offset, (UV)mjd_nodelen)
1900         );
1901 #endif
1902         /* But first we check to see if there is a common prefix we can 
1903            split out as an EXACT and put in front of the TRIE node.  */
1904         trie->startstate= 1;
1905         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
1906             U32 state;
1907             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
1908                 U32 ofs = 0;
1909                 I32 idx = -1;
1910                 U32 count = 0;
1911                 const U32 base = trie->states[ state ].trans.base;
1912
1913                 if ( trie->states[state].wordnum )
1914                         count = 1;
1915
1916                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1917                     if ( ( base + ofs >= trie->uniquecharcount ) &&
1918                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1919                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1920                     {
1921                         if ( ++count > 1 ) {
1922                             SV **tmp = av_fetch( revcharmap, ofs, 0);
1923                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
1924                             if ( state == 1 ) break;
1925                             if ( count == 2 ) {
1926                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
1927                                 DEBUG_OPTIMISE_r(
1928                                     PerlIO_printf(Perl_debug_log,
1929                                         "%*sNew Start State=%"UVuf" Class: [",
1930                                         (int)depth * 2 + 2, "",
1931                                         (UV)state));
1932                                 if (idx >= 0) {
1933                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
1934                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
1935
1936                                     TRIE_BITMAP_SET(trie,*ch);
1937                                     if ( folder )
1938                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
1939                                     DEBUG_OPTIMISE_r(
1940                                         PerlIO_printf(Perl_debug_log, (char*)ch)
1941                                     );
1942                                 }
1943                             }
1944                             TRIE_BITMAP_SET(trie,*ch);
1945                             if ( folder )
1946                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
1947                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
1948                         }
1949                         idx = ofs;
1950                     }
1951                 }
1952                 if ( count == 1 ) {
1953                     SV **tmp = av_fetch( revcharmap, idx, 0);
1954                     char *ch = SvPV_nolen( *tmp );
1955                     DEBUG_OPTIMISE_r({
1956                         SV *sv=sv_newmortal();
1957                         PerlIO_printf( Perl_debug_log,
1958                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
1959                             (int)depth * 2 + 2, "",
1960                             (UV)state, (UV)idx, 
1961                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, 
1962                                 PL_colors[0], PL_colors[1],
1963                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1964                                 PERL_PV_ESCAPE_FIRSTCHAR 
1965                             )
1966                         );
1967                     });
1968                     if ( state==1 ) {
1969                         OP( convert ) = nodetype;
1970                         str=STRING(convert);
1971                         STR_LEN(convert)=0;
1972                     }
1973                     while (*ch) {
1974                         *str++ = *ch++;
1975                         STR_LEN(convert)++;
1976                     }
1977                     
1978                 } else {
1979 #ifdef DEBUGGING            
1980                     if (state>1)
1981                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
1982 #endif
1983                     break;
1984                 }
1985             }
1986             if (str) {
1987                 regnode *n = convert+NODE_SZ_STR(convert);
1988                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
1989                 trie->startstate = state;
1990                 trie->minlen -= (state - 1);
1991                 trie->maxlen -= (state - 1);
1992                 DEBUG_r({
1993                     regnode *fix = convert;
1994                     U32 word = trie->wordcount;
1995                     mjd_nodelen++;
1996                     Set_Node_Offset_Length(convert, mjd_offset, state - 1);
1997                     while( ++fix < n ) {
1998                         Set_Node_Offset_Length(fix, 0, 0);
1999                     }
2000                     while (word--) {
2001                         SV ** const tmp = av_fetch( trie_words, word, 0 );
2002                         if (tmp) {
2003                             if ( STR_LEN(convert) <= SvCUR(*tmp) )
2004                                 sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2005                             else
2006                                 sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2007                         }
2008                     }    
2009                 });
2010                 if (trie->maxlen) {
2011                     convert = n;
2012                 } else {
2013                     NEXT_OFF(convert) = (U16)(tail - convert);
2014                     DEBUG_r(optimize= n);
2015                 }
2016             }
2017         }
2018         if (!jumper) 
2019             jumper = last; 
2020         if ( trie->maxlen ) {
2021             NEXT_OFF( convert ) = (U16)(tail - convert);
2022             ARG_SET( convert, data_slot );
2023             /* Store the offset to the first unabsorbed branch in 
2024                jump[0], which is otherwise unused by the jump logic. 
2025                We use this when dumping a trie and during optimisation. */
2026             if (trie->jump) 
2027                 trie->jump[0] = (U16)(nextbranch - convert);
2028             
2029             /* XXXX */
2030             if ( !trie->states[trie->startstate].wordnum && trie->bitmap && 
2031                  ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2032             {
2033                 OP( convert ) = TRIEC;
2034                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2035                 PerlMemShared_free(trie->bitmap);
2036                 trie->bitmap= NULL;
2037             } else 
2038                 OP( convert ) = TRIE;
2039
2040             /* store the type in the flags */
2041             convert->flags = nodetype;
2042             DEBUG_r({
2043             optimize = convert 
2044                       + NODE_STEP_REGNODE 
2045                       + regarglen[ OP( convert ) ];
2046             });
2047             /* XXX We really should free up the resource in trie now, 
2048                    as we won't use them - (which resources?) dmq */
2049         }
2050         /* needed for dumping*/
2051         DEBUG_r(if (optimize) {
2052             regnode *opt = convert;
2053
2054             while ( ++opt < optimize) {
2055                 Set_Node_Offset_Length(opt,0,0);
2056             }
2057             /* 
2058                 Try to clean up some of the debris left after the 
2059                 optimisation.
2060              */
2061             while( optimize < jumper ) {
2062                 mjd_nodelen += Node_Length((optimize));
2063                 OP( optimize ) = OPTIMIZED;
2064                 Set_Node_Offset_Length(optimize,0,0);
2065                 optimize++;
2066             }
2067             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2068         });
2069     } /* end node insert */
2070     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2071 #ifdef DEBUGGING
2072     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2073     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2074 #else
2075     SvREFCNT_dec(revcharmap);
2076 #endif
2077     return trie->jump 
2078            ? MADE_JUMP_TRIE 
2079            : trie->startstate>1 
2080              ? MADE_EXACT_TRIE 
2081              : MADE_TRIE;
2082 }
2083
2084 STATIC void
2085 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source,  regnode *stclass, U32 depth)
2086 {
2087 /* The Trie is constructed and compressed now so we can build a fail array now if its needed
2088
2089    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2090    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2091    ISBN 0-201-10088-6
2092
2093    We find the fail state for each state in the trie, this state is the longest proper
2094    suffix of the current states 'word' that is also a proper prefix of another word in our
2095    trie. State 1 represents the word '' and is the thus the default fail state. This allows
2096    the DFA not to have to restart after its tried and failed a word at a given point, it
2097    simply continues as though it had been matching the other word in the first place.
2098    Consider
2099       'abcdgu'=~/abcdefg|cdgu/
2100    When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2101    fail, which would bring use to the state representing 'd' in the second word where we would
2102    try 'g' and succeed, prodceding to match 'cdgu'.
2103  */
2104  /* add a fail transition */
2105     const U32 trie_offset = ARG(source);
2106     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2107     U32 *q;
2108     const U32 ucharcount = trie->uniquecharcount;
2109     const U32 numstates = trie->statecount;
2110     const U32 ubound = trie->lasttrans + ucharcount;
2111     U32 q_read = 0;
2112     U32 q_write = 0;
2113     U32 charid;
2114     U32 base = trie->states[ 1 ].trans.base;
2115     U32 *fail;
2116     reg_ac_data *aho;
2117     const U32 data_slot = add_data( pRExC_state, 1, "T" );
2118     GET_RE_DEBUG_FLAGS_DECL;
2119 #ifndef DEBUGGING
2120     PERL_UNUSED_ARG(depth);
2121 #endif
2122
2123
2124     ARG_SET( stclass, data_slot );
2125     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2126     RExC_rxi->data->data[ data_slot ] = (void*)aho;
2127     aho->trie=trie_offset;
2128     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2129     Copy( trie->states, aho->states, numstates, reg_trie_state );
2130     Newxz( q, numstates, U32);
2131     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2132     aho->refcount = 1;
2133     fail = aho->fail;
2134     /* initialize fail[0..1] to be 1 so that we always have
2135        a valid final fail state */
2136     fail[ 0 ] = fail[ 1 ] = 1;
2137
2138     for ( charid = 0; charid < ucharcount ; charid++ ) {
2139         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2140         if ( newstate ) {
2141             q[ q_write ] = newstate;
2142             /* set to point at the root */
2143             fail[ q[ q_write++ ] ]=1;
2144         }
2145     }
2146     while ( q_read < q_write) {
2147         const U32 cur = q[ q_read++ % numstates ];
2148         base = trie->states[ cur ].trans.base;
2149
2150         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2151             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2152             if (ch_state) {
2153                 U32 fail_state = cur;
2154                 U32 fail_base;
2155                 do {
2156                     fail_state = fail[ fail_state ];
2157                     fail_base = aho->states[ fail_state ].trans.base;
2158                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2159
2160                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2161                 fail[ ch_state ] = fail_state;
2162                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2163                 {
2164                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
2165                 }
2166                 q[ q_write++ % numstates] = ch_state;
2167             }
2168         }
2169     }
2170     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2171        when we fail in state 1, this allows us to use the
2172        charclass scan to find a valid start char. This is based on the principle
2173        that theres a good chance the string being searched contains lots of stuff
2174        that cant be a start char.
2175      */
2176     fail[ 0 ] = fail[ 1 ] = 0;
2177     DEBUG_TRIE_COMPILE_r({
2178         PerlIO_printf(Perl_debug_log,
2179                       "%*sStclass Failtable (%"UVuf" states): 0", 
2180                       (int)(depth * 2), "", (UV)numstates
2181         );
2182         for( q_read=1; q_read<numstates; q_read++ ) {
2183             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2184         }
2185         PerlIO_printf(Perl_debug_log, "\n");
2186     });
2187     Safefree(q);
2188     /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2189 }
2190
2191
2192 /*
2193  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2194  * These need to be revisited when a newer toolchain becomes available.
2195  */
2196 #if defined(__sparc64__) && defined(__GNUC__)
2197 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2198 #       undef  SPARC64_GCC_WORKAROUND
2199 #       define SPARC64_GCC_WORKAROUND 1
2200 #   endif
2201 #endif
2202
2203 #define DEBUG_PEEP(str,scan,depth) \
2204     DEBUG_OPTIMISE_r({if (scan){ \
2205        SV * const mysv=sv_newmortal(); \
2206        regnode *Next = regnext(scan); \
2207        regprop(RExC_rx, mysv, scan); \
2208        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2209        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2210        Next ? (REG_NODE_NUM(Next)) : 0 ); \
2211    }});
2212
2213
2214
2215
2216
2217 #define JOIN_EXACT(scan,min,flags) \
2218     if (PL_regkind[OP(scan)] == EXACT) \
2219         join_exact(pRExC_state,(scan),(min),(flags),NULL,depth+1)
2220
2221 STATIC U32
2222 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags,regnode *val, U32 depth) {
2223     /* Merge several consecutive EXACTish nodes into one. */
2224     regnode *n = regnext(scan);
2225     U32 stringok = 1;
2226     regnode *next = scan + NODE_SZ_STR(scan);
2227     U32 merged = 0;
2228     U32 stopnow = 0;
2229 #ifdef DEBUGGING
2230     regnode *stop = scan;
2231     GET_RE_DEBUG_FLAGS_DECL;
2232 #else
2233     PERL_UNUSED_ARG(depth);
2234 #endif
2235 #ifndef EXPERIMENTAL_INPLACESCAN
2236     PERL_UNUSED_ARG(flags);
2237     PERL_UNUSED_ARG(val);
2238 #endif
2239     DEBUG_PEEP("join",scan,depth);
2240     
2241     /* Skip NOTHING, merge EXACT*. */
2242     while (n &&
2243            ( PL_regkind[OP(n)] == NOTHING ||
2244              (stringok && (OP(n) == OP(scan))))
2245            && NEXT_OFF(n)
2246            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
2247         
2248         if (OP(n) == TAIL || n > next)
2249             stringok = 0;
2250         if (PL_regkind[OP(n)] == NOTHING) {
2251             DEBUG_PEEP("skip:",n,depth);
2252             NEXT_OFF(scan) += NEXT_OFF(n);
2253             next = n + NODE_STEP_REGNODE;
2254 #ifdef DEBUGGING
2255             if (stringok)
2256                 stop = n;
2257 #endif
2258             n = regnext(n);
2259         }
2260         else if (stringok) {
2261             const unsigned int oldl = STR_LEN(scan);
2262             regnode * const nnext = regnext(n);
2263             
2264             DEBUG_PEEP("merg",n,depth);
2265             
2266             merged++;
2267             if (oldl + STR_LEN(n) > U8_MAX)
2268                 break;
2269             NEXT_OFF(scan) += NEXT_OFF(n);
2270             STR_LEN(scan) += STR_LEN(n);
2271             next = n + NODE_SZ_STR(n);
2272             /* Now we can overwrite *n : */
2273             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2274 #ifdef DEBUGGING
2275             stop = next - 1;
2276 #endif
2277             n = nnext;
2278             if (stopnow) break;
2279         }
2280
2281 #ifdef EXPERIMENTAL_INPLACESCAN
2282         if (flags && !NEXT_OFF(n)) {
2283             DEBUG_PEEP("atch", val, depth);
2284             if (reg_off_by_arg[OP(n)]) {
2285                 ARG_SET(n, val - n);
2286             }
2287             else {
2288                 NEXT_OFF(n) = val - n;
2289             }
2290             stopnow = 1;
2291         }
2292 #endif
2293     }
2294     
2295     if (UTF && ( OP(scan) == EXACTF ) && ( STR_LEN(scan) >= 6 ) ) {
2296     /*
2297     Two problematic code points in Unicode casefolding of EXACT nodes:
2298     
2299     U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2300     U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2301     
2302     which casefold to
2303     
2304     Unicode                      UTF-8
2305     
2306     U+03B9 U+0308 U+0301         0xCE 0xB9 0xCC 0x88 0xCC 0x81
2307     U+03C5 U+0308 U+0301         0xCF 0x85 0xCC 0x88 0xCC 0x81
2308     
2309     This means that in case-insensitive matching (or "loose matching",
2310     as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
2311     length of the above casefolded versions) can match a target string
2312     of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
2313     This would rather mess up the minimum length computation.
2314     
2315     What we'll do is to look for the tail four bytes, and then peek
2316     at the preceding two bytes to see whether we need to decrease
2317     the minimum length by four (six minus two).
2318     
2319     Thanks to the design of UTF-8, there cannot be false matches:
2320     A sequence of valid UTF-8 bytes cannot be a subsequence of
2321     another valid sequence of UTF-8 bytes.
2322     
2323     */
2324          char * const s0 = STRING(scan), *s, *t;
2325          char * const s1 = s0 + STR_LEN(scan) - 1;
2326          char * const s2 = s1 - 4;
2327 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2328          const char t0[] = "\xaf\x49\xaf\x42";
2329 #else
2330          const char t0[] = "\xcc\x88\xcc\x81";
2331 #endif
2332          const char * const t1 = t0 + 3;
2333     
2334          for (s = s0 + 2;
2335               s < s2 && (t = ninstr(s, s1, t0, t1));
2336               s = t + 4) {
2337 #ifdef EBCDIC
2338               if (((U8)t[-1] == 0x68 && (U8)t[-2] == 0xB4) ||
2339                   ((U8)t[-1] == 0x46 && (U8)t[-2] == 0xB5))
2340 #else
2341               if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
2342                   ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
2343 #endif
2344                    *min -= 4;
2345          }
2346     }
2347     
2348 #ifdef DEBUGGING
2349     /* Allow dumping */
2350     n = scan + NODE_SZ_STR(scan);
2351     while (n <= stop) {
2352         if (PL_regkind[OP(n)] != NOTHING || OP(n) == NOTHING) {
2353             OP(n) = OPTIMIZED;
2354             NEXT_OFF(n) = 0;
2355         }
2356         n++;
2357     }
2358 #endif
2359     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2360     return stopnow;
2361 }
2362
2363 /* REx optimizer.  Converts nodes into quickier variants "in place".
2364    Finds fixed substrings.  */
2365
2366 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2367    to the position after last scanned or to NULL. */
2368
2369 #define INIT_AND_WITHP \
2370     assert(!and_withp); \
2371     Newx(and_withp,1,struct regnode_charclass_class); \
2372     SAVEFREEPV(and_withp)
2373
2374 /* this is a chain of data about sub patterns we are processing that
2375    need to be handled seperately/specially in study_chunk. Its so
2376    we can simulate recursion without losing state.  */
2377 struct scan_frame;
2378 typedef struct scan_frame {
2379     regnode *last;  /* last node to process in this frame */
2380     regnode *next;  /* next node to process when last is reached */
2381     struct scan_frame *prev; /*previous frame*/
2382     I32 stop; /* what stopparen do we use */
2383 } scan_frame;
2384
2385
2386 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2387
2388 STATIC I32
2389 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2390                         I32 *minlenp, I32 *deltap,
2391                         regnode *last,
2392                         scan_data_t *data,
2393                         I32 stopparen,
2394                         U8* recursed,
2395                         struct regnode_charclass_class *and_withp,
2396                         U32 flags, U32 depth)
2397                         /* scanp: Start here (read-write). */
2398                         /* deltap: Write maxlen-minlen here. */
2399                         /* last: Stop before this one. */
2400                         /* data: string data about the pattern */
2401                         /* stopparen: treat close N as END */
2402                         /* recursed: which subroutines have we recursed into */
2403                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
2404 {
2405     dVAR;
2406     I32 min = 0, pars = 0, code;
2407     regnode *scan = *scanp, *next;
2408     I32 delta = 0;
2409     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
2410     int is_inf_internal = 0;            /* The studied chunk is infinite */
2411     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
2412     scan_data_t data_fake;
2413     SV *re_trie_maxbuff = NULL;
2414     regnode *first_non_open = scan;
2415     I32 stopmin = I32_MAX;
2416     scan_frame *frame = NULL;
2417
2418     GET_RE_DEBUG_FLAGS_DECL;
2419
2420 #ifdef DEBUGGING
2421     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
2422 #endif
2423
2424     if ( depth == 0 ) {
2425         while (first_non_open && OP(first_non_open) == OPEN)
2426             first_non_open=regnext(first_non_open);
2427     }
2428
2429
2430   fake_study_recurse:
2431     while ( scan && OP(scan) != END && scan < last ){
2432         /* Peephole optimizer: */
2433         DEBUG_STUDYDATA("Peep:", data,depth);
2434         DEBUG_PEEP("Peep",scan,depth);
2435         JOIN_EXACT(scan,&min,0);
2436
2437         /* Follow the next-chain of the current node and optimize
2438            away all the NOTHINGs from it.  */
2439         if (OP(scan) != CURLYX) {
2440             const int max = (reg_off_by_arg[OP(scan)]
2441                        ? I32_MAX
2442                        /* I32 may be smaller than U16 on CRAYs! */
2443                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
2444             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
2445             int noff;
2446             regnode *n = scan;
2447         
2448             /* Skip NOTHING and LONGJMP. */
2449             while ((n = regnext(n))
2450                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
2451                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
2452                    && off + noff < max)
2453                 off += noff;
2454             if (reg_off_by_arg[OP(scan)])
2455                 ARG(scan) = off;
2456             else
2457                 NEXT_OFF(scan) = off;
2458         }
2459
2460
2461
2462         /* The principal pseudo-switch.  Cannot be a switch, since we
2463            look into several different things.  */
2464         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
2465                    || OP(scan) == IFTHEN) {
2466             next = regnext(scan);
2467             code = OP(scan);
2468             /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
2469         
2470             if (OP(next) == code || code == IFTHEN) {
2471                 /* NOTE - There is similar code to this block below for handling
2472                    TRIE nodes on a re-study.  If you change stuff here check there
2473                    too. */
2474                 I32 max1 = 0, min1 = I32_MAX, num = 0;
2475                 struct regnode_charclass_class accum;
2476                 regnode * const startbranch=scan;
2477                 
2478                 if (flags & SCF_DO_SUBSTR)
2479                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
2480                 if (flags & SCF_DO_STCLASS)
2481                     cl_init_zero(pRExC_state, &accum);
2482
2483                 while (OP(scan) == code) {
2484                     I32 deltanext, minnext, f = 0, fake;
2485                     struct regnode_charclass_class this_class;
2486
2487                     num++;
2488                     data_fake.flags = 0;
2489                     if (data) {
2490                         data_fake.whilem_c = data->whilem_c;
2491                         data_fake.last_closep = data->last_closep;
2492                     }
2493                     else
2494                         data_fake.last_closep = &fake;
2495
2496                     data_fake.pos_delta = delta;
2497                     next = regnext(scan);
2498                     scan = NEXTOPER(scan);
2499                     if (code != BRANCH)
2500                         scan = NEXTOPER(scan);
2501                     if (flags & SCF_DO_STCLASS) {
2502                         cl_init(pRExC_state, &this_class);
2503                         data_fake.start_class = &this_class;
2504                         f = SCF_DO_STCLASS_AND;
2505                     }
2506                     if (flags & SCF_WHILEM_VISITED_POS)
2507                         f |= SCF_WHILEM_VISITED_POS;
2508
2509                     /* we suppose the run is continuous, last=next...*/
2510                     minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
2511                                           next, &data_fake,
2512                                           stopparen, recursed, NULL, f,depth+1);
2513                     if (min1 > minnext)
2514                         min1 = minnext;
2515                     if (max1 < minnext + deltanext)
2516                         max1 = minnext + deltanext;
2517                     if (deltanext == I32_MAX)
2518                         is_inf = is_inf_internal = 1;
2519                     scan = next;
2520                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
2521                         pars++;
2522                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
2523                         if ( stopmin > minnext) 
2524                             stopmin = min + min1;
2525                         flags &= ~SCF_DO_SUBSTR;
2526                         if (data)
2527                             data->flags |= SCF_SEEN_ACCEPT;
2528                     }
2529                     if (data) {
2530                         if (data_fake.flags & SF_HAS_EVAL)
2531                             data->flags |= SF_HAS_EVAL;
2532                         data->whilem_c = data_fake.whilem_c;
2533                     }
2534                     if (flags & SCF_DO_STCLASS)
2535                         cl_or(pRExC_state, &accum, &this_class);
2536                 }
2537                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
2538                     min1 = 0;
2539                 if (flags & SCF_DO_SUBSTR) {
2540                     data->pos_min += min1;
2541                     data->pos_delta += max1 - min1;
2542                     if (max1 != min1 || is_inf)
2543                         data->longest = &(data->longest_float);
2544                 }
2545                 min += min1;
2546                 delta += max1 - min1;
2547                 if (flags & SCF_DO_STCLASS_OR) {
2548                     cl_or(pRExC_state, data->start_class, &accum);
2549                     if (min1) {
2550                         cl_and(data->start_class, and_withp);
2551                         flags &= ~SCF_DO_STCLASS;
2552                     }
2553                 }
2554                 else if (flags & SCF_DO_STCLASS_AND) {
2555                     if (min1) {
2556                         cl_and(data->start_class, &accum);
2557                         flags &= ~SCF_DO_STCLASS;
2558                     }
2559                     else {
2560                         /* Switch to OR mode: cache the old value of
2561                          * data->start_class */
2562                         INIT_AND_WITHP;
2563                         StructCopy(data->start_class, and_withp,
2564                                    struct regnode_charclass_class);
2565                         flags &= ~SCF_DO_STCLASS_AND;
2566                         StructCopy(&accum, data->start_class,
2567                                    struct regnode_charclass_class);
2568                         flags |= SCF_DO_STCLASS_OR;
2569                         data->start_class->flags |= ANYOF_EOS;
2570                     }
2571                 }
2572
2573                 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
2574                 /* demq.
2575
2576                    Assuming this was/is a branch we are dealing with: 'scan' now
2577                    points at the item that follows the branch sequence, whatever
2578                    it is. We now start at the beginning of the sequence and look
2579                    for subsequences of
2580
2581                    BRANCH->EXACT=>x1
2582                    BRANCH->EXACT=>x2
2583                    tail
2584
2585                    which would be constructed from a pattern like /A|LIST|OF|WORDS/
2586
2587                    If we can find such a subseqence we need to turn the first
2588                    element into a trie and then add the subsequent branch exact
2589                    strings to the trie.
2590
2591                    We have two cases
2592
2593                      1. patterns where the whole set of branch can be converted. 
2594
2595                      2. patterns where only a subset can be converted.
2596
2597                    In case 1 we can replace the whole set with a single regop
2598                    for the trie. In case 2 we need to keep the start and end
2599                    branchs so
2600
2601                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
2602                      becomes BRANCH TRIE; BRANCH X;
2603
2604                   There is an additional case, that being where there is a 
2605                   common prefix, which gets split out into an EXACT like node
2606                   preceding the TRIE node.
2607
2608                   If x(1..n)==tail then we can do a simple trie, if not we make
2609                   a "jump" trie, such that when we match the appropriate word
2610                   we "jump" to the appopriate tail node. Essentailly we turn
2611                   a nested if into a case structure of sorts.
2612
2613                 */
2614                 
2615                     int made=0;
2616                     if (!re_trie_maxbuff) {
2617                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2618                         if (!SvIOK(re_trie_maxbuff))
2619                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2620                     }
2621                     if ( SvIV(re_trie_maxbuff)>=0  ) {
2622                         regnode *cur;
2623                         regnode *first = (regnode *)NULL;
2624                         regnode *last = (regnode *)NULL;
2625                         regnode *tail = scan;
2626                         U8 optype = 0;
2627                         U32 count=0;
2628
2629 #ifdef DEBUGGING
2630                         SV * const mysv = sv_newmortal();       /* for dumping */
2631 #endif
2632                         /* var tail is used because there may be a TAIL
2633                            regop in the way. Ie, the exacts will point to the
2634                            thing following the TAIL, but the last branch will
2635                            point at the TAIL. So we advance tail. If we
2636                            have nested (?:) we may have to move through several
2637                            tails.
2638                          */
2639
2640                         while ( OP( tail ) == TAIL ) {
2641                             /* this is the TAIL generated by (?:) */
2642                             tail = regnext( tail );
2643                         }
2644
2645                         
2646                         DEBUG_OPTIMISE_r({
2647                             regprop(RExC_rx, mysv, tail );
2648                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
2649                                 (int)depth * 2 + 2, "", 
2650                                 "Looking for TRIE'able sequences. Tail node is: ", 
2651                                 SvPV_nolen_const( mysv )
2652                             );
2653                         });
2654                         
2655                         /*
2656
2657                            step through the branches, cur represents each
2658                            branch, noper is the first thing to be matched
2659                            as part of that branch and noper_next is the
2660                            regnext() of that node. if noper is an EXACT
2661                            and noper_next is the same as scan (our current
2662                            position in the regex) then the EXACT branch is
2663                            a possible optimization target. Once we have
2664                            two or more consequetive such branches we can
2665                            create a trie of the EXACT's contents and stich
2666                            it in place. If the sequence represents all of
2667                            the branches we eliminate the whole thing and
2668                            replace it with a single TRIE. If it is a
2669                            subsequence then we need to stitch it in. This
2670                            means the first branch has to remain, and needs
2671                            to be repointed at the item on the branch chain
2672                            following the last branch optimized. This could
2673                            be either a BRANCH, in which case the
2674                            subsequence is internal, or it could be the
2675                            item following the branch sequence in which
2676                            case the subsequence is at the end.
2677
2678                         */
2679
2680                         /* dont use tail as the end marker for this traverse */
2681                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
2682                             regnode * const noper = NEXTOPER( cur );
2683 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
2684                             regnode * const noper_next = regnext( noper );
2685 #endif
2686
2687                             DEBUG_OPTIMISE_r({
2688                                 regprop(RExC_rx, mysv, cur);
2689                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
2690                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
2691
2692                                 regprop(RExC_rx, mysv, noper);
2693                                 PerlIO_printf( Perl_debug_log, " -> %s",
2694                                     SvPV_nolen_const(mysv));
2695
2696                                 if ( noper_next ) {
2697                                   regprop(RExC_rx, mysv, noper_next );
2698                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
2699                                     SvPV_nolen_const(mysv));
2700                                 }
2701                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
2702                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
2703                             });
2704                             if ( (((first && optype!=NOTHING) ? OP( noper ) == optype
2705                                          : PL_regkind[ OP( noper ) ] == EXACT )
2706                                   || OP(noper) == NOTHING )
2707 #ifdef NOJUMPTRIE
2708                                   && noper_next == tail
2709 #endif
2710                                   && count < U16_MAX)
2711                             {
2712                                 count++;
2713                                 if ( !first || optype == NOTHING ) {
2714                                     if (!first) first = cur;
2715                                     optype = OP( noper );
2716                                 } else {
2717                                     last = cur;
2718                                 }
2719                             } else {
2720                                 if ( last ) {
2721                                     make_trie( pRExC_state, 
2722                                             startbranch, first, cur, tail, count, 
2723                                             optype, depth+1 );
2724                                 }
2725                                 if ( PL_regkind[ OP( noper ) ] == EXACT
2726 #ifdef NOJUMPTRIE
2727                                      && noper_next == tail
2728 #endif
2729                                 ){
2730                                     count = 1;
2731                                     first = cur;
2732                                     optype = OP( noper );
2733                                 } else {
2734                                     count = 0;
2735                                     first = NULL;
2736                                     optype = 0;
2737                                 }
2738                                 last = NULL;
2739                             }
2740                         }
2741                         DEBUG_OPTIMISE_r({
2742                             regprop(RExC_rx, mysv, cur);
2743                             PerlIO_printf( Perl_debug_log,
2744                               "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
2745                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
2746
2747                         });
2748                         if ( last ) {
2749                             made= make_trie( pRExC_state, startbranch, first, scan, tail, count, optype, depth+1 );
2750 #ifdef TRIE_STUDY_OPT   
2751                             if ( ((made == MADE_EXACT_TRIE && 
2752                                  startbranch == first) 
2753                                  || ( first_non_open == first )) && 
2754                                  depth==0 ) {
2755                                 flags |= SCF_TRIE_RESTUDY;
2756                                 if ( startbranch == first 
2757                                      && scan == tail ) 
2758                                 {
2759                                     RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
2760                                 }
2761                             }
2762 #endif
2763                         }
2764                     }
2765                     
2766                 } /* do trie */
2767                 
2768             }
2769             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
2770                 scan = NEXTOPER(NEXTOPER(scan));
2771             } else                      /* single branch is optimized. */
2772                 scan = NEXTOPER(scan);
2773             continue;
2774         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
2775             scan_frame *newframe = NULL;
2776             I32 paren;
2777             regnode *start;
2778             regnode *end;
2779
2780             if (OP(scan) != SUSPEND) {
2781             /* set the pointer */
2782                 if (OP(scan) == GOSUB) {
2783                     paren = ARG(scan);
2784                     RExC_recurse[ARG2L(scan)] = scan;
2785                     start = RExC_open_parens[paren-1];
2786                     end   = RExC_close_parens[paren-1];
2787                 } else {
2788                     paren = 0;
2789                     start = RExC_rxi->program + 1;
2790                     end   = RExC_opend;
2791                 }
2792                 if (!recursed) {
2793                     Newxz(recursed, (((RExC_npar)>>3) +1), U8);
2794                     SAVEFREEPV(recursed);
2795                 }
2796                 if (!PAREN_TEST(recursed,paren+1)) {
2797                     PAREN_SET(recursed,paren+1);
2798                     Newx(newframe,1,scan_frame);
2799                 } else {
2800                     if (flags & SCF_DO_SUBSTR) {
2801                         SCAN_COMMIT(pRExC_state,data,minlenp);
2802                         data->longest = &(data->longest_float);
2803                     }
2804                     is_inf = is_inf_internal = 1;
2805                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
2806                         cl_anything(pRExC_state, data->start_class);
2807                     flags &= ~SCF_DO_STCLASS;
2808                 }
2809             } else {
2810                 Newx(newframe,1,scan_frame);
2811                 paren = stopparen;
2812                 start = scan+2;
2813                 end = regnext(scan);
2814             }
2815             if (newframe) {
2816                 assert(start);
2817                 assert(end);
2818                 SAVEFREEPV(newframe);
2819                 newframe->next = regnext(scan);
2820                 newframe->last = last;
2821                 newframe->stop = stopparen;
2822                 newframe->prev = frame;
2823
2824                 frame = newframe;
2825                 scan =  start;
2826                 stopparen = paren;
2827                 last = end;
2828
2829                 continue;
2830             }
2831         }
2832         else if (OP(scan) == EXACT) {
2833             I32 l = STR_LEN(scan);
2834             UV uc;
2835             if (UTF) {
2836                 const U8 * const s = (U8*)STRING(scan);
2837                 l = utf8_length(s, s + l);
2838                 uc = utf8_to_uvchr(s, NULL);
2839             } else {
2840                 uc = *((U8*)STRING(scan));
2841             }
2842             min += l;
2843             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
2844                 /* The code below prefers earlier match for fixed
2845                    offset, later match for variable offset.  */
2846                 if (data->last_end == -1) { /* Update the start info. */
2847                     data->last_start_min = data->pos_min;
2848                     data->last_start_max = is_inf
2849                         ? I32_MAX : data->pos_min + data->pos_delta;
2850                 }
2851                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
2852                 if (UTF)
2853                     SvUTF8_on(data->last_found);
2854                 {
2855                     SV * const sv = data->last_found;
2856                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
2857                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
2858                     if (mg && mg->mg_len >= 0)
2859                         mg->mg_len += utf8_length((U8*)STRING(scan),
2860                                                   (U8*)STRING(scan)+STR_LEN(scan));
2861                 }
2862                 data->last_end = data->pos_min + l;
2863                 data->pos_min += l; /* As in the first entry. */
2864                 data->flags &= ~SF_BEFORE_EOL;
2865             }
2866             if (flags & SCF_DO_STCLASS_AND) {
2867                 /* Check whether it is compatible with what we know already! */
2868                 int compat = 1;
2869
2870                 if (uc >= 0x100 ||
2871                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
2872                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
2873                     && (!(data->start_class->flags & ANYOF_FOLD)
2874                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
2875                     )
2876                     compat = 0;
2877                 ANYOF_CLASS_ZERO(data->start_class);
2878                 ANYOF_BITMAP_ZERO(data->start_class);
2879                 if (compat)
2880                     ANYOF_BITMAP_SET(data->start_class, uc);
2881                 data->start_class->flags &= ~ANYOF_EOS;
2882                 if (uc < 0x100)
2883                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
2884             }
2885             else if (flags & SCF_DO_STCLASS_OR) {
2886                 /* false positive possible if the class is case-folded */
2887                 if (uc < 0x100)
2888                     ANYOF_BITMAP_SET(data->start_class, uc);
2889                 else
2890                     data->start_class->flags |= ANYOF_UNICODE_ALL;
2891                 data->start_class->flags &= ~ANYOF_EOS;
2892                 cl_and(data->start_class, and_withp);
2893             }
2894             flags &= ~SCF_DO_STCLASS;
2895         }
2896         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
2897             I32 l = STR_LEN(scan);
2898             UV uc = *((U8*)STRING(scan));
2899
2900             /* Search for fixed substrings supports EXACT only. */
2901             if (flags & SCF_DO_SUBSTR) {
2902                 assert(data);
2903                 SCAN_COMMIT(pRExC_state, data, minlenp);
2904             }
2905             if (UTF) {
2906                 const U8 * const s = (U8 *)STRING(scan);
2907                 l = utf8_length(s, s + l);
2908                 uc = utf8_to_uvchr(s, NULL);
2909             }
2910             min += l;
2911             if (flags & SCF_DO_SUBSTR)
2912                 data->pos_min += l;
2913             if (flags & SCF_DO_STCLASS_AND) {
2914                 /* Check whether it is compatible with what we know already! */
2915                 int compat = 1;
2916
2917                 if (uc >= 0x100 ||
2918                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
2919                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
2920                      && !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
2921                     compat = 0;
2922                 ANYOF_CLASS_ZERO(data->start_class);
2923                 ANYOF_BITMAP_ZERO(data->start_class);
2924                 if (compat) {
2925                     ANYOF_BITMAP_SET(data->start_class, uc);
2926                     data->start_class->flags &= ~ANYOF_EOS;
2927                     data->start_class->flags |= ANYOF_FOLD;
2928                     if (OP(scan) == EXACTFL)
2929                         data->start_class->flags |= ANYOF_LOCALE;
2930                 }
2931             }
2932             else if (flags & SCF_DO_STCLASS_OR) {
2933                 if (data->start_class->flags & ANYOF_FOLD) {
2934                     /* false positive possible if the class is case-folded.
2935                        Assume that the locale settings are the same... */
2936                     if (uc < 0x100)
2937                         ANYOF_BITMAP_SET(data->start_class, uc);
2938                     data->start_class->flags &= ~ANYOF_EOS;
2939                 }
2940                 cl_and(data->start_class, and_withp);
2941             }
2942             flags &= ~SCF_DO_STCLASS;
2943         }
2944         else if (strchr((const char*)PL_varies,OP(scan))) {
2945             I32 mincount, maxcount, minnext, deltanext, fl = 0;
2946             I32 f = flags, pos_before = 0;
2947             regnode * const oscan = scan;
2948             struct regnode_charclass_class this_class;
2949             struct regnode_charclass_class *oclass = NULL;
2950             I32 next_is_eval = 0;
2951
2952             switch (PL_regkind[OP(scan)]) {
2953             case WHILEM:                /* End of (?:...)* . */
2954                 scan = NEXTOPER(scan);
2955                 goto finish;
2956             case PLUS:
2957                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
2958                     next = NEXTOPER(scan);
2959                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
2960                         mincount = 1;
2961                         maxcount = REG_INFTY;
2962                         next = regnext(scan);
2963                         scan = NEXTOPER(scan);
2964                         goto do_curly;
2965                     }
2966                 }
2967                 if (flags & SCF_DO_SUBSTR)
2968                     data->pos_min++;
2969                 min++;
2970                 /* Fall through. */
2971             case STAR:
2972                 if (flags & SCF_DO_STCLASS) {
2973                     mincount = 0;
2974                     maxcount = REG_INFTY;
2975                     next = regnext(scan);
2976                     scan = NEXTOPER(scan);
2977                     goto do_curly;
2978                 }
2979                 is_inf = is_inf_internal = 1;
2980                 scan = regnext(scan);
2981                 if (flags & SCF_DO_SUBSTR) {
2982                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
2983                     data->longest = &(data->longest_float);
2984                 }
2985                 goto optimize_curly_tail;
2986             case CURLY:
2987                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
2988                     && (scan->flags == stopparen))
2989                 {
2990                     mincount = 1;
2991                     maxcount = 1;
2992                 } else {
2993                     mincount = ARG1(scan);
2994                     maxcount = ARG2(scan);
2995                 }
2996                 next = regnext(scan);
2997                 if (OP(scan) == CURLYX) {
2998                     I32 lp = (data ? *(data->last_closep) : 0);
2999                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3000                 }
3001                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3002                 next_is_eval = (OP(scan) == EVAL);
3003               do_curly:
3004                 if (flags & SCF_DO_SUBSTR) {
3005                     if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3006                     pos_before = data->pos_min;
3007                 }
3008                 if (data) {
3009                     fl = data->flags;
3010                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3011                     if (is_inf)
3012                         data->flags |= SF_IS_INF;
3013                 }
3014                 if (flags & SCF_DO_STCLASS) {
3015                     cl_init(pRExC_state, &this_class);
3016                     oclass = data->start_class;
3017                     data->start_class = &this_class;
3018                     f |= SCF_DO_STCLASS_AND;
3019                     f &= ~SCF_DO_STCLASS_OR;
3020                 }
3021                 /* These are the cases when once a subexpression
3022                    fails at a particular position, it cannot succeed
3023                    even after backtracking at the enclosing scope.
3024                 
3025                    XXXX what if minimal match and we are at the
3026                         initial run of {n,m}? */
3027                 if ((mincount != maxcount - 1) && (maxcount != REG_INFTY))
3028                     f &= ~SCF_WHILEM_VISITED_POS;
3029
3030                 /* This will finish on WHILEM, setting scan, or on NULL: */
3031                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, 
3032                                       last, data, stopparen, recursed, NULL,
3033                                       (mincount == 0
3034                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3035
3036                 if (flags & SCF_DO_STCLASS)
3037                     data->start_class = oclass;
3038                 if (mincount == 0 || minnext == 0) {
3039                     if (flags & SCF_DO_STCLASS_OR) {
3040                         cl_or(pRExC_state, data->start_class, &this_class);
3041                     }
3042                     else if (flags & SCF_DO_STCLASS_AND) {
3043                         /* Switch to OR mode: cache the old value of
3044                          * data->start_class */
3045                         INIT_AND_WITHP;
3046                         StructCopy(data->start_class, and_withp,
3047                                    struct regnode_charclass_class);
3048                         flags &= ~SCF_DO_STCLASS_AND;
3049                         StructCopy(&this_class, data->start_class,
3050                                    struct regnode_charclass_class);
3051                         flags |= SCF_DO_STCLASS_OR;
3052                         data->start_class->flags |= ANYOF_EOS;
3053                     }
3054                 } else {                /* Non-zero len */
3055                     if (flags & SCF_DO_STCLASS_OR) {
3056                         cl_or(pRExC_state, data->start_class, &this_class);
3057                         cl_and(data->start_class, and_withp);
3058                     }
3059                     else if (flags & SCF_DO_STCLASS_AND)
3060                         cl_and(data->start_class, &this_class);
3061                     flags &= ~SCF_DO_STCLASS;
3062                 }
3063                 if (!scan)              /* It was not CURLYX, but CURLY. */
3064                     scan = next;
3065                 if ( /* ? quantifier ok, except for (?{ ... }) */
3066                     (next_is_eval || !(mincount == 0 && maxcount == 1))
3067                     && (minnext == 0) && (deltanext == 0)
3068                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3069                     && maxcount <= REG_INFTY/3 /* Complement check for big count */
3070                     && ckWARN(WARN_REGEXP))
3071                 {
3072                     vWARN(RExC_parse,
3073                           "Quantifier unexpected on zero-length expression");
3074                 }
3075
3076                 min += minnext * mincount;
3077                 is_inf_internal |= ((maxcount == REG_INFTY
3078                                      && (minnext + deltanext) > 0)
3079                                     || deltanext == I32_MAX);
3080                 is_inf |= is_inf_internal;
3081                 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3082
3083                 /* Try powerful optimization CURLYX => CURLYN. */
3084                 if (  OP(oscan) == CURLYX && data
3085                       && data->flags & SF_IN_PAR
3086                       && !(data->flags & SF_HAS_EVAL)
3087                       && !deltanext && minnext == 1 ) {
3088                     /* Try to optimize to CURLYN.  */
3089                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3090                     regnode * const nxt1 = nxt;
3091 #ifdef DEBUGGING
3092                     regnode *nxt2;
3093 #endif
3094
3095                     /* Skip open. */
3096                     nxt = regnext(nxt);
3097                     if (!strchr((const char*)PL_simple,OP(nxt))
3098                         && !(PL_regkind[OP(nxt)] == EXACT
3099                              && STR_LEN(nxt) == 1))
3100                         goto nogo;
3101 #ifdef DEBUGGING
3102                     nxt2 = nxt;
3103 #endif
3104                     nxt = regnext(nxt);
3105                     if (OP(nxt) != CLOSE)
3106                         goto nogo;
3107                     if (RExC_open_parens) {
3108                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3109                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3110                     }
3111                     /* Now we know that nxt2 is the only contents: */
3112                     oscan->flags = (U8)ARG(nxt);
3113                     OP(oscan) = CURLYN;
3114                     OP(nxt1) = NOTHING; /* was OPEN. */
3115
3116 #ifdef DEBUGGING
3117                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3118                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistancy. */
3119                     NEXT_OFF(nxt2) = 0; /* just for consistancy with CURLY. */
3120                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
3121                     OP(nxt + 1) = OPTIMIZED; /* was count. */
3122                     NEXT_OFF(nxt+ 1) = 0; /* just for consistancy. */
3123 #endif
3124                 }
3125               nogo:
3126
3127                 /* Try optimization CURLYX => CURLYM. */
3128                 if (  OP(oscan) == CURLYX && data
3129                       && !(data->flags & SF_HAS_PAR)
3130                       && !(data->flags & SF_HAS_EVAL)
3131                       && !deltanext     /* atom is fixed width */
3132                       && minnext != 0   /* CURLYM can't handle zero width */
3133                 ) {
3134                     /* XXXX How to optimize if data == 0? */
3135                     /* Optimize to a simpler form.  */
3136                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3137                     regnode *nxt2;
3138
3139                     OP(oscan) = CURLYM;
3140                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3141                             && (OP(nxt2) != WHILEM))
3142                         nxt = nxt2;
3143                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3144                     /* Need to optimize away parenths. */
3145                     if (data->flags & SF_IN_PAR) {
3146                         /* Set the parenth number.  */
3147                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3148
3149                         if (OP(nxt) != CLOSE)
3150                             FAIL("Panic opt close");
3151                         oscan->flags = (U8)ARG(nxt);
3152                         if (RExC_open_parens) {
3153                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3154                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3155                         }
3156                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
3157                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
3158
3159 #ifdef DEBUGGING
3160                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3161                         OP(nxt + 1) = OPTIMIZED; /* was count. */
3162                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistancy. */
3163                         NEXT_OFF(nxt + 1) = 0; /* just for consistancy. */
3164 #endif
3165 #if 0
3166                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
3167                             regnode *nnxt = regnext(nxt1);
3168                         
3169                             if (nnxt == nxt) {
3170                                 if (reg_off_by_arg[OP(nxt1)])
3171                                     ARG_SET(nxt1, nxt2 - nxt1);
3172                                 else if (nxt2 - nxt1 < U16_MAX)
3173                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
3174                                 else
3175                                     OP(nxt) = NOTHING;  /* Cannot beautify */
3176                             }
3177                             nxt1 = nnxt;
3178                         }
3179 #endif
3180                         /* Optimize again: */
3181                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3182                                     NULL, stopparen, recursed, NULL, 0,depth+1);
3183                     }
3184                     else
3185                         oscan->flags = 0;
3186                 }
3187                 else if ((OP(oscan) == CURLYX)
3188                          && (flags & SCF_WHILEM_VISITED_POS)
3189                          /* See the comment on a similar expression above.
3190                             However, this time it not a subexpression
3191                             we care about, but the expression itself. */
3192                          && (maxcount == REG_INFTY)
3193                          && data && ++data->whilem_c < 16) {
3194                     /* This stays as CURLYX, we can put the count/of pair. */
3195                     /* Find WHILEM (as in regexec.c) */
3196                     regnode *nxt = oscan + NEXT_OFF(oscan);
3197
3198                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
3199                         nxt += ARG(nxt);
3200                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
3201                         | (RExC_whilem_seen << 4)); /* On WHILEM */
3202                 }
3203                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
3204                     pars++;
3205                 if (flags & SCF_DO_SUBSTR) {
3206                     SV *last_str = NULL;
3207                     int counted = mincount != 0;
3208
3209                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
3210 #if defined(SPARC64_GCC_WORKAROUND)
3211                         I32 b = 0;
3212                         STRLEN l = 0;
3213                         const char *s = NULL;
3214                         I32 old = 0;
3215
3216                         if (pos_before >= data->last_start_min)
3217                             b = pos_before;
3218                         else
3219                             b = data->last_start_min;
3220
3221                         l = 0;
3222                         s = SvPV_const(data->last_found, l);
3223                         old = b - data->last_start_min;
3224
3225 #else
3226                         I32 b = pos_before >= data->last_start_min
3227                             ? pos_before : data->last_start_min;
3228                         STRLEN l;
3229                         const char * const s = SvPV_const(data->last_found, l);
3230                         I32 old = b - data->last_start_min;
3231 #endif
3232
3233                         if (UTF)
3234                             old = utf8_hop((U8*)s, old) - (U8*)s;
3235                         
3236                         l -= old;
3237                         /* Get the added string: */
3238                         last_str = newSVpvn(s  + old, l);
3239                         if (UTF)
3240                             SvUTF8_on(last_str);
3241                         if (deltanext == 0 && pos_before == b) {
3242                             /* What was added is a constant string */
3243                             if (mincount > 1) {
3244                                 SvGROW(last_str, (mincount * l) + 1);
3245                                 repeatcpy(SvPVX(last_str) + l,
3246                                           SvPVX_const(last_str), l, mincount - 1);
3247                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
3248                                 /* Add additional parts. */
3249                                 SvCUR_set(data->last_found,
3250                                           SvCUR(data->last_found) - l);
3251                                 sv_catsv(data->last_found, last_str);
3252                                 {
3253                                     SV * sv = data->last_found;
3254                                     MAGIC *mg =
3255                                         SvUTF8(sv) && SvMAGICAL(sv) ?
3256                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3257                                     if (mg && mg->mg_len >= 0)
3258                                         mg->mg_len += CHR_SVLEN(last_str);
3259                                 }
3260                                 data->last_end += l * (mincount - 1);
3261                             }
3262                         } else {
3263                             /* start offset must point into the last copy */
3264                             data->last_start_min += minnext * (mincount - 1);
3265                             data->last_start_max += is_inf ? I32_MAX
3266                                 : (maxcount - 1) * (minnext + data->pos_delta);
3267                         }
3268                     }
3269                     /* It is counted once already... */
3270                     data->pos_min += minnext * (mincount - counted);
3271                     data->pos_delta += - counted * deltanext +
3272                         (minnext + deltanext) * maxcount - minnext * mincount;
3273                     if (mincount != maxcount) {
3274                          /* Cannot extend fixed substrings found inside
3275                             the group.  */
3276                         SCAN_COMMIT(pRExC_state,data,minlenp);
3277                         if (mincount && last_str) {
3278                             SV * const sv = data->last_found;
3279                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3280                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3281
3282                             if (mg)
3283                                 mg->mg_len = -1;
3284                             sv_setsv(sv, last_str);
3285                             data->last_end = data->pos_min;
3286                             data->last_start_min =
3287                                 data->pos_min - CHR_SVLEN(last_str);
3288                             data->last_start_max = is_inf
3289                                 ? I32_MAX
3290                                 : data->pos_min + data->pos_delta
3291                                 - CHR_SVLEN(last_str);
3292                         }
3293                         data->longest = &(data->longest_float);
3294                     }
3295                     SvREFCNT_dec(last_str);
3296                 }
3297                 if (data && (fl & SF_HAS_EVAL))
3298                     data->flags |= SF_HAS_EVAL;
3299               optimize_curly_tail:
3300                 if (OP(oscan) != CURLYX) {
3301                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
3302                            && NEXT_OFF(next))
3303                         NEXT_OFF(oscan) += NEXT_OFF(next);
3304                 }
3305                 continue;
3306             default:                    /* REF and CLUMP only? */
3307                 if (flags & SCF_DO_SUBSTR) {
3308                     SCAN_COMMIT(pRExC_state,data,minlenp);      /* Cannot expect anything... */
3309                     data->longest = &(data->longest_float);
3310                 }
3311                 is_inf = is_inf_internal = 1;
3312                 if (flags & SCF_DO_STCLASS_OR)
3313                     cl_anything(pRExC_state, data->start_class);
3314                 flags &= ~SCF_DO_STCLASS;
3315                 break;
3316             }
3317         }
3318         else if (strchr((const char*)PL_simple,OP(scan))) {
3319             int value = 0;
3320
3321             if (flags & SCF_DO_SUBSTR) {
3322                 SCAN_COMMIT(pRExC_state,data,minlenp);
3323                 data->pos_min++;
3324             }
3325             min++;
3326             if (flags & SCF_DO_STCLASS) {
3327                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3328
3329                 /* Some of the logic below assumes that switching
3330                    locale on will only add false positives. */
3331                 switch (PL_regkind[OP(scan)]) {
3332                 case SANY:
3333                 default:
3334                   do_default:
3335                     /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
3336                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3337                         cl_anything(pRExC_state, data->start_class);
3338                     break;
3339                 case REG_ANY:
3340                     if (OP(scan) == SANY)
3341                         goto do_default;
3342                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
3343                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
3344                                  || (data->start_class->flags & ANYOF_CLASS));
3345                         cl_anything(pRExC_state, data->start_class);
3346                     }
3347                     if (flags & SCF_DO_STCLASS_AND || !value)
3348                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
3349                     break;
3350                 case ANYOF:
3351                     if (flags & SCF_DO_STCLASS_AND)
3352                         cl_and(data->start_class,
3353                                (struct regnode_charclass_class*)scan);
3354                     else
3355                         cl_or(pRExC_state, data->start_class,
3356                               (struct regnode_charclass_class*)scan);
3357                     break;
3358                 case ALNUM:
3359                     if (flags & SCF_DO_STCLASS_AND) {
3360                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3361                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
3362                             for (value = 0; value < 256; value++)
3363                                 if (!isALNUM(value))
3364                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3365                         }
3366                     }
3367                     else {
3368                         if (data->start_class->flags & ANYOF_LOCALE)
3369                             ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
3370                         else {
3371                             for (value = 0; value < 256; value++)
3372                                 if (isALNUM(value))
3373                                     ANYOF_BITMAP_SET(data->start_class, value);                 
3374                         }
3375                     }
3376                     break;
3377                 case ALNUML:
3378                     if (flags & SCF_DO_STCLASS_AND) {
3379                         if (data->start_class->flags & ANYOF_LOCALE)
3380                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
3381                     }
3382                     else {
3383                         ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
3384                         data->start_class->flags |= ANYOF_LOCALE;
3385                     }
3386                     break;
3387                 case NALNUM:
3388                     if (flags & SCF_DO_STCLASS_AND) {
3389                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3390                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
3391                             for (value = 0; value < 256; value++)
3392                                 if (isALNUM(value))
3393                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3394                         }
3395                     }
3396                     else {
3397                         if (data->start_class->flags & ANYOF_LOCALE)
3398                             ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
3399                         else {
3400                             for (value = 0; value < 256; value++)
3401                                 if (!isALNUM(value))
3402                                     ANYOF_BITMAP_SET(data->start_class, value);                 
3403                         }
3404                     }
3405                     break;
3406                 case NALNUML:
3407                     if (flags & SCF_DO_STCLASS_AND) {
3408                         if (data->start_class->flags & ANYOF_LOCALE)
3409                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
3410                     }
3411                     else {
3412                         data->start_class->flags |= ANYOF_LOCALE;
3413                         ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
3414                     }
3415                     break;
3416                 case SPACE:
3417                     if (flags & SCF_DO_STCLASS_AND) {
3418                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3419                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
3420                             for (value = 0; value < 256; value++)
3421                                 if (!isSPACE(value))
3422                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3423                         }
3424                     }
3425                     else {
3426                         if (data->start_class->flags & ANYOF_LOCALE)
3427                             ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
3428                         else {
3429                             for (value = 0; value < 256; value++)
3430                                 if (isSPACE(value))
3431                                     ANYOF_BITMAP_SET(data->start_class, value);                 
3432                         }
3433                     }
3434                     break;
3435                 case SPACEL:
3436                     if (flags & SCF_DO_STCLASS_AND) {
3437                         if (data->start_class->flags & ANYOF_LOCALE)
3438                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
3439                     }
3440                     else {
3441                         data->start_class->flags |= ANYOF_LOCALE;
3442                         ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
3443                     }
3444                     break;
3445                 case NSPACE:
3446                     if (flags & SCF_DO_STCLASS_AND) {
3447                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3448                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
3449                             for (value = 0; value < 256; value++)
3450                                 if (isSPACE(value))
3451                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3452                         }
3453                     }
3454                     else {
3455                         if (data->start_class->flags & ANYOF_LOCALE)
3456                             ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
3457                         else {
3458                             for (value = 0; value < 256; value++)
3459                                 if (!isSPACE(value))
3460                                     ANYOF_BITMAP_SET(data->start_class, value);                 
3461                         }
3462                     }
3463                     break;
3464                 case NSPACEL:
3465                     if (flags & SCF_DO_STCLASS_AND) {
3466                         if (data->start_class->flags & ANYOF_LOCALE) {
3467                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
3468                             for (value = 0; value < 256; value++)
3469                                 if (!isSPACE(value))
3470                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3471                         }
3472                     }
3473                     else {
3474                         data->start_class->flags |= ANYOF_LOCALE;
3475                         ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
3476                     }
3477                     break;
3478                 case DIGIT:
3479                     if (flags & SCF_DO_STCLASS_AND) {
3480                         ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
3481                         for (value = 0; value < 256; value++)
3482                             if (!isDIGIT(value))
3483                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
3484                     }
3485                     else {
3486                         if (data->start_class->flags & ANYOF_LOCALE)
3487                             ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
3488                         else {
3489                             for (value = 0; value < 256; value++)
3490                                 if (isDIGIT(value))
3491                                     ANYOF_BITMAP_SET(data->start_class, value);                 
3492                         }
3493                     }
3494                     break;
3495                 case NDIGIT:
3496                     if (flags & SCF_DO_STCLASS_AND) {
3497                         ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
3498                         for (value = 0; value < 256; value++)
3499                             if (isDIGIT(value))
3500                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
3501                     }
3502                     else {
3503                         if (data->start_class->flags & ANYOF_LOCALE)
3504                             ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
3505                         else {
3506                             for (value = 0; value < 256; value++)
3507                                 if (!isDIGIT(value))
3508                                     ANYOF_BITMAP_SET(data->start_class, value);                 
3509                         }
3510                     }
3511                     break;
3512                 }
3513                 if (flags & SCF_DO_STCLASS_OR)
3514                     cl_and(data->start_class, and_withp);
3515                 flags &= ~SCF_DO_STCLASS;
3516             }
3517         }
3518         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
3519             data->flags |= (OP(scan) == MEOL
3520                             ? SF_BEFORE_MEOL
3521                             : SF_BEFORE_SEOL);
3522         }
3523         else if (  PL_regkind[OP(scan)] == BRANCHJ
3524                  /* Lookbehind, or need to calculate parens/evals/stclass: */
3525                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
3526                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
3527             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY 
3528                 || OP(scan) == UNLESSM )
3529             {
3530                 /* Negative Lookahead/lookbehind
3531                    In this case we can't do fixed string optimisation.
3532                 */
3533
3534                 I32 deltanext, minnext, fake = 0;
3535                 regnode *nscan;
3536                 struct regnode_charclass_class intrnl;
3537                 int f = 0;
3538
3539                 data_fake.flags = 0;
3540                 if (data) {
3541                     data_fake.whilem_c = data->whilem_c;
3542                     data_fake.last_closep = data->last_closep;
3543                 }
3544                 else
3545                     data_fake.last_closep = &fake;
3546                 data_fake.pos_delta = delta;
3547                 if ( flags & SCF_DO_STCLASS && !scan->flags
3548                      && OP(scan) == IFMATCH ) { /* Lookahead */
3549                     cl_init(pRExC_state, &intrnl);
3550                     data_fake.start_class = &intrnl;
3551                     f |= SCF_DO_STCLASS_AND;
3552                 }
3553                 if (flags & SCF_WHILEM_VISITED_POS)
3554                     f |= SCF_WHILEM_VISITED_POS;
3555                 next = regnext(scan);
3556                 nscan = NEXTOPER(NEXTOPER(scan));
3557                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, 
3558                     last, &data_fake, stopparen, recursed, NULL, f, depth+1);
3559                 if (scan->flags) {
3560                     if (deltanext) {
3561                         FAIL("Variable length lookbehind not implemented");
3562                     }
3563                     else if (minnext > (I32)U8_MAX) {
3564                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
3565                     }
3566                     scan->flags = (U8)minnext;
3567                 }
3568                 if (data) {
3569                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3570                         pars++;
3571                     if (data_fake.flags & SF_HAS_EVAL)
3572                         data->flags |= SF_HAS_EVAL;
3573                     data->whilem_c = data_fake.whilem_c;
3574                 }
3575                 if (f & SCF_DO_STCLASS_AND) {
3576                     const int was = (data->start_class->flags & ANYOF_EOS);
3577
3578                     cl_and(data->start_class, &intrnl);
3579                     if (was)
3580                         data->start_class->flags |= ANYOF_EOS;
3581                 }
3582             }
3583 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
3584             else {
3585                 /* Positive Lookahead/lookbehind
3586                    In this case we can do fixed string optimisation,
3587                    but we must be careful about it. Note in the case of
3588                    lookbehind the positions will be offset by the minimum
3589                    length of the pattern, something we won't know about
3590                    until after the recurse.
3591                 */
3592                 I32 deltanext, fake = 0;
3593                 regnode *nscan;
3594                 struct regnode_charclass_class intrnl;
3595                 int f = 0;
3596                 /* We use SAVEFREEPV so that when the full compile 
3597                     is finished perl will clean up the allocated 
3598                     minlens when its all done. This was we don't
3599                     have to worry about freeing them when we know
3600                     they wont be used, which would be a pain.
3601                  */
3602                 I32 *minnextp;
3603                 Newx( minnextp, 1, I32 );
3604                 SAVEFREEPV(minnextp);
3605
3606                 if (data) {
3607                     StructCopy(data, &data_fake, scan_data_t);
3608                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
3609                         f |= SCF_DO_SUBSTR;
3610                         if (scan->flags) 
3611                             SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
3612                         data_fake.last_found=newSVsv(data->last_found);
3613                     }
3614                 }
3615                 else
3616                     data_fake.last_closep = &fake;
3617                 data_fake.flags = 0;
3618                 data_fake.pos_delta = delta;
3619                 if (is_inf)
3620                     data_fake.flags |= SF_IS_INF;
3621                 if ( flags & SCF_DO_STCLASS && !scan->flags
3622                      && OP(scan) == IFMATCH ) { /* Lookahead */
3623                     cl_init(pRExC_state, &intrnl);
3624                     data_fake.start_class = &intrnl;
3625                     f |= SCF_DO_STCLASS_AND;
3626                 }
3627                 if (flags & SCF_WHILEM_VISITED_POS)
3628                     f |= SCF_WHILEM_VISITED_POS;
3629                 next = regnext(scan);
3630                 nscan = NEXTOPER(NEXTOPER(scan));
3631
3632                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, 
3633                     last, &data_fake, stopparen, recursed, NULL, f,depth+1);
3634                 if (scan->flags) {
3635                     if (deltanext) {
3636                         FAIL("Variable length lookbehind not implemented");
3637                     }
3638                     else if (*minnextp > (I32)U8_MAX) {
3639                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
3640                     }
3641                     scan->flags = (U8)*minnextp;
3642                 }
3643
3644                 *minnextp += min;
3645
3646                 if (f & SCF_DO_STCLASS_AND) {
3647                     const int was = (data->start_class->flags & ANYOF_EOS);
3648
3649                     cl_and(data->start_class, &intrnl);
3650                     if (was)
3651                         data->start_class->flags |= ANYOF_EOS;
3652                 }
3653                 if (data) {
3654                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3655                         pars++;
3656                     if (data_fake.flags & SF_HAS_EVAL)
3657                         data->flags |= SF_HAS_EVAL;
3658                     data->whilem_c = data_fake.whilem_c;
3659                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
3660                         if (RExC_rx->minlen<*minnextp)
3661                             RExC_rx->minlen=*minnextp;
3662                         SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
3663                         SvREFCNT_dec(data_fake.last_found);
3664                         
3665                         if ( data_fake.minlen_fixed != minlenp ) 
3666                         {
3667                             data->offset_fixed= data_fake.offset_fixed;
3668                             data->minlen_fixed= data_fake.minlen_fixed;
3669                             data->lookbehind_fixed+= scan->flags;
3670                         }
3671                         if ( data_fake.minlen_float != minlenp )
3672                         {
3673                             data->minlen_float= data_fake.minlen_float;
3674                             data->offset_float_min=data_fake.offset_float_min;
3675                             data->offset_float_max=data_fake.offset_float_max;
3676                             data->lookbehind_float+= scan->flags;
3677                         }
3678                     }
3679                 }
3680
3681
3682             }
3683 #endif
3684         }
3685         else if (OP(scan) == OPEN) {
3686             if (stopparen != (I32)ARG(scan))
3687                 pars++;
3688         }
3689         else if (OP(scan) == CLOSE) {
3690             if (stopparen == (I32)ARG(scan)) {
3691                 break;
3692             }
3693             if ((I32)ARG(scan) == is_par) {
3694                 next = regnext(scan);
3695
3696                 if ( next && (OP(next) != WHILEM) && next < last)
3697                     is_par = 0;         /* Disable optimization */
3698             }
3699             if (data)
3700                 *(data->last_closep) = ARG(scan);
3701         }
3702         else if (OP(scan) == EVAL) {
3703                 if (data)
3704                     data->flags |= SF_HAS_EVAL;
3705         }
3706         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
3707             if (flags & SCF_DO_SUBSTR) {
3708                 SCAN_COMMIT(pRExC_state,data,minlenp);
3709                 flags &= ~SCF_DO_SUBSTR;
3710             }
3711             if (data && OP(scan)==ACCEPT) {
3712                 data->flags |= SCF_SEEN_ACCEPT;
3713                 if (stopmin > min)
3714                     stopmin = min;
3715             }
3716         }
3717         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
3718         {
3719                 if (flags & SCF_DO_SUBSTR) {
3720                     SCAN_COMMIT(pRExC_state,data,minlenp);
3721                     data->longest = &(data->longest_float);
3722                 }
3723                 is_inf = is_inf_internal = 1;
3724                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3725                     cl_anything(pRExC_state, data->start_class);
3726                 flags &= ~SCF_DO_STCLASS;
3727         }
3728         else if (OP(scan) == GPOS) {
3729             if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
3730                 !(delta || is_inf || (data && data->pos_delta))) 
3731             {
3732                 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
3733                     RExC_rx->extflags |= RXf_ANCH_GPOS;
3734                 if (RExC_rx->gofs < (U32)min)
3735                     RExC_rx->gofs = min;
3736             } else {
3737                 RExC_rx->extflags |= RXf_GPOS_FLOAT;
3738                 RExC_rx->gofs = 0;
3739             }       
3740         }
3741 #ifdef TRIE_STUDY_OPT
3742 #ifdef FULL_TRIE_STUDY
3743         else if (PL_regkind[OP(scan)] == TRIE) {
3744             /* NOTE - There is similar code to this block above for handling
3745                BRANCH nodes on the initial study.  If you change stuff here
3746                check there too. */
3747             regnode *trie_node= scan;
3748             regnode *tail= regnext(scan);
3749             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
3750             I32 max1 = 0, min1 = I32_MAX;
3751             struct regnode_charclass_class accum;
3752
3753             if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
3754                 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
3755             if (flags & SCF_DO_STCLASS)
3756                 cl_init_zero(pRExC_state, &accum);
3757                 
3758             if (!trie->jump) {
3759                 min1= trie->minlen;
3760                 max1= trie->maxlen;
3761             } else {
3762                 const regnode *nextbranch= NULL;
3763                 U32 word;
3764                 
3765                 for ( word=1 ; word <= trie->wordcount ; word++) 
3766                 {
3767                     I32 deltanext=0, minnext=0, f = 0, fake;
3768                     struct regnode_charclass_class this_class;
3769                     
3770                     data_fake.flags = 0;
3771                     if (data) {
3772                         data_fake.whilem_c = data->whilem_c;
3773                         data_fake.last_closep = data->last_closep;
3774                     }
3775                     else
3776                         data_fake.last_closep = &fake;
3777                     data_fake.pos_delta = delta;
3778                     if (flags & SCF_DO_STCLASS) {
3779                         cl_init(pRExC_state, &this_class);
3780                         data_fake.start_class = &this_class;
3781                         f = SCF_DO_STCLASS_AND;
3782                     }
3783                     if (flags & SCF_WHILEM_VISITED_POS)
3784                         f |= SCF_WHILEM_VISITED_POS;
3785     
3786                     if (trie->jump[word]) {
3787                         if (!nextbranch)
3788                             nextbranch = trie_node + trie->jump[0];
3789                         scan= trie_node + trie->jump[word];
3790                         /* We go from the jump point to the branch that follows
3791                            it. Note this means we need the vestigal unused branches
3792                            even though they arent otherwise used.
3793                          */
3794                         minnext = study_chunk(pRExC_state, &scan, minlenp, 
3795                             &deltanext, (regnode *)nextbranch, &data_fake, 
3796                             stopparen, recursed, NULL, f,depth+1);
3797                     }
3798                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
3799                         nextbranch= regnext((regnode*)nextbranch);
3800                     
3801                     if (min1 > (I32)(minnext + trie->minlen))
3802                         min1 = minnext + trie->minlen;
3803                     if (max1 < (I32)(minnext + deltanext + trie->maxlen))
3804                         max1 = minnext + deltanext + trie->maxlen;
3805                     if (deltanext == I32_MAX)
3806                         is_inf = is_inf_internal = 1;
3807                     
3808                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3809                         pars++;
3810                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
3811                         if ( stopmin > min + min1) 
3812                             stopmin = min + min1;
3813                         flags &= ~SCF_DO_SUBSTR;
3814                         if (data)
3815                             data->flags |= SCF_SEEN_ACCEPT;
3816                     }
3817                     if (data) {
3818                         if (data_fake.flags & SF_HAS_EVAL)
3819                             data->flags |= SF_HAS_EVAL;
3820                         data->whilem_c = data_fake.whilem_c;
3821                     }
3822                     if (flags & SCF_DO_STCLASS)
3823                         cl_or(pRExC_state, &accum, &this_class);
3824                 }
3825             }
3826             if (flags & SCF_DO_SUBSTR) {
3827                 data->pos_min += min1;
3828                 data->pos_delta += max1 - min1;
3829                 if (max1 != min1 || is_inf)
3830                     data->longest = &(data->longest_float);
3831             }
3832             min += min1;
3833             delta += max1 - min1;
3834             if (flags & SCF_DO_STCLASS_OR) {
3835                 cl_or(pRExC_state, data->start_class, &accum);
3836                 if (min1) {
3837                     cl_and(data->start_class, and_withp);
3838                     flags &= ~SCF_DO_STCLASS;
3839                 }
3840             }
3841             else if (flags & SCF_DO_STCLASS_AND) {
3842                 if (min1) {
3843                     cl_and(data->start_class, &accum);
3844                     flags &= ~SCF_DO_STCLASS;
3845                 }
3846                 else {
3847                     /* Switch to OR mode: cache the old value of
3848                      * data->start_class */
3849                     INIT_AND_WITHP;
3850                     StructCopy(data->start_class, and_withp,
3851                                struct regnode_charclass_class);
3852                     flags &= ~SCF_DO_STCLASS_AND;
3853                     StructCopy(&accum, data->start_class,
3854                                struct regnode_charclass_class);
3855                     flags |= SCF_DO_STCLASS_OR;
3856                     data->start_class->flags |= ANYOF_EOS;
3857                 }
3858             }
3859             scan= tail;
3860             continue;
3861         }
3862 #else
3863         else if (PL_regkind[OP(scan)] == TRIE) {
3864             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
3865             U8*bang=NULL;
3866             
3867             min += trie->minlen;
3868             delta += (trie->maxlen - trie->minlen);
3869             flags &= ~SCF_DO_STCLASS; /* xxx */
3870             if (flags & SCF_DO_SUBSTR) {
3871                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
3872                 data->pos_min += trie->minlen;
3873                 data->pos_delta += (trie->maxlen - trie->minlen);
3874                 if (trie->maxlen != trie->minlen)
3875                     data->longest = &(data->longest_float);
3876             }
3877             if (trie->jump) /* no more substrings -- for now /grr*/
3878                 flags &= ~SCF_DO_SUBSTR; 
3879         }
3880 #endif /* old or new */
3881 #endif /* TRIE_STUDY_OPT */     
3882         /* Else: zero-length, ignore. */
3883         scan = regnext(scan);
3884     }
3885     if (frame) {
3886         last = frame->last;
3887         scan = frame->next;
3888         stopparen = frame->stop;
3889         frame = frame->prev;
3890         goto fake_study_recurse;
3891     }
3892
3893   finish:
3894     assert(!frame);
3895     DEBUG_STUDYDATA("pre-fin:",data,depth);
3896
3897     *scanp = scan;
3898     *deltap = is_inf_internal ? I32_MAX : delta;
3899     if (flags & SCF_DO_SUBSTR && is_inf)
3900         data->pos_delta = I32_MAX - data->pos_min;
3901     if (is_par > (I32)U8_MAX)
3902         is_par = 0;
3903     if (is_par && pars==1 && data) {
3904         data->flags |= SF_IN_PAR;
3905         data->flags &= ~SF_HAS_PAR;
3906     }
3907     else if (pars && data) {
3908         data->flags |= SF_HAS_PAR;
3909         data->flags &= ~SF_IN_PAR;
3910     }
3911     if (flags & SCF_DO_STCLASS_OR)
3912         cl_and(data->start_class, and_withp);
3913     if (flags & SCF_TRIE_RESTUDY)
3914         data->flags |=  SCF_TRIE_RESTUDY;
3915     
3916     DEBUG_STUDYDATA("post-fin:",data,depth);
3917     
3918     return min < stopmin ? min : stopmin;
3919 }
3920
3921 STATIC U32
3922 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
3923 {
3924     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
3925
3926     Renewc(RExC_rxi->data,
3927            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
3928            char, struct reg_data);
3929     if(count)
3930         Renew(RExC_rxi->data->what, count + n, U8);
3931     else
3932         Newx(RExC_rxi->data->what, n, U8);
3933     RExC_rxi->data->count = count + n;
3934     Copy(s, RExC_rxi->data->what + count, n, U8);
3935     return count;
3936 }
3937
3938 /*XXX: todo make this not included in a non debugging perl */
3939 #ifndef PERL_IN_XSUB_RE
3940 void
3941 Perl_reginitcolors(pTHX)
3942 {
3943     dVAR;
3944     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
3945     if (s) {
3946         char *t = savepv(s);
3947         int i = 0;
3948         PL_colors[0] = t;
3949         while (++i < 6) {
3950             t = strchr(t, '\t');
3951             if (t) {
3952                 *t = '\0';
3953                 PL_colors[i] = ++t;
3954             }
3955             else
3956                 PL_colors[i] = t = (char *)"";
3957         }
3958     } else {
3959         int i = 0;
3960         while (i < 6)
3961             PL_colors[i++] = (char *)"";
3962     }
3963     PL_colorset = 1;
3964 }
3965 #endif
3966
3967
3968 #ifdef TRIE_STUDY_OPT
3969 #define CHECK_RESTUDY_GOTO                                  \
3970         if (                                                \
3971               (data.flags & SCF_TRIE_RESTUDY)               \
3972               && ! restudied++                              \
3973         )     goto reStudy
3974 #else
3975 #define CHECK_RESTUDY_GOTO
3976 #endif        
3977
3978 /*
3979  - pregcomp - compile a regular expression into internal code
3980  *
3981  * We can't allocate space until we know how big the compiled form will be,
3982  * but we can't compile it (and thus know how big it is) until we've got a
3983  * place to put the code.  So we cheat:  we compile it twice, once with code
3984  * generation turned off and size counting turned on, and once "for real".
3985  * This also means that we don't allocate space until we are sure that the
3986  * thing really will compile successfully, and we never have to move the
3987  * code and thus invalidate pointers into it.  (Note that it has to be in
3988  * one piece because free() must be able to free it all.) [NB: not true in perl]
3989  *
3990  * Beware that the optimization-preparation code in here knows about some
3991  * of the structure of the compiled regexp.  [I'll say.]
3992  */
3993
3994
3995
3996 #ifndef PERL_IN_XSUB_RE
3997 #define RE_ENGINE_PTR &PL_core_reg_engine
3998 #else
3999 extern const struct regexp_engine my_reg_engine;
4000 #define RE_ENGINE_PTR &my_reg_engine
4001 #endif
4002
4003 #ifndef PERL_IN_XSUB_RE 
4004 regexp *
4005 Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
4006 {
4007     dVAR;
4008     HV * const table = GvHV(PL_hintgv);
4009     /* Dispatch a request to compile a regexp to correct 
4010        regexp engine. */
4011     if (table) {
4012         SV **ptr= hv_fetchs(table, "regcomp", FALSE);
4013         GET_RE_DEBUG_FLAGS_DECL;
4014         if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
4015             const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
4016             DEBUG_COMPILE_r({
4017                 PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4018                     SvIV(*ptr));
4019             });            
4020             return CALLREGCOMP_ENG(eng, exp, xend, pm);
4021         } 
4022     }
4023     return Perl_re_compile(aTHX_ exp, xend, pm);
4024 }
4025 #endif
4026
4027 regexp *
4028 Perl_re_compile(pTHX_ char *exp, char *xend, PMOP *pm)
4029 {
4030     dVAR;
4031     register regexp *r;
4032     register regexp_internal *ri;
4033     regnode *scan;
4034     regnode *first;
4035     I32 flags;
4036     I32 minlen = 0;
4037     I32 sawplus = 0;
4038     I32 sawopen = 0;
4039     scan_data_t data;
4040     RExC_state_t RExC_state;
4041     RExC_state_t * const pRExC_state = &RExC_state;
4042 #ifdef TRIE_STUDY_OPT    
4043     int restudied= 0;
4044     RExC_state_t copyRExC_state;
4045 #endif    
4046     GET_RE_DEBUG_FLAGS_DECL;
4047     DEBUG_r(if (!PL_colorset) reginitcolors());
4048         
4049     if (exp == NULL)
4050         FAIL("NULL regexp argument");
4051
4052     RExC_utf8 = pm->op_pmdynflags & PMdf_CMP_UTF8;
4053
4054     RExC_precomp = exp;
4055     DEBUG_COMPILE_r({
4056         SV *dsv= sv_newmortal();
4057         RE_PV_QUOTED_DECL(s, RExC_utf8,
4058             dsv, RExC_precomp, (xend - exp), 60);
4059         PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
4060                        PL_colors[4],PL_colors[5],s);
4061     });
4062     RExC_flags = pm->op_pmflags;
4063     RExC_sawback = 0;
4064
4065     RExC_seen = 0;
4066     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
4067     RExC_seen_evals = 0;
4068     RExC_extralen = 0;
4069
4070     /* First pass: determine size, legality. */
4071     RExC_parse = exp;
4072     RExC_start = exp;
4073     RExC_end = xend;
4074     RExC_naughty = 0;
4075     RExC_npar = 1;
4076     RExC_nestroot = 0;
4077     RExC_size = 0L;
4078     RExC_emit = &PL_regdummy;
4079     RExC_whilem_seen = 0;
4080     RExC_charnames = NULL;
4081     RExC_open_parens = NULL;
4082     RExC_close_parens = NULL;
4083     RExC_opend = NULL;
4084     RExC_paren_names = NULL;
4085 #ifdef DEBUGGING
4086     RExC_paren_name_list = NULL;
4087 #endif
4088     RExC_recurse = NULL;
4089     RExC_recurse_count = 0;
4090
4091 #if 0 /* REGC() is (currently) a NOP at the first pass.
4092        * Clever compilers notice this and complain. --jhi */
4093     REGC((U8)REG_MAGIC, (char*)RExC_emit);
4094 #endif
4095     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n"));
4096     if (reg(pRExC_state, 0, &flags,1) == NULL) {
4097         RExC_precomp = NULL;
4098         return(NULL);
4099     }
4100     DEBUG_PARSE_r({
4101         PerlIO_printf(Perl_debug_log, 
4102             "Required size %"IVdf" nodes\n"
4103             "Starting second pass (creation)\n", 
4104             (IV)RExC_size);
4105         RExC_lastnum=0; 
4106         RExC_lastparse=NULL; 
4107     });
4108     /* Small enough for pointer-storage convention?
4109        If extralen==0, this means that we will not need long jumps. */
4110     if (RExC_size >= 0x10000L && RExC_extralen)
4111         RExC_size += RExC_extralen;
4112     else
4113         RExC_extralen = 0;
4114     if (RExC_whilem_seen > 15)
4115         RExC_whilem_seen = 15;
4116
4117 #ifdef DEBUGGING
4118     /* Make room for a sentinel value at the end of the program */
4119     RExC_size++;
4120 #endif
4121
4122     /* Allocate space and zero-initialize. Note, the two step process 
4123        of zeroing when in debug mode, thus anything assigned has to 
4124        happen after that */
4125     Newxz(r, 1, regexp);
4126     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
4127          char, regexp_internal);
4128     if ( r == NULL || ri == NULL )
4129         FAIL("Regexp out of space");
4130 #ifdef DEBUGGING
4131     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
4132     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
4133 #else 
4134     /* bulk initialize base fields with 0. */
4135     Zero(ri, sizeof(regexp_internal), char);        
4136 #endif
4137
4138     /* non-zero initialization begins here */
4139     RXi_SET( r, ri );
4140     r->engine= RE_ENGINE_PTR;
4141     r->refcnt = 1;
4142     r->prelen = xend - exp;
4143     r->extflags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4144     {
4145         bool has_k     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
4146         bool has_minus = ((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD);
4147         bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
4148         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD) >> 12);
4149         const char *fptr = STD_PAT_MODS;        /*"msix"*/
4150         char *p;
4151         r->wraplen = r->prelen + has_minus + has_k + has_runon
4152             + (sizeof(STD_PAT_MODS) - 1)
4153             + (sizeof("(?:)") - 1);
4154
4155         Newx(r->wrapped, r->wraplen, char );
4156         p = r->wrapped;
4157         *p++='('; *p++='?';
4158         if (has_k)
4159             *p++ = KEEPCOPY_PAT_MOD; /*'k'*/
4160         {
4161             char *r = p + (sizeof(STD_PAT_MODS) - 1) + has_minus - 1;
4162             char *colon = r + 1;
4163             char ch;
4164
4165             while((ch = *fptr++)) {
4166                 if(reganch & 1)
4167                     *p++ = ch;
4168                 else
4169                     *r-- = ch;
4170                 reganch >>= 1;
4171             }
4172             if(has_minus) {
4173                 *r = '-';
4174                 p = colon;
4175             }
4176         }
4177
4178         *p++=':';
4179         Copy(RExC_precomp, p, r->prelen, char);
4180         r->precomp = p;
4181         p += r->prelen;
4182         if (has_runon)
4183             *p++='\n';
4184         *p=')';
4185     }
4186
4187     r->intflags = 0;
4188     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
4189     
4190     if (RExC_seen & REG_SEEN_RECURSE) {
4191         Newxz(RExC_open_parens, RExC_npar,regnode *);
4192         SAVEFREEPV(RExC_open_parens);
4193         Newxz(RExC_close_parens,RExC_npar,regnode *);
4194         SAVEFREEPV(RExC_close_parens);
4195     }
4196
4197     /* Useful during FAIL. */
4198 #ifdef RE_TRACK_PATTERN_OFFSETS
4199     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
4200     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
4201                           "%s %"UVuf" bytes for offset annotations.\n",
4202                           ri->u.offsets ? "Got" : "Couldn't get",
4203                           (UV)((2*RExC_size+1) * sizeof(U32))));
4204 #endif
4205     SetProgLen(ri,RExC_size);
4206     RExC_rx = r;
4207     RExC_rxi = ri;
4208
4209     /* Second pass: emit code. */
4210     RExC_flags = pm->op_pmflags;        /* don't let top level (?i) bleed */
4211     RExC_parse = exp;
4212     RExC_end = xend;
4213     RExC_naughty = 0;
4214     RExC_npar = 1;
4215     RExC_emit_start = ri->program;
4216     RExC_emit = ri->program;
4217 #ifdef DEBUGGING
4218     /* put a sentinal on the end of the program so we can check for
4219        overwrites */
4220     ri->program[RExC_size].type = 255;
4221 #endif
4222     /* Store the count of eval-groups for security checks: */
4223     RExC_rx->seen_evals = RExC_seen_evals;
4224     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
4225     if (reg(pRExC_state, 0, &flags,1) == NULL)
4226         return(NULL);
4227
4228     /* XXXX To minimize changes to RE engine we always allocate
4229        3-units-long substrs field. */
4230     Newx(r->substrs, 1, struct reg_substr_data);
4231     if (RExC_recurse_count) {
4232         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
4233         SAVEFREEPV(RExC_recurse);
4234     }
4235
4236 reStudy:
4237     r->minlen = minlen = sawplus = sawopen = 0;
4238     Zero(r->substrs, 1, struct reg_substr_data);
4239
4240 #ifdef TRIE_STUDY_OPT
4241     if ( restudied ) {
4242         U32 seen=RExC_seen;
4243         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
4244         
4245         RExC_state = copyRExC_state;
4246         if (seen & REG_TOP_LEVEL_BRANCHES) 
4247             RExC_seen |= REG_TOP_LEVEL_BRANCHES;
4248         else
4249             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
4250         if (data.last_found) {
4251             SvREFCNT_dec(data.longest_fixed);
4252             SvREFCNT_dec(data.longest_float);
4253             SvREFCNT_dec(data.last_found);
4254         }
4255         StructCopy(&zero_scan_data, &data, scan_data_t);
4256     } else {
4257         StructCopy(&zero_scan_data, &data, scan_data_t);
4258         copyRExC_state = RExC_state;
4259     }
4260 #else
4261     StructCopy(&zero_scan_data, &data, scan_data_t);
4262 #endif    
4263
4264     /* Dig out information for optimizations. */
4265     r->extflags = pm->op_pmflags & RXf_PMf_COMPILETIME; /* Again? */
4266     pm->op_pmflags = RExC_flags;
4267     if (UTF)
4268         r->extflags |= RXf_UTF8;        /* Unicode in it? */
4269     ri->regstclass = NULL;
4270     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
4271         r->intflags |= PREGf_NAUGHTY;
4272     scan = ri->program + 1;             /* First BRANCH. */
4273
4274     /* testing for BRANCH here tells us whether there is "must appear"
4275        data in the pattern. If there is then we can use it for optimisations */
4276     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
4277         I32 fake;
4278         STRLEN longest_float_length, longest_fixed_length;
4279         struct regnode_charclass_class ch_class; /* pointed to by data */
4280         int stclass_flag;
4281         I32 last_close = 0; /* pointed to by data */
4282
4283         first = scan;
4284         /* Skip introductions and multiplicators >= 1. */
4285         while ((OP(first) == OPEN && (sawopen = 1)) ||
4286                /* An OR of *one* alternative - should not happen now. */
4287             (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
4288             /* for now we can't handle lookbehind IFMATCH*/
4289             (OP(first) == IFMATCH && !first->flags) || 
4290             (OP(first) == PLUS) ||
4291             (OP(first) == MINMOD) ||
4292                /* An {n,m} with n>0 */
4293             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ) 
4294         {
4295                 
4296                 if (OP(first) == PLUS)
4297                     sawplus = 1;
4298                 else
4299                     first += regarglen[OP(first)];
4300                 if (OP(first) == IFMATCH) {
4301                     first = NEXTOPER(first);
4302                     first += EXTRA_STEP_2ARGS;
4303                 } else  /* XXX possible optimisation for /(?=)/  */
4304                     first = NEXTOPER(first);
4305         }
4306
4307         /* Starting-point info. */
4308       again:
4309         DEBUG_PEEP("first:",first,0);
4310         /* Ignore EXACT as we deal with it later. */
4311         if (PL_regkind[OP(first)] == EXACT) {
4312             if (OP(first) == EXACT)
4313                 NOOP;   /* Empty, get anchored substr later. */
4314             else if ((OP(first) == EXACTF || OP(first) == EXACTFL))
4315                 ri->regstclass = first;
4316         }
4317 #ifdef TRIE_STCLASS     
4318         else if (PL_regkind[OP(first)] == TRIE &&
4319                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) 
4320         {
4321             regnode *trie_op;
4322             /* this can happen only on restudy */
4323             if ( OP(first) == TRIE ) {
4324                 struct regnode_1 *trieop = (struct regnode_1 *)
4325                     PerlMemShared_calloc(1, sizeof(struct regnode_1));
4326                 StructCopy(first,trieop,struct regnode_1);
4327                 trie_op=(regnode *)trieop;
4328             } else {
4329                 struct regnode_charclass *trieop = (struct regnode_charclass *)
4330                     PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
4331                 StructCopy(first,trieop,struct regnode_charclass);
4332                 trie_op=(regnode *)trieop;
4333             }
4334             OP(trie_op)+=2;
4335             make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
4336             ri->regstclass = trie_op;
4337         }
4338 #endif  
4339         else if (strchr((const char*)PL_simple,OP(first)))
4340             ri->regstclass = first;
4341         else if (PL_regkind[OP(first)] == BOUND ||
4342                  PL_regkind[OP(first)] == NBOUND)
4343             ri->regstclass = first;
4344         else if (PL_regkind[OP(first)] == BOL) {
4345             r->extflags |= (OP(first) == MBOL
4346                            ? RXf_ANCH_MBOL
4347                            : (OP(first) == SBOL
4348                               ? RXf_ANCH_SBOL
4349                               : RXf_ANCH_BOL));
4350             first = NEXTOPER(first);
4351             goto again;
4352         }
4353         else if (OP(first) == GPOS) {
4354             r->extflags |= RXf_ANCH_GPOS;
4355             first = NEXTOPER(first);
4356             goto again;
4357         }
4358         else if ((!sawopen || !RExC_sawback) &&
4359             (OP(first) == STAR &&
4360             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
4361             !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL))
4362         {
4363             /* turn .* into ^.* with an implied $*=1 */
4364             const int type =
4365                 (OP(NEXTOPER(first)) == REG_ANY)
4366                     ? RXf_ANCH_MBOL
4367                     : RXf_ANCH_SBOL;
4368             r->extflags |= type;
4369             r->intflags |= PREGf_IMPLICIT;
4370             first = NEXTOPER(first);
4371             goto again;
4372         }
4373         if (sawplus && (!sawopen || !RExC_sawback)
4374             && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
4375             /* x+ must match at the 1st pos of run of x's */
4376             r->intflags |= PREGf_SKIP;
4377
4378         /* Scan is after the zeroth branch, first is atomic matcher. */
4379 #ifdef TRIE_STUDY_OPT
4380         DEBUG_PARSE_r(
4381             if (!restudied)
4382                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
4383                               (IV)(first - scan + 1))
4384         );
4385 #else
4386         DEBUG_PARSE_r(
4387             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
4388                 (IV)(first - scan + 1))
4389         );
4390 #endif
4391
4392
4393         /*
4394         * If there's something expensive in the r.e., find the
4395         * longest literal string that must appear and make it the
4396         * regmust.  Resolve ties in favor of later strings, since
4397         * the regstart check works with the beginning of the r.e.
4398         * and avoiding duplication strengthens checking.  Not a
4399         * strong reason, but sufficient in the absence of others.
4400         * [Now we resolve ties in favor of the earlier string if
4401         * it happens that c_offset_min has been invalidated, since the
4402         * earlier string may buy us something the later one won't.]
4403         */
4404         
4405         data.longest_fixed = newSVpvs("");
4406         data.longest_float = newSVpvs("");
4407         data.last_found = newSVpvs("");
4408         data.longest = &(data.longest_fixed);
4409         first = scan;
4410         if (!ri->regstclass) {
4411             cl_init(pRExC_state, &ch_class);
4412             data.start_class = &ch_class;
4413             stclass_flag = SCF_DO_STCLASS_AND;
4414         } else                          /* XXXX Check for BOUND? */
4415             stclass_flag = 0;
4416         data.last_closep = &last_close;
4417         
4418         minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
4419             &data, -1, NULL, NULL,
4420             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
4421
4422         
4423         CHECK_RESTUDY_GOTO;
4424
4425
4426         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
4427              && data.last_start_min == 0 && data.last_end > 0
4428              && !RExC_seen_zerolen
4429              && !(RExC_seen & REG_SEEN_VERBARG)
4430              && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
4431             r->extflags |= RXf_CHECK_ALL;
4432         scan_commit(pRExC_state, &data,&minlen,0);
4433         SvREFCNT_dec(data.last_found);
4434
4435         /* Note that code very similar to this but for anchored string 
4436            follows immediately below, changes may need to be made to both. 
4437            Be careful. 
4438          */
4439         longest_float_length = CHR_SVLEN(data.longest_float);
4440         if (longest_float_length
4441             || (data.flags & SF_FL_BEFORE_EOL
4442                 && (!(data.flags & SF_FL_BEFORE_MEOL)
4443                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
4444         {
4445             I32 t,ml;
4446
4447             if (SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
4448                 && data.offset_fixed == data.offset_float_min
4449                 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
4450                     goto remove_float;          /* As in (a)+. */
4451
4452             /* copy the information about the longest float from the reg_scan_data
4453                over to the program. */
4454             if (SvUTF8(data.longest_float)) {
4455                 r->float_utf8 = data.longest_float;
4456                 r->float_substr = NULL;
4457             } else {
4458                 r->float_substr = data.longest_float;
4459                 r->float_utf8 = NULL;
4460             }
4461             /* float_end_shift is how many chars that must be matched that 
4462                follow this item. We calculate it ahead of time as once the
4463                lookbehind offset is added in we lose the ability to correctly
4464                calculate it.*/
4465             ml = data.minlen_float ? *(data.minlen_float) 
4466                                    : (I32)longest_float_length;
4467             r->float_end_shift = ml - data.offset_float_min
4468                 - longest_float_length + (SvTAIL(data.longest_float) != 0)
4469                 + data.lookbehind_float;
4470             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
4471             r->float_max_offset = data.offset_float_max;
4472             if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
4473                 r->float_max_offset -= data.lookbehind_float;
4474             
4475             t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
4476                        && (!(data.flags & SF_FL_BEFORE_MEOL)
4477                            || (RExC_flags & RXf_PMf_MULTILINE)));
4478             fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
4479         }
4480         else {
4481           remove_float:
4482             r->float_substr = r->float_utf8 = NULL;
4483             SvREFCNT_dec(data.longest_float);
4484             longest_float_length = 0;
4485         }
4486
4487         /* Note that code very similar to this but for floating string 
4488            is immediately above, changes may need to be made to both. 
4489            Be careful. 
4490          */
4491         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
4492         if (longest_fixed_length
4493             || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
4494                 && (!(data.flags & SF_FIX_BEFORE_MEOL)
4495                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
4496         {
4497             I32 t,ml;
4498
4499             /* copy the information about the longest fixed 
4500                from the reg_scan_data over to the program. */
4501             if (SvUTF8(data.longest_fixed)) {
4502                 r->anchored_utf8 = data.longest_fixed;
4503                 r->anchored_substr = NULL;
4504             } else {
4505                 r->anchored_substr = data.longest_fixed;
4506                 r->anchored_utf8 = NULL;
4507             }
4508             /* fixed_end_shift is how many chars that must be matched that 
4509                follow this item. We calculate it ahead of time as once the
4510                lookbehind offset is added in we lose the ability to correctly
4511                calculate it.*/
4512             ml = data.minlen_fixed ? *(data.minlen_fixed) 
4513                                    : (I32)longest_fixed_length;
4514             r->anchored_end_shift = ml - data.offset_fixed
4515                 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
4516                 + data.lookbehind_fixed;
4517             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
4518
4519             t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
4520                  && (!(data.flags & SF_FIX_BEFORE_MEOL)
4521                      || (RExC_flags & RXf_PMf_MULTILINE)));
4522             fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
4523         }
4524         else {
4525             r->anchored_substr = r->anchored_utf8 = NULL;
4526             SvREFCNT_dec(data.longest_fixed);
4527             longest_fixed_length = 0;
4528         }
4529         if (ri->regstclass
4530             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
4531             ri->regstclass = NULL;
4532         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
4533             && stclass_flag
4534             && !(data.start_class->flags & ANYOF_EOS)
4535             && !cl_is_anything(data.start_class))
4536         {
4537             const U32 n = add_data(pRExC_state, 1, "f");
4538
4539             Newx(RExC_rxi->data->data[n], 1,
4540                 struct regnode_charclass_class);
4541             StructCopy(data.start_class,
4542                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
4543                        struct regnode_charclass_class);
4544             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
4545             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
4546             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
4547                       regprop(r, sv, (regnode*)data.start_class);
4548                       PerlIO_printf(Perl_debug_log,
4549                                     "synthetic stclass \"%s\".\n",
4550                                     SvPVX_const(sv));});
4551         }
4552
4553         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
4554         if (longest_fixed_length > longest_float_length) {
4555             r->check_end_shift = r->anchored_end_shift;
4556             r->check_substr = r->anchored_substr;
4557             r->check_utf8 = r->anchored_utf8;
4558             r->check_offset_min = r->check_offset_max = r->anchored_offset;
4559             if (r->extflags & RXf_ANCH_SINGLE)
4560                 r->extflags |= RXf_NOSCAN;
4561         }
4562         else {
4563             r->check_end_shift = r->float_end_shift;
4564             r->check_substr = r->float_substr;
4565             r->check_utf8 = r->float_utf8;
4566             r->check_offset_min = r->float_min_offset;
4567             r->check_offset_max = r->float_max_offset;
4568         }
4569         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
4570            This should be changed ASAP!  */
4571         if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
4572             r->extflags |= RXf_USE_INTUIT;
4573             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
4574                 r->extflags |= RXf_INTUIT_TAIL;
4575         }
4576         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
4577         if ( (STRLEN)minlen < longest_float_length )
4578             minlen= longest_float_length;
4579         if ( (STRLEN)minlen < longest_fixed_length )
4580             minlen= longest_fixed_length;     
4581         */
4582     }
4583     else {
4584         /* Several toplevels. Best we can is to set minlen. */
4585         I32 fake;
4586         struct regnode_charclass_class ch_class;
4587         I32 last_close = 0;
4588         
4589         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
4590
4591         scan = ri->program + 1;
4592         cl_init(pRExC_state, &ch_class);
4593         data.start_class = &ch_class;
4594         data.last_closep = &last_close;
4595
4596         
4597         minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
4598             &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
4599         
4600         CHECK_RESTUDY_GOTO;
4601
4602         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
4603                 = r->float_substr = r->float_utf8 = NULL;
4604         if (!(data.start_class->flags & ANYOF_EOS)
4605             && !cl_is_anything(data.start_class))
4606         {
4607             const U32 n = add_data(pRExC_state, 1, "f");
4608
4609             Newx(RExC_rxi->data->data[n], 1,
4610                 struct regnode_charclass_class);
4611             StructCopy(data.start_class,
4612                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
4613                        struct regnode_charclass_class);
4614             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
4615             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
4616             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
4617                       regprop(r, sv, (regnode*)data.start_class);
4618                       PerlIO_printf(Perl_debug_log,
4619                                     "synthetic stclass \"%s\".\n",
4620                                     SvPVX_const(sv));});
4621         }
4622     }
4623
4624     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
4625        the "real" pattern. */
4626     DEBUG_OPTIMISE_r({
4627         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
4628                       (IV)minlen, (IV)r->minlen);
4629     });
4630     r->minlenret = minlen;
4631     if (r->minlen < minlen) 
4632         r->minlen = minlen;
4633     
4634     if (RExC_seen & REG_SEEN_GPOS)
4635         r->extflags |= RXf_GPOS_SEEN;
4636     if (RExC_seen & REG_SEEN_LOOKBEHIND)
4637         r->extflags |= RXf_LOOKBEHIND_SEEN;
4638     if (RExC_seen & REG_SEEN_EVAL)
4639         r->extflags |= RXf_EVAL_SEEN;
4640     if (RExC_seen & REG_SEEN_CANY)
4641         r->extflags |= RXf_CANY_SEEN;
4642     if (RExC_seen & REG_SEEN_VERBARG)
4643         r->intflags |= PREGf_VERBARG_SEEN;
4644     if (RExC_seen & REG_SEEN_CUTGROUP)
4645         r->intflags |= PREGf_CUTGROUP_SEEN;
4646     if (RExC_paren_names)
4647         r->paren_names = (HV*)SvREFCNT_inc(RExC_paren_names);
4648     else
4649         r->paren_names = NULL;
4650     if (r->prelen == 3 && strEQ("\\s+", r->precomp))
4651         r->extflags |= RXf_WHITE;
4652     else if (r->prelen == 1 && r->precomp[0] == '^')
4653         r->extflags |= RXf_START_ONLY;
4654
4655 #ifdef DEBUGGING
4656     if (RExC_paren_names) {
4657         ri->name_list_idx = add_data( pRExC_state, 1, "p" );
4658         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
4659     } else
4660 #endif
4661         ri->name_list_idx = 0;
4662
4663     if (RExC_recurse_count) {
4664         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
4665             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
4666             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
4667         }
4668     }
4669     Newxz(r->startp, RExC_npar, I32);
4670     Newxz(r->endp, RExC_npar, I32);
4671     /* assume we don't need to swap parens around before we match */
4672
4673     DEBUG_DUMP_r({
4674         PerlIO_printf(Perl_debug_log,"Final program:\n");
4675         regdump(r);
4676     });
4677 #ifdef RE_TRACK_PATTERN_OFFSETS
4678     DEBUG_OFFSETS_r(if (ri->u.offsets) {
4679         const U32 len = ri->u.offsets[0];
4680         U32 i;
4681         GET_RE_DEBUG_FLAGS_DECL;
4682         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
4683         for (i = 1; i <= len; i++) {
4684             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
4685                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
4686                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
4687             }
4688         PerlIO_printf(Perl_debug_log, "\n");
4689     });
4690 #endif
4691     return(r);
4692 }
4693
4694 #undef CORE_ONLY_BLOCK
4695 #undef RE_ENGINE_PTR
4696
4697 #ifndef PERL_IN_XSUB_RE
4698 SV*
4699 Perl_reg_named_buff_get(pTHX_ SV* namesv, const REGEXP * const from_re, U32 flags)
4700 {
4701     AV *retarray = NULL;
4702     SV *ret;
4703     if (flags & 1) 
4704         retarray=newAV();
4705     
4706     if (from_re || PL_curpm) {
4707         const REGEXP * const rx = from_re ? from_re : PM_GETRE(PL_curpm);
4708         if (rx && rx->paren_names) {            
4709             HE *he_str = hv_fetch_ent( rx->paren_names, namesv, 0, 0 );
4710             if (he_str) {
4711                 IV i;
4712                 SV* sv_dat=HeVAL(he_str);
4713                 I32 *nums=(I32*)SvPVX(sv_dat);
4714                 for ( i=0; i<SvIVX(sv_dat); i++ ) {
4715                     if ((I32)(rx->nparens) >= nums[i]
4716                         && rx->startp[nums[i]] != -1
4717                         && rx->endp[nums[i]] != -1)
4718                     {
4719                         ret = reg_numbered_buff_get(nums[i],rx,NULL,0);
4720                         if (!retarray) 
4721                             return ret;
4722                     } else {
4723                         ret = newSVsv(&PL_sv_undef);
4724                     }
4725                     if (retarray) {
4726                         SvREFCNT_inc(ret); 
4727                         av_push(retarray, ret);
4728                     }
4729                 }
4730                 if (retarray)
4731                     return (SV*)retarray;
4732             }
4733         }
4734     }
4735     return NULL;
4736 }
4737
4738 SV*
4739 Perl_reg_numbered_buff_get(pTHX_ I32 paren, const REGEXP * const rx, SV* usesv, U32 flags)
4740 {
4741     char *s = NULL;
4742     I32 i = 0;
4743     I32 s1, t1;
4744     SV *sv = usesv ? usesv : newSVpvs("");
4745     PERL_UNUSED_ARG(flags);
4746         
4747     if (!rx->subbeg) {
4748         sv_setsv(sv,&PL_sv_undef);
4749         return sv;
4750     } 
4751     else               
4752     if (paren == -2 && rx->startp[0] != -1) {
4753         /* $` */
4754         i = rx->startp[0];
4755         s = rx->subbeg;
4756     }
4757     else 
4758     if (paren == -1 && rx->endp[0] != -1) {
4759         /* $' */
4760         s = rx->subbeg + rx->endp[0];
4761         i = rx->sublen - rx->endp[0];
4762     } 
4763     else
4764     if ( 0 <= paren && paren <= (I32)rx->nparens &&
4765         (s1 = rx->startp[paren]) != -1 &&
4766         (t1 = rx->endp[paren]) != -1)
4767     {
4768         /* $& $1 ... */
4769         i = t1 - s1;
4770         s = rx->subbeg + s1;
4771     } else {
4772         sv_setsv(sv,&PL_sv_undef);
4773         return sv;
4774     }          
4775     assert(rx->sublen >= (s - rx->subbeg) + i );
4776     if (i >= 0) {
4777         const int oldtainted = PL_tainted;
4778         TAINT_NOT;
4779         sv_setpvn(sv, s, i);
4780         PL_tainted = oldtainted;
4781         if ( (rx->extflags & RXf_CANY_SEEN)
4782             ? (RX_MATCH_UTF8(rx)
4783                         && (!i || is_utf8_string((U8*)s, i)))
4784             : (RX_MATCH_UTF8(rx)) )
4785         {
4786             SvUTF8_on(sv);
4787         }
4788         else
4789             SvUTF8_off(sv);
4790         if (PL_tainting) {
4791             if (RX_MATCH_TAINTED(rx)) {
4792                 if (SvTYPE(sv) >= SVt_PVMG) {
4793                     MAGIC* const mg = SvMAGIC(sv);
4794                     MAGIC* mgt;
4795                     PL_tainted = 1;
4796                     SvMAGIC_set(sv, mg->mg_moremagic);
4797                     SvTAINT(sv);
4798                     if ((mgt = SvMAGIC(sv))) {
4799                         mg->mg_moremagic = mgt;
4800                         SvMAGIC_set(sv, mg);
4801                     }
4802                 } else {
4803                     PL_tainted = 1;
4804                     SvTAINT(sv);
4805                 }
4806             } else 
4807                 SvTAINTED_off(sv);
4808         }
4809     } else {
4810         sv_setsv(sv,&PL_sv_undef);
4811     }
4812     return sv;
4813 }
4814 #endif
4815
4816 /* Scans the name of a named buffer from the pattern.
4817  * If flags is REG_RSN_RETURN_NULL returns null.
4818  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
4819  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
4820  * to the parsed name as looked up in the RExC_paren_names hash.
4821  * If there is an error throws a vFAIL().. type exception.
4822  */
4823
4824 #define REG_RSN_RETURN_NULL    0
4825 #define REG_RSN_RETURN_NAME    1
4826 #define REG_RSN_RETURN_DATA    2
4827
4828 STATIC SV*
4829 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) {
4830     char *name_start = RExC_parse;
4831
4832     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
4833          /* skip IDFIRST by using do...while */
4834         if (UTF)
4835             do {
4836                 RExC_parse += UTF8SKIP(RExC_parse);
4837             } while (isALNUM_utf8((U8*)RExC_parse));
4838         else
4839             do {
4840                 RExC_parse++;
4841             } while (isALNUM(*RExC_parse));
4842     }
4843
4844     if ( flags ) {
4845         SV* sv_name = sv_2mortal(Perl_newSVpvn(aTHX_ name_start,
4846             (int)(RExC_parse - name_start)));
4847         if (UTF)
4848             SvUTF8_on(sv_name);
4849         if ( flags == REG_RSN_RETURN_NAME)
4850             return sv_name;
4851         else if (flags==REG_RSN_RETURN_DATA) {
4852             HE *he_str = NULL;
4853             SV *sv_dat = NULL;
4854             if ( ! sv_name )      /* should not happen*/
4855                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
4856             if (RExC_paren_names)
4857                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
4858             if ( he_str )
4859                 sv_dat = HeVAL(he_str);
4860             if ( ! sv_dat )
4861                 vFAIL("Reference to nonexistent named group");
4862             return sv_dat;
4863         }
4864         else {
4865             Perl_croak(aTHX_ "panic: bad flag in reg_scan_name");
4866         }
4867         /* NOT REACHED */
4868     }
4869     return NULL;
4870 }
4871
4872 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
4873     int rem=(int)(RExC_end - RExC_parse);                       \
4874     int cut;                                                    \
4875     int num;                                                    \
4876     int iscut=0;                                                \
4877     if (rem>10) {                                               \
4878         rem=10;                                                 \
4879         iscut=1;                                                \
4880     }                                                           \
4881     cut=10-rem;                                                 \
4882     if (RExC_lastparse!=RExC_parse)                             \
4883         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
4884             rem, RExC_parse,                                    \
4885             cut + 4,                                            \
4886             iscut ? "..." : "<"                                 \
4887         );                                                      \
4888     else                                                        \
4889         PerlIO_printf(Perl_debug_log,"%16s","");                \
4890                                                                 \
4891     if (SIZE_ONLY)                                              \
4892        num=RExC_size;                                           \
4893     else                                                        \
4894        num=REG_NODE_NUM(RExC_emit);                             \
4895     if (RExC_lastnum!=num)                                      \
4896        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
4897     else                                                        \
4898        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
4899     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
4900         (int)((depth*2)), "",                                   \
4901         (funcname)                                              \
4902     );                                                          \
4903     RExC_lastnum=num;                                           \
4904     RExC_lastparse=RExC_parse;                                  \
4905 })
4906
4907
4908
4909 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
4910     DEBUG_PARSE_MSG((funcname));                            \
4911     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
4912 })
4913 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
4914     DEBUG_PARSE_MSG((funcname));                            \
4915     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
4916 })
4917 /*
4918  - reg - regular expression, i.e. main body or parenthesized thing
4919  *
4920  * Caller must absorb opening parenthesis.
4921  *
4922  * Combining parenthesis handling with the base level of regular expression
4923  * is a trifle forced, but the need to tie the tails of the branches to what
4924  * follows makes it hard to avoid.
4925  */
4926 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
4927 #ifdef DEBUGGING
4928 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
4929 #else
4930 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
4931 #endif
4932
4933 /* this idea is borrowed from STR_WITH_LEN in handy.h */
4934 #define CHECK_WORD(s,v,l)  \
4935     (((sizeof(s)-1)==(l)) && (strnEQ(start_verb, (s ""), (sizeof(s)-1))))
4936
4937 STATIC regnode *
4938 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
4939     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
4940 {
4941     dVAR;
4942     register regnode *ret;              /* Will be the head of the group. */
4943     register regnode *br;
4944     register regnode *lastbr;
4945     register regnode *ender = NULL;
4946     register I32 parno = 0;
4947     I32 flags;
4948     const I32 oregflags = RExC_flags;
4949     bool have_branch = 0;
4950     bool is_open = 0;
4951     I32 freeze_paren = 0;
4952     I32 after_freeze = 0;
4953
4954     /* for (?g), (?gc), and (?o) warnings; warning
4955        about (?c) will warn about (?g) -- japhy    */
4956
4957 #define WASTED_O  0x01
4958 #define WASTED_G  0x02
4959 #define WASTED_C  0x04
4960 #define WASTED_GC (0x02|0x04)
4961     I32 wastedflags = 0x00;
4962
4963     char * parse_start = RExC_parse; /* MJD */
4964     char * const oregcomp_parse = RExC_parse;
4965
4966     GET_RE_DEBUG_FLAGS_DECL;
4967     DEBUG_PARSE("reg ");
4968
4969
4970     *flagp = 0;                         /* Tentatively. */
4971
4972
4973     /* Make an OPEN node, if parenthesized. */
4974     if (paren) {
4975         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
4976             char *start_verb = RExC_parse;
4977             STRLEN verb_len = 0;
4978             char *start_arg = NULL;
4979             unsigned char op = 0;
4980             int argok = 1;
4981             int internal_argval = 0; /* internal_argval is only useful if !argok */
4982             while ( *RExC_parse && *RExC_parse != ')' ) {
4983                 if ( *RExC_parse == ':' ) {
4984                     start_arg = RExC_parse + 1;
4985                     break;
4986                 }
4987                 RExC_parse++;
4988             }
4989             ++start_verb;
4990             verb_len = RExC_parse - start_verb;
4991             if ( start_arg ) {
4992                 RExC_parse++;
4993                 while ( *RExC_parse && *RExC_parse != ')' ) 
4994                     RExC_parse++;
4995                 if ( *RExC_parse != ')' ) 
4996                     vFAIL("Unterminated verb pattern argument");
4997                 if ( RExC_parse == start_arg )
4998                     start_arg = NULL;
4999             } else {
5000                 if ( *RExC_parse != ')' )
5001                     vFAIL("Unterminated verb pattern");
5002             }
5003             
5004             switch ( *start_verb ) {
5005             case 'A':  /* (*ACCEPT) */
5006                 if ( CHECK_WORD("ACCEPT",start_verb,verb_len) ) {
5007                     op = ACCEPT;
5008                     internal_argval = RExC_nestroot;
5009                 }
5010                 break;
5011             case 'C':  /* (*COMMIT) */
5012                 if ( CHECK_WORD("COMMIT",start_verb,verb_len) )
5013                     op = COMMIT;
5014                 break;
5015             case 'F':  /* (*FAIL) */
5016                 if ( verb_len==1 || CHECK_WORD("FAIL",start_verb,verb_len) ) {
5017                     op = OPFAIL;
5018                     argok = 0;
5019                 }
5020                 break;
5021             case ':':  /* (*:NAME) */
5022             case 'M':  /* (*MARK:NAME) */
5023                 if ( verb_len==0 || CHECK_WORD("MARK",start_verb,verb_len) ) {
5024                     op = MARKPOINT;
5025                     argok = -1;
5026                 }
5027                 break;
5028             case 'P':  /* (*PRUNE) */
5029                 if ( CHECK_WORD("PRUNE",start_verb,verb_len) )
5030                     op = PRUNE;
5031                 break;
5032             case 'S':   /* (*SKIP) */  
5033                 if ( CHECK_WORD("SKIP",start_verb,verb_len) ) 
5034                     op = SKIP;
5035                 break;
5036             case 'T':  /* (*THEN) */
5037                 /* [19:06] <TimToady> :: is then */
5038                 if ( CHECK_WORD("THEN",start_verb,verb_len) ) {
5039                     op = CUTGROUP;
5040                     RExC_seen |= REG_SEEN_CUTGROUP;
5041                 }
5042                 break;
5043             }
5044             if ( ! op ) {
5045                 RExC_parse++;
5046                 vFAIL3("Unknown verb pattern '%.*s'",
5047                     verb_len, start_verb);
5048             }
5049             if ( argok ) {
5050                 if ( start_arg && internal_argval ) {
5051                     vFAIL3("Verb pattern '%.*s' may not have an argument",
5052                         verb_len, start_verb); 
5053                 } else if ( argok < 0 && !start_arg ) {
5054                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
5055                         verb_len, start_verb);    
5056                 } else {
5057                     ret = reganode(pRExC_state, op, internal_argval);
5058                     if ( ! internal_argval && ! SIZE_ONLY ) {
5059                         if (start_arg) {
5060                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
5061                             ARG(ret) = add_data( pRExC_state, 1, "S" );
5062                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
5063                             ret->flags = 0;
5064                         } else {
5065                             ret->flags = 1; 
5066                         }
5067                     }               
5068                 }
5069                 if (!internal_argval)
5070                     RExC_seen |= REG_SEEN_VERBARG;
5071             } else if ( start_arg ) {
5072                 vFAIL3("Verb pattern '%.*s' may not have an argument",
5073                         verb_len, start_verb);    
5074             } else {
5075                 ret = reg_node(pRExC_state, op);
5076             }
5077             nextchar(pRExC_state);
5078             return ret;
5079         } else 
5080         if (*RExC_parse == '?') { /* (?...) */
5081             bool is_logical = 0;
5082             const char * const seqstart = RExC_parse;
5083
5084             RExC_parse++;
5085             paren = *RExC_parse++;
5086             ret = NULL;                 /* For look-ahead/behind. */
5087             switch (paren) {
5088
5089             case 'P':   /* (?P...) variants for those used to PCRE/Python */
5090                 paren = *RExC_parse++;
5091                 if ( paren == '<')         /* (?P<...>) named capture */
5092                     goto named_capture;
5093                 else if (paren == '>') {   /* (?P>name) named recursion */
5094                     goto named_recursion;
5095                 }
5096                 else if (paren == '=') {   /* (?P=...)  named backref */
5097                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
5098                        you change this make sure you change that */
5099                     char* name_start = RExC_parse;
5100                     U32 num = 0;
5101                     SV *sv_dat = reg_scan_name(pRExC_state,
5102                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5103                     if (RExC_parse == name_start || *RExC_parse != ')')
5104                         vFAIL2("Sequence %.3s... not terminated",parse_start);
5105
5106                     if (!SIZE_ONLY) {
5107                         num = add_data( pRExC_state, 1, "S" );
5108                         RExC_rxi->data->data[num]=(void*)sv_dat;
5109                         SvREFCNT_inc(sv_dat);
5110                     }
5111                     RExC_sawback = 1;
5112                     ret = reganode(pRExC_state,
5113                            (U8)(FOLD ? (LOC ? NREFFL : NREFF) : NREF),
5114                            num);
5115                     *flagp |= HASWIDTH;
5116
5117                     Set_Node_Offset(ret, parse_start+1);
5118                     Set_Node_Cur_Length(ret); /* MJD */
5119
5120                     nextchar(pRExC_state);
5121                     return ret;
5122                 }
5123                 RExC_parse++;
5124                 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
5125                 /*NOTREACHED*/
5126             case '<':           /* (?<...) */
5127                 if (*RExC_parse == '!')
5128                     paren = ',';
5129                 else if (*RExC_parse != '=') 
5130               named_capture:
5131                 {               /* (?<...>) */
5132                     char *name_start;
5133                     SV *svname;
5134                     paren= '>';
5135             case '\'':          /* (?'...') */
5136                     name_start= RExC_parse;
5137                     svname = reg_scan_name(pRExC_state,
5138                         SIZE_ONLY ?  /* reverse test from the others */
5139                         REG_RSN_RETURN_NAME : 
5140                         REG_RSN_RETURN_NULL);
5141                     if (RExC_parse == name_start) {
5142                         RExC_parse++;
5143                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
5144                         /*NOTREACHED*/
5145                     }
5146                     if (*RExC_parse != paren)
5147                         vFAIL2("Sequence (?%c... not terminated",
5148                             paren=='>' ? '<' : paren);
5149                     if (SIZE_ONLY) {
5150                         HE *he_str;
5151                         SV *sv_dat = NULL;
5152                         if (!svname) /* shouldnt happen */
5153                             Perl_croak(aTHX_
5154                                 "panic: reg_scan_name returned NULL");
5155                         if (!RExC_paren_names) {
5156                             RExC_paren_names= newHV();
5157                             sv_2mortal((SV*)RExC_paren_names);
5158 #ifdef DEBUGGING
5159                             RExC_paren_name_list= newAV();
5160                             sv_2mortal((SV*)RExC_paren_name_list);
5161 #endif
5162                         }
5163                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
5164                         if ( he_str )
5165                             sv_dat = HeVAL(he_str);
5166                         if ( ! sv_dat ) {
5167                             /* croak baby croak */
5168                             Perl_croak(aTHX_
5169                                 "panic: paren_name hash element allocation failed");
5170                         } else if ( SvPOK(sv_dat) ) {
5171                             IV count=SvIV(sv_dat);
5172                             I32 *pv=(I32*)SvGROW(sv_dat,SvCUR(sv_dat)+sizeof(I32)+1);
5173                             SvCUR_set(sv_dat,SvCUR(sv_dat)+sizeof(I32));
5174                             pv[count]=RExC_npar;
5175                             SvIVX(sv_dat)++;
5176                         } else {
5177                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
5178                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
5179                             SvIOK_on(sv_dat);
5180                             SvIVX(sv_dat)= 1;
5181                         }
5182 #ifdef DEBUGGING
5183                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
5184                             SvREFCNT_dec(svname);
5185 #endif
5186
5187                         /*sv_dump(sv_dat);*/
5188                     }
5189                     nextchar(pRExC_state);
5190                     paren = 1;
5191                     goto capturing_parens;
5192                 }
5193                 RExC_seen |= REG_SEEN_LOOKBEHIND;
5194                 RExC_parse++;
5195             case '=':           /* (?=...) */
5196             case '!':           /* (?!...) */
5197                 RExC_seen_zerolen++;
5198                 if (*RExC_parse == ')') {
5199                     ret=reg_node(pRExC_state, OPFAIL);
5200                     nextchar(pRExC_state);
5201                     return ret;
5202                 }
5203                 break;
5204             case '|':           /* (?|...) */
5205                 /* branch reset, behave like a (?:...) except that
5206                    buffers in alternations share the same numbers */
5207                 paren = ':'; 
5208                 after_freeze = freeze_paren = RExC_npar;
5209                 break;
5210             case ':':           /* (?:...) */
5211             case '>':           /* (?>...) */
5212                 break;
5213             case '$':           /* (?$...) */
5214             case '@':           /* (?@...) */
5215                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
5216                 break;
5217             case '#':           /* (?#...) */
5218                 while (*RExC_parse && *RExC_parse != ')')
5219                     RExC_parse++;
5220                 if (*RExC_parse != ')')
5221                     FAIL("Sequence (?#... not terminated");
5222                 nextchar(pRExC_state);
5223                 *flagp = TRYAGAIN;
5224                 return NULL;
5225             case '0' :           /* (?0) */
5226             case 'R' :           /* (?R) */
5227                 if (*RExC_parse != ')')
5228                     FAIL("Sequence (?R) not terminated");
5229                 ret = reg_node(pRExC_state, GOSTART);
5230                 nextchar(pRExC_state);
5231                 return ret;
5232                 /*notreached*/
5233             { /* named and numeric backreferences */
5234                 I32 num;
5235             case '&':            /* (?&NAME) */
5236                 parse_start = RExC_parse - 1;
5237               named_recursion:
5238                 {
5239                     SV *sv_dat = reg_scan_name(pRExC_state,
5240                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5241                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
5242                 }
5243                 goto gen_recurse_regop;
5244                 /* NOT REACHED */
5245             case '+':
5246                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
5247                     RExC_parse++;
5248                     vFAIL("Illegal pattern");
5249                 }
5250                 goto parse_recursion;
5251                 /* NOT REACHED*/
5252             case '-': /* (?-1) */
5253                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
5254                     RExC_parse--; /* rewind to let it be handled later */
5255                     goto parse_flags;
5256                 } 
5257                 /*FALLTHROUGH */
5258             case '1': case '2': case '3': case '4': /* (?1) */
5259             case '5': case '6': case '7': case '8': case '9':
5260                 RExC_parse--;
5261               parse_recursion:
5262                 num = atoi(RExC_parse);
5263                 parse_start = RExC_parse - 1; /* MJD */
5264                 if (*RExC_parse == '-')
5265                     RExC_parse++;
5266                 while (isDIGIT(*RExC_parse))
5267                         RExC_parse++;
5268                 if (*RExC_parse!=')') 
5269                     vFAIL("Expecting close bracket");
5270                         
5271               gen_recurse_regop:
5272                 if ( paren == '-' ) {
5273                     /*
5274                     Diagram of capture buffer numbering.
5275                     Top line is the normal capture buffer numbers
5276                     Botton line is the negative indexing as from
5277                     the X (the (?-2))
5278
5279                     +   1 2    3 4 5 X          6 7
5280                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
5281                     -   5 4    3 2 1 X          x x
5282
5283                     */
5284                     num = RExC_npar + num;
5285                     if (num < 1)  {
5286                         RExC_parse++;
5287                         vFAIL("Reference to nonexistent group");
5288                     }
5289                 } else if ( paren == '+' ) {
5290                     num = RExC_npar + num - 1;
5291                 }
5292
5293                 ret = reganode(pRExC_state, GOSUB, num);
5294                 if (!SIZE_ONLY) {
5295                     if (num > (I32)RExC_rx->nparens) {
5296                         RExC_parse++;
5297                         vFAIL("Reference to nonexistent group");
5298                     }
5299                     ARG2L_SET( ret, RExC_recurse_count++);
5300                     RExC_emit++;
5301                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5302                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
5303                 } else {
5304                     RExC_size++;
5305                 }
5306                 RExC_seen |= REG_SEEN_RECURSE;
5307                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
5308                 Set_Node_Offset(ret, parse_start); /* MJD */
5309
5310                 nextchar(pRExC_state);
5311                 return ret;
5312             } /* named and numeric backreferences */
5313             /* NOT REACHED */
5314
5315             case 'p':           /* (?p...) */
5316                 if (SIZE_ONLY && ckWARN2(WARN_DEPRECATED, WARN_REGEXP))
5317                     vWARNdep(RExC_parse, "(?p{}) is deprecated - use (??{})");
5318                 /* FALL THROUGH*/
5319             case '?':           /* (??...) */
5320                 is_logical = 1;
5321                 if (*RExC_parse != '{') {
5322                     RExC_parse++;
5323                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
5324                     /*NOTREACHED*/
5325                 }
5326                 paren = *RExC_parse++;
5327                 /* FALL THROUGH */
5328             case '{':           /* (?{...}) */
5329             {
5330                 I32 count = 1;
5331                 U32 n = 0;
5332                 char c;
5333                 char *s = RExC_parse;
5334
5335                 RExC_seen_zerolen++;
5336                 RExC_seen |= REG_SEEN_EVAL;
5337                 while (count && (c = *RExC_parse)) {
5338                     if (c == '\\') {
5339                         if (RExC_parse[1])
5340                             RExC_parse++;
5341                     }
5342                     else if (c == '{')
5343                         count++;
5344                     else if (c == '}')
5345                         count--;
5346                     RExC_parse++;
5347                 }
5348                 if (*RExC_parse != ')') {
5349                     RExC_parse = s;             
5350                     vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
5351                 }
5352                 if (!SIZE_ONLY) {
5353                     PAD *pad;
5354                     OP_4tree *sop, *rop;
5355                     SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
5356
5357                     ENTER;
5358                     Perl_save_re_context(aTHX);
5359                     rop = sv_compile_2op(sv, &sop, "re", &pad);
5360                     sop->op_private |= OPpREFCOUNTED;
5361                     /* re_dup will OpREFCNT_inc */
5362                     OpREFCNT_set(sop, 1);
5363                     LEAVE;
5364
5365                     n = add_data(pRExC_state, 3, "nop");
5366                     RExC_rxi->data->data[n] = (void*)rop;
5367                     RExC_rxi->data->data[n+1] = (void*)sop;
5368                     RExC_rxi->data->data[n+2] = (void*)pad;
5369                     SvREFCNT_dec(sv);
5370                 }
5371                 else {                                          /* First pass */
5372                     if (PL_reginterp_cnt < ++RExC_seen_evals
5373                         && IN_PERL_RUNTIME)
5374                         /* No compiled RE interpolated, has runtime
5375                            components ===> unsafe.  */
5376                         FAIL("Eval-group not allowed at runtime, use re 'eval'");
5377                     if (PL_tainting && PL_tainted)
5378                         FAIL("Eval-group in insecure regular expression");
5379 #if PERL_VERSION > 8
5380                     if (IN_PERL_COMPILETIME)
5381                         PL_cv_has_eval = 1;
5382 #endif
5383                 }
5384
5385                 nextchar(pRExC_state);
5386                 if (is_logical) {
5387                     ret = reg_node(pRExC_state, LOGICAL);
5388                     if (!SIZE_ONLY)
5389                         ret->flags = 2;
5390                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
5391                     /* deal with the length of this later - MJD */
5392                     return ret;
5393                 }
5394                 ret = reganode(pRExC_state, EVAL, n);
5395                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
5396                 Set_Node_Offset(ret, parse_start);
5397                 return ret;
5398             }
5399             case '(':           /* (?(?{...})...) and (?(?=...)...) */
5400             {
5401                 int is_define= 0;
5402                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
5403                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
5404                         || RExC_parse[1] == '<'
5405                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
5406                         I32 flag;
5407                         
5408                         ret = reg_node(pRExC_state, LOGICAL);
5409                         if (!SIZE_ONLY)
5410                             ret->flags = 1;
5411                         REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
5412                         goto insert_if;
5413                     }
5414                 }
5415                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
5416                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
5417                 {
5418                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
5419                     char *name_start= RExC_parse++;
5420                     U32 num = 0;
5421                     SV *sv_dat=reg_scan_name(pRExC_state,
5422                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5423                     if (RExC_parse == name_start || *RExC_parse != ch)
5424                         vFAIL2("Sequence (?(%c... not terminated",
5425                             (ch == '>' ? '<' : ch));
5426                     RExC_parse++;
5427                     if (!SIZE_ONLY) {
5428                         num = add_data( pRExC_state, 1, "S" );
5429                         RExC_rxi->data->data[num]=(void*)sv_dat;
5430                         SvREFCNT_inc(sv_dat);
5431                     }
5432                     ret = reganode(pRExC_state,NGROUPP,num);
5433                     goto insert_if_check_paren;
5434                 }
5435                 else if (RExC_parse[0] == 'D' &&
5436                          RExC_parse[1] == 'E' &&
5437                          RExC_parse[2] == 'F' &&
5438                          RExC_parse[3] == 'I' &&
5439                          RExC_parse[4] == 'N' &&
5440                          RExC_parse[5] == 'E')
5441                 {
5442                     ret = reganode(pRExC_state,DEFINEP,0);
5443                     RExC_parse +=6 ;
5444                     is_define = 1;
5445                     goto insert_if_check_paren;
5446                 }
5447                 else if (RExC_parse[0] == 'R') {
5448                     RExC_parse++;
5449                     parno = 0;
5450                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
5451                         parno = atoi(RExC_parse++);
5452                         while (isDIGIT(*RExC_parse))
5453                             RExC_parse++;
5454                     } else if (RExC_parse[0] == '&') {
5455                         SV *sv_dat;
5456                         RExC_parse++;
5457                         sv_dat = reg_scan_name(pRExC_state,
5458                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5459                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
5460                     }
5461                     ret = reganode(pRExC_state,INSUBP,parno); 
5462                     goto insert_if_check_paren;
5463                 }
5464                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
5465                     /* (?(1)...) */
5466                     char c;
5467                     parno = atoi(RExC_parse++);
5468
5469                     while (isDIGIT(*RExC_parse))
5470                         RExC_parse++;
5471                     ret = reganode(pRExC_state, GROUPP, parno);
5472
5473                  insert_if_check_paren:
5474                     if ((c = *nextchar(pRExC_state)) != ')')
5475                         vFAIL("Switch condition not recognized");
5476                   insert_if:
5477                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
5478                     br = regbranch(pRExC_state, &flags, 1,depth+1);
5479                     if (br == NULL)
5480                         br = reganode(pRExC_state, LONGJMP, 0);
5481                     else
5482                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
5483                     c = *nextchar(pRExC_state);
5484                     if (flags&HASWIDTH)
5485                         *flagp |= HASWIDTH;
5486                     if (c == '|') {
5487                         if (is_define) 
5488                             vFAIL("(?(DEFINE)....) does not allow branches");
5489                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
5490                         regbranch(pRExC_state, &flags, 1,depth+1);
5491                         REGTAIL(pRExC_state, ret, lastbr);
5492                         if (flags&HASWIDTH)
5493                             *flagp |= HASWIDTH;
5494                         c = *nextchar(pRExC_state);
5495                     }
5496                     else
5497                         lastbr = NULL;
5498                     if (c != ')')
5499                         vFAIL("Switch (?(condition)... contains too many branches");
5500                     ender = reg_node(pRExC_state, TAIL);
5501                     REGTAIL(pRExC_state, br, ender);
5502                     if (lastbr) {
5503                         REGTAIL(pRExC_state, lastbr, ender);
5504                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
5505                     }
5506                     else
5507                         REGTAIL(pRExC_state, ret, ender);
5508                     return ret;
5509                 }
5510                 else {
5511                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
5512                 }
5513             }
5514             case 0:
5515                 RExC_parse--; /* for vFAIL to print correctly */
5516                 vFAIL("Sequence (? incomplete");
5517                 break;
5518             default:
5519                 --RExC_parse;
5520                 parse_flags:      /* (?i) */  
5521             {
5522                 U32 posflags = 0, negflags = 0;
5523                 U32 *flagsp = &posflags;
5524
5525                 while (*RExC_parse) {
5526                     /* && strchr("iogcmsx", *RExC_parse) */
5527                     /* (?g), (?gc) and (?o) are useless here
5528                        and must be globally applied -- japhy */
5529                     switch (*RExC_parse) {
5530                     CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
5531                     case 'o':
5532                     case 'g':
5533                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
5534                             const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
5535                             if (! (wastedflags & wflagbit) ) {
5536                                 wastedflags |= wflagbit;
5537                                 vWARN5(
5538                                     RExC_parse + 1,
5539                                     "Useless (%s%c) - %suse /%c modifier",
5540                                     flagsp == &negflags ? "?-" : "?",
5541                                     *RExC_parse,
5542                                     flagsp == &negflags ? "don't " : "",
5543                                     *RExC_parse
5544                                 );
5545                             }
5546                         }
5547                         break;
5548                         
5549                     case 'c':
5550                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
5551                             if (! (wastedflags & WASTED_C) ) {
5552                                 wastedflags |= WASTED_GC;
5553                                 vWARN3(
5554                                     RExC_parse + 1,
5555                                     "Useless (%sc) - %suse /gc modifier",
5556                                     flagsp == &negflags ? "?-" : "?",
5557                                     flagsp == &negflags ? "don't " : ""
5558                                 );
5559                             }
5560                         }
5561                         break;
5562                     case 'k':
5563                         if (flagsp == &negflags) {
5564                             if (SIZE_ONLY && ckWARN(WARN_REGEXP))
5565                                 vWARN(RExC_parse + 1,"Useless use of (?-k)");
5566                         } else {
5567                             *flagsp |= RXf_PMf_KEEPCOPY;
5568                         }
5569                         break;
5570                     case '-':
5571                         if (flagsp == &negflags) {
5572                             RExC_parse++;
5573                             vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
5574                             /*NOTREACHED*/
5575                         }
5576                         flagsp = &negflags;
5577                         wastedflags = 0;  /* reset so (?g-c) warns twice */
5578                         break;
5579                     case ':':
5580                         paren = ':';
5581                         /*FALLTHROUGH*/
5582                     case ')':
5583                         RExC_flags |= posflags;
5584                         RExC_flags &= ~negflags;
5585                         nextchar(pRExC_state);
5586                         if (paren != ':') {
5587                             *flagp = TRYAGAIN;
5588                             return NULL;
5589                         } else {
5590                             ret = NULL;
5591                             goto parse_rest;
5592                         }
5593                         /*NOTREACHED*/
5594                     default:
5595                         RExC_parse++;
5596                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
5597                         /*NOTREACHED*/
5598                     }                           
5599                     ++RExC_parse;
5600                 }
5601             }} /* one for the default block, one for the switch */
5602         }
5603         else {                  /* (...) */
5604           capturing_parens:
5605             parno = RExC_npar;
5606             RExC_npar++;
5607             
5608             ret = reganode(pRExC_state, OPEN, parno);
5609             if (!SIZE_ONLY ){
5610                 if (!RExC_nestroot) 
5611                     RExC_nestroot = parno;
5612                 if (RExC_seen & REG_SEEN_RECURSE) {
5613                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5614                         "Setting open paren #%"IVdf" to %d\n", 
5615                         (IV)parno, REG_NODE_NUM(ret)));
5616                     RExC_open_parens[parno-1]= ret;
5617                 }
5618             }
5619             Set_Node_Length(ret, 1); /* MJD */
5620             Set_Node_Offset(ret, RExC_parse); /* MJD */
5621             is_open = 1;
5622         }
5623     }
5624     else                        /* ! paren */
5625         ret = NULL;
5626    
5627    parse_rest:
5628     /* Pick up the branches, linking them together. */
5629     parse_start = RExC_parse;   /* MJD */
5630     br = regbranch(pRExC_state, &flags, 1,depth+1);
5631     /*     branch_len = (paren != 0); */
5632
5633     if (br == NULL)
5634         return(NULL);
5635     if (*RExC_parse == '|') {
5636         if (!SIZE_ONLY && RExC_extralen) {
5637             reginsert(pRExC_state, BRANCHJ, br, depth+1);
5638         }
5639         else {                  /* MJD */
5640             reginsert(pRExC_state, BRANCH, br, depth+1);
5641             Set_Node_Length(br, paren != 0);
5642             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
5643         }
5644         have_branch = 1;
5645         if (SIZE_ONLY)
5646             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
5647     }
5648     else if (paren == ':') {
5649         *flagp |= flags&SIMPLE;
5650     }
5651     if (is_open) {                              /* Starts with OPEN. */
5652         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
5653     }
5654     else if (paren != '?')              /* Not Conditional */
5655         ret = br;
5656     *flagp |= flags & (SPSTART | HASWIDTH);
5657     lastbr = br;
5658     while (*RExC_parse == '|') {
5659         if (!SIZE_ONLY && RExC_extralen) {
5660             ender = reganode(pRExC_state, LONGJMP,0);
5661             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
5662         }
5663         if (SIZE_ONLY)
5664             RExC_extralen += 2;         /* Account for LONGJMP. */
5665         nextchar(pRExC_state);
5666         if (freeze_paren) {
5667             if (RExC_npar > after_freeze)
5668                 after_freeze = RExC_npar;
5669             RExC_npar = freeze_paren;       
5670         }
5671         br = regbranch(pRExC_state, &flags, 0, depth+1);
5672
5673         if (br == NULL)
5674             return(NULL);
5675         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
5676         lastbr = br;
5677         if (flags&HASWIDTH)
5678             *flagp |= HASWIDTH;
5679         *flagp |= flags&SPSTART;
5680     }
5681
5682     if (have_branch || paren != ':') {
5683         /* Make a closing node, and hook it on the end. */
5684         switch (paren) {
5685         case ':':
5686             ender = reg_node(pRExC_state, TAIL);
5687             break;
5688         case 1:
5689             ender = reganode(pRExC_state, CLOSE, parno);
5690             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
5691                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5692                         "Setting close paren #%"IVdf" to %d\n", 
5693                         (IV)parno, REG_NODE_NUM(ender)));
5694                 RExC_close_parens[parno-1]= ender;
5695                 if (RExC_nestroot == parno) 
5696                     RExC_nestroot = 0;
5697             }       
5698             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
5699             Set_Node_Length(ender,1); /* MJD */
5700             break;
5701         case '<':
5702         case ',':
5703         case '=':
5704         case '!':
5705             *flagp &= ~HASWIDTH;
5706             /* FALL THROUGH */
5707         case '>':
5708             ender = reg_node(pRExC_state, SUCCEED);
5709             break;
5710         case 0:
5711             ender = reg_node(pRExC_state, END);
5712             if (!SIZE_ONLY) {
5713                 assert(!RExC_opend); /* there can only be one! */
5714                 RExC_opend = ender;
5715             }
5716             break;
5717         }
5718         REGTAIL(pRExC_state, lastbr, ender);
5719
5720         if (have_branch && !SIZE_ONLY) {
5721             if (depth==1)
5722                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
5723
5724             /* Hook the tails of the branches to the closing node. */
5725             for (br = ret; br; br = regnext(br)) {
5726                 const U8 op = PL_regkind[OP(br)];
5727                 if (op == BRANCH) {
5728                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
5729                 }
5730                 else if (op == BRANCHJ) {
5731                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
5732                 }
5733             }
5734         }
5735     }
5736
5737     {
5738         const char *p;
5739         static const char parens[] = "=!<,>";
5740
5741         if (paren && (p = strchr(parens, paren))) {
5742             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
5743             int flag = (p - parens) > 1;
5744
5745             if (paren == '>')
5746                 node = SUSPEND, flag = 0;
5747             reginsert(pRExC_state, node,ret, depth+1);
5748             Set_Node_Cur_Length(ret);
5749             Set_Node_Offset(ret, parse_start + 1);
5750             ret->flags = flag;
5751             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
5752         }
5753     }
5754
5755     /* Check for proper termination. */
5756     if (paren) {
5757         RExC_flags = oregflags;
5758         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
5759             RExC_parse = oregcomp_parse;
5760             vFAIL("Unmatched (");
5761         }
5762     }
5763     else if (!paren && RExC_parse < RExC_end) {
5764         if (*RExC_parse == ')') {
5765             RExC_parse++;
5766             vFAIL("Unmatched )");
5767         }
5768         else
5769             FAIL("Junk on end of regexp");      /* "Can't happen". */
5770         /* NOTREACHED */
5771     }
5772     if (after_freeze)
5773         RExC_npar = after_freeze;
5774     return(ret);
5775 }
5776
5777 /*
5778  - regbranch - one alternative of an | operator
5779  *
5780  * Implements the concatenation operator.
5781  */
5782 STATIC regnode *
5783 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
5784 {
5785     dVAR;
5786     register regnode *ret;
5787     register regnode *chain = NULL;
5788     register regnode *latest;
5789     I32 flags = 0, c = 0;
5790     GET_RE_DEBUG_FLAGS_DECL;
5791     DEBUG_PARSE("brnc");
5792     if (first)
5793         ret = NULL;
5794     else {
5795         if (!SIZE_ONLY && RExC_extralen)
5796             ret = reganode(pRExC_state, BRANCHJ,0);
5797         else {
5798             ret = reg_node(pRExC_state, BRANCH);
5799             Set_Node_Length(ret, 1);
5800         }
5801     }
5802         
5803     if (!first && SIZE_ONLY)
5804         RExC_extralen += 1;                     /* BRANCHJ */
5805
5806     *flagp = WORST;                     /* Tentatively. */
5807
5808     RExC_parse--;
5809     nextchar(pRExC_state);
5810     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
5811         flags &= ~TRYAGAIN;
5812         latest = regpiece(pRExC_state, &flags,depth+1);
5813         if (latest == NULL) {
5814             if (flags & TRYAGAIN)
5815                 continue;
5816             return(NULL);
5817         }
5818         else if (ret == NULL)
5819             ret = latest;
5820         *flagp |= flags&HASWIDTH;
5821         if (chain == NULL)      /* First piece. */
5822             *flagp |= flags&SPSTART;
5823         else {
5824             RExC_naughty++;
5825             REGTAIL(pRExC_state, chain, latest);
5826         }
5827         chain = latest;
5828         c++;
5829     }
5830     if (chain == NULL) {        /* Loop ran zero times. */
5831         chain = reg_node(pRExC_state, NOTHING);
5832         if (ret == NULL)
5833             ret = chain;
5834     }
5835     if (c == 1) {
5836         *flagp |= flags&SIMPLE;
5837     }
5838
5839     return ret;
5840 }
5841
5842 /*
5843  - regpiece - something followed by possible [*+?]
5844  *
5845  * Note that the branching code sequences used for ? and the general cases
5846  * of * and + are somewhat optimized:  they use the same NOTHING node as
5847  * both the endmarker for their branch list and the body of the last branch.
5848  * It might seem that this node could be dispensed with entirely, but the
5849  * endmarker role is not redundant.
5850  */
5851 STATIC regnode *
5852 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
5853 {
5854     dVAR;
5855     register regnode *ret;
5856     register char op;
5857     register char *next;
5858     I32 flags;
5859     const char * const origparse = RExC_parse;
5860     I32 min;
5861     I32 max = REG_INFTY;
5862     char *parse_start;
5863     const char *maxpos = NULL;
5864     GET_RE_DEBUG_FLAGS_DECL;
5865     DEBUG_PARSE("piec");
5866
5867     ret = regatom(pRExC_state, &flags,depth+1);
5868     if (ret == NULL) {
5869         if (flags & TRYAGAIN)
5870             *flagp |= TRYAGAIN;
5871         return(NULL);
5872     }
5873
5874     op = *RExC_parse;
5875
5876     if (op == '{' && regcurly(RExC_parse)) {
5877         maxpos = NULL;
5878         parse_start = RExC_parse; /* MJD */
5879         next = RExC_parse + 1;
5880         while (isDIGIT(*next) || *next == ',') {
5881             if (*next == ',') {
5882                 if (maxpos)
5883                     break;
5884                 else
5885                     maxpos = next;
5886             }
5887             next++;
5888         }
5889         if (*next == '}') {             /* got one */
5890             if (!maxpos)
5891                 maxpos = next;
5892             RExC_parse++;
5893             min = atoi(RExC_parse);
5894             if (*maxpos == ',')
5895                 maxpos++;
5896             else
5897                 maxpos = RExC_parse;
5898             max = atoi(maxpos);
5899             if (!max && *maxpos != '0')
5900                 max = REG_INFTY;                /* meaning "infinity" */
5901             else if (max >= REG_INFTY)
5902                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
5903             RExC_parse = next;
5904             nextchar(pRExC_state);
5905
5906         do_curly:
5907             if ((flags&SIMPLE)) {
5908                 RExC_naughty += 2 + RExC_naughty / 2;
5909                 reginsert(pRExC_state, CURLY, ret, depth+1);
5910                 Set_Node_Offset(ret, parse_start+1); /* MJD */
5911                 Set_Node_Cur_Length(ret);
5912             }
5913             else {
5914                 regnode * const w = reg_node(pRExC_state, WHILEM);
5915
5916                 w->flags = 0;
5917                 REGTAIL(pRExC_state, ret, w);
5918                 if (!SIZE_ONLY && RExC_extralen) {
5919                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
5920                     reginsert(pRExC_state, NOTHING,ret, depth+1);
5921                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
5922                 }
5923                 reginsert(pRExC_state, CURLYX,ret, depth+1);
5924                                 /* MJD hk */
5925                 Set_Node_Offset(ret, parse_start+1);
5926                 Set_Node_Length(ret,
5927                                 op == '{' ? (RExC_parse - parse_start) : 1);
5928
5929                 if (!SIZE_ONLY && RExC_extralen)
5930                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
5931                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
5932                 if (SIZE_ONLY)
5933                     RExC_whilem_seen++, RExC_extralen += 3;
5934                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
5935             }
5936             ret->flags = 0;
5937
5938             if (min > 0)
5939                 *flagp = WORST;
5940             if (max > 0)
5941                 *flagp |= HASWIDTH;
5942             if (max && max < min)
5943                 vFAIL("Can't do {n,m} with n > m");
5944             if (!SIZE_ONLY) {
5945                 ARG1_SET(ret, (U16)min);
5946                 ARG2_SET(ret, (U16)max);
5947             }
5948
5949             goto nest_check;
5950         }
5951     }
5952
5953     if (!ISMULT1(op)) {
5954         *flagp = flags;
5955         return(ret);
5956     }
5957
5958 #if 0                           /* Now runtime fix should be reliable. */
5959
5960     /* if this is reinstated, don't forget to put this back into perldiag:
5961
5962             =item Regexp *+ operand could be empty at {#} in regex m/%s/
5963
5964            (F) The part of the regexp subject to either the * or + quantifier
5965            could match an empty string. The {#} shows in the regular
5966            expression about where the problem was discovered.
5967
5968     */
5969
5970     if (!(flags&HASWIDTH) && op != '?')
5971       vFAIL("Regexp *+ operand could be empty");
5972 #endif
5973
5974     parse_start = RExC_parse;
5975     nextchar(pRExC_state);
5976
5977     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
5978
5979     if (op == '*' && (flags&SIMPLE)) {
5980         reginsert(pRExC_state, STAR, ret, depth+1);
5981         ret->flags = 0;
5982         RExC_naughty += 4;
5983     }
5984     else if (op == '*') {
5985         min = 0;
5986         goto do_curly;
5987     }
5988     else if (op == '+' && (flags&SIMPLE)) {
5989         reginsert(pRExC_state, PLUS, ret, depth+1);
5990         ret->flags = 0;
5991         RExC_naughty += 3;
5992     }
5993     else if (op == '+') {
5994         min = 1;
5995         goto do_curly;
5996     }
5997     else if (op == '?') {
5998         min = 0; max = 1;
5999         goto do_curly;
6000     }
6001   nest_check:
6002     if (!SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3 && ckWARN(WARN_REGEXP)) {
6003         vWARN3(RExC_parse,
6004                "%.*s matches null string many times",
6005                (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
6006                origparse);
6007     }
6008
6009     if (RExC_parse < RExC_end && *RExC_parse == '?') {
6010         nextchar(pRExC_state);
6011         reginsert(pRExC_state, MINMOD, ret, depth+1);
6012         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
6013     }
6014 #ifndef REG_ALLOW_MINMOD_SUSPEND
6015     else
6016 #endif
6017     if (RExC_parse < RExC_end && *RExC_parse == '+') {
6018         regnode *ender;
6019         nextchar(pRExC_state);
6020         ender = reg_node(pRExC_state, SUCCEED);
6021         REGTAIL(pRExC_state, ret, ender);
6022         reginsert(pRExC_state, SUSPEND, ret, depth+1);
6023         ret->flags = 0;
6024         ender = reg_node(pRExC_state, TAIL);
6025         REGTAIL(pRExC_state, ret, ender);
6026         /*ret= ender;*/
6027     }
6028
6029     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
6030         RExC_parse++;
6031         vFAIL("Nested quantifiers");
6032     }
6033
6034     return(ret);
6035 }
6036
6037
6038 /* reg_namedseq(pRExC_state,UVp)
6039    
6040    This is expected to be called by a parser routine that has 
6041    recognized'\N' and needs to handle the rest. RExC_parse is 
6042    expected to point at the first char following the N at the time
6043    of the call.
6044    
6045    If valuep is non-null then it is assumed that we are parsing inside 
6046    of a charclass definition and the first codepoint in the resolved
6047    string is returned via *valuep and the routine will return NULL. 
6048    In this mode if a multichar string is returned from the charnames 
6049    handler a warning will be issued, and only the first char in the 
6050    sequence will be examined. If the string returned is zero length
6051    then the value of *valuep is undefined and NON-NULL will 
6052    be returned to indicate failure. (This will NOT be a valid pointer 
6053    to a regnode.)
6054    
6055    If value is null then it is assumed that we are parsing normal text
6056    and inserts a new EXACT node into the program containing the resolved
6057    string and returns a pointer to the new node. If the string is 
6058    zerolength a NOTHING node is emitted.
6059    
6060    On success RExC_parse is set to the char following the endbrace.
6061    Parsing failures will generate a fatal errorvia vFAIL(...)
6062    
6063    NOTE: We cache all results from the charnames handler locally in 
6064    the RExC_charnames hash (created on first use) to prevent a charnames 
6065    handler from playing silly-buggers and returning a short string and 
6066    then a long string for a given pattern. Since the regexp program 
6067    size is calculated during an initial parse this would result
6068    in a buffer overrun so we cache to prevent the charname result from
6069    changing during the course of the parse.
6070    
6071  */
6072 STATIC regnode *
6073 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep) 
6074 {
6075     char * name;        /* start of the content of the name */
6076     char * endbrace;    /* endbrace following the name */
6077     SV *sv_str = NULL;  
6078     SV *sv_name = NULL;
6079     STRLEN len; /* this has various purposes throughout the code */
6080     bool cached = 0; /* if this is true then we shouldn't refcount dev sv_str */
6081     regnode *ret = NULL;
6082     
6083     if (*RExC_parse != '{') {
6084         vFAIL("Missing braces on \\N{}");
6085     }
6086     name = RExC_parse+1;
6087     endbrace = strchr(RExC_parse, '}');
6088     if ( ! endbrace ) {
6089         RExC_parse++;
6090         vFAIL("Missing right brace on \\N{}");
6091     } 
6092     RExC_parse = endbrace + 1;  
6093     
6094     
6095     /* RExC_parse points at the beginning brace, 
6096        endbrace points at the last */
6097     if ( name[0]=='U' && name[1]=='+' ) {
6098         /* its a "unicode hex" notation {U+89AB} */
6099         I32 fl = PERL_SCAN_ALLOW_UNDERSCORES
6100             | PERL_SCAN_DISALLOW_PREFIX
6101             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
6102         UV cp;
6103         len = (STRLEN)(endbrace - name - 2);
6104         cp = grok_hex(name + 2, &len, &fl, NULL);
6105         if ( len != (STRLEN)(endbrace - name - 2) ) {
6106             cp = 0xFFFD;
6107         }    
6108         if (cp > 0xff)
6109             RExC_utf8 = 1;
6110         if ( valuep ) {
6111             *valuep = cp;
6112             return NULL;
6113         }
6114         sv_str= Perl_newSVpvf_nocontext("%c",(int)cp);
6115     } else {
6116         /* fetch the charnames handler for this scope */
6117         HV * const table = GvHV(PL_hintgv);
6118         SV **cvp= table ? 
6119             hv_fetchs(table, "charnames", FALSE) :
6120             NULL;
6121         SV *cv= cvp ? *cvp : NULL;
6122         HE *he_str;
6123         int count;
6124         /* create an SV with the name as argument */
6125         sv_name = newSVpvn(name, endbrace - name);
6126         
6127         if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
6128             vFAIL2("Constant(\\N{%s}) unknown: "
6129                   "(possibly a missing \"use charnames ...\")",
6130                   SvPVX(sv_name));
6131         }
6132         if (!cvp || !SvOK(*cvp)) { /* when $^H{charnames} = undef; */
6133             vFAIL2("Constant(\\N{%s}): "
6134                   "$^H{charnames} is not defined",SvPVX(sv_name));
6135         }
6136         
6137         
6138         
6139         if (!RExC_charnames) {
6140             /* make sure our cache is allocated */
6141             RExC_charnames = newHV();
6142             sv_2mortal((SV*)RExC_charnames);
6143         } 
6144             /* see if we have looked this one up before */
6145         he_str = hv_fetch_ent( RExC_charnames, sv_name, 0, 0 );
6146         if ( he_str ) {
6147             sv_str = HeVAL(he_str);
6148             cached = 1;
6149         } else {
6150             dSP ;
6151
6152             ENTER ;
6153             SAVETMPS ;
6154             PUSHMARK(SP) ;
6155             
6156             XPUSHs(sv_name);
6157             
6158             PUTBACK ;
6159             
6160             count= call_sv(cv, G_SCALAR);
6161             
6162             if (count == 1) { /* XXXX is this right? dmq */
6163                 sv_str = POPs;
6164                 SvREFCNT_inc_simple_void(sv_str);
6165             } 
6166             
6167             SPAGAIN ;
6168             PUTBACK ;
6169             FREETMPS ;
6170             LEAVE ;
6171             
6172             if ( !sv_str || !SvOK(sv_str) ) {
6173                 vFAIL2("Constant(\\N{%s}): Call to &{$^H{charnames}} "
6174                       "did not return a defined value",SvPVX(sv_name));
6175             }
6176             if (hv_store_ent( RExC_charnames, sv_name, sv_str, 0))
6177                 cached = 1;
6178         }
6179     }
6180     if (valuep) {
6181         char *p = SvPV(sv_str, len);
6182         if (len) {
6183             STRLEN numlen = 1;
6184             if ( SvUTF8(sv_str) ) {
6185                 *valuep = utf8_to_uvchr((U8*)p, &numlen);
6186                 if (*valuep > 0x7F)
6187                     RExC_utf8 = 1; 
6188                 /* XXXX
6189                   We have to turn on utf8 for high bit chars otherwise
6190                   we get failures with
6191                   
6192                    "ss" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i
6193                    "SS" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i
6194                 
6195                   This is different from what \x{} would do with the same
6196                   codepoint, where the condition is > 0xFF.
6197                   - dmq
6198                 */
6199                 
6200                 
6201             } else {
6202                 *valuep = (UV)*p;
6203                 /* warn if we havent used the whole string? */
6204             }
6205             if (numlen<len && SIZE_ONLY && ckWARN(WARN_REGEXP)) {
6206                 vWARN2(RExC_parse,
6207                     "Ignoring excess chars from \\N{%s} in character class",
6208                     SvPVX(sv_name)
6209                 );
6210             }        
6211         } else if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
6212             vWARN2(RExC_parse,
6213                     "Ignoring zero length \\N{%s} in character class",
6214                     SvPVX(sv_name)
6215                 );
6216         }
6217         if (sv_name)    
6218             SvREFCNT_dec(sv_name);    
6219         if (!cached)
6220             SvREFCNT_dec(sv_str);    
6221         return len ? NULL : (regnode *)&len;
6222     } else if(SvCUR(sv_str)) {     
6223         
6224         char *s; 
6225         char *p, *pend;        
6226         STRLEN charlen = 1;
6227 #ifdef DEBUGGING
6228         char * parse_start = name-3; /* needed for the offsets */
6229 #endif
6230         GET_RE_DEBUG_FLAGS_DECL;     /* needed for the offsets */
6231         
6232         ret = reg_node(pRExC_state,
6233             (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
6234         s= STRING(ret);
6235         
6236         if ( RExC_utf8 && !SvUTF8(sv_str) ) {
6237             sv_utf8_upgrade(sv_str);
6238         } else if ( !RExC_utf8 && SvUTF8(sv_str) ) {
6239             RExC_utf8= 1;
6240         }
6241         
6242         p = SvPV(sv_str, len);
6243         pend = p + len;
6244         /* len is the length written, charlen is the size the char read */
6245         for ( len = 0; p < pend; p += charlen ) {
6246             if (UTF) {
6247                 UV uvc = utf8_to_uvchr((U8*)p, &charlen);
6248                 if (FOLD) {
6249                     STRLEN foldlen,numlen;
6250                     U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
6251                     uvc = toFOLD_uni(uvc, tmpbuf, &foldlen);
6252                     /* Emit all the Unicode characters. */
6253                     
6254                     for (foldbuf = tmpbuf;
6255                         foldlen;
6256                         foldlen -= numlen) 
6257                     {
6258                         uvc = utf8_to_uvchr(foldbuf, &numlen);
6259                         if (numlen > 0) {
6260                             const STRLEN unilen = reguni(pRExC_state, uvc, s);
6261                             s       += unilen;
6262                             len     += unilen;
6263                             /* In EBCDIC the numlen
6264                             * and unilen can differ. */
6265                             foldbuf += numlen;
6266                             if (numlen >= foldlen)
6267                                 break;
6268                         }
6269                         else
6270                             break; /* "Can't happen." */
6271                     }                          
6272                 } else {
6273                     const STRLEN unilen = reguni(pRExC_state, uvc, s);
6274                     if (unilen > 0) {
6275                        s   += unilen;
6276                        len += unilen;
6277                     }
6278                 }
6279             } else {
6280                 len++;
6281                 REGC(*p, s++);
6282             }
6283         }
6284         if (SIZE_ONLY) {
6285             RExC_size += STR_SZ(len);
6286         } else {
6287             STR_LEN(ret) = len;
6288             RExC_emit += STR_SZ(len);
6289         }
6290         Set_Node_Cur_Length(ret); /* MJD */
6291         RExC_parse--; 
6292         nextchar(pRExC_state);
6293     } else {
6294         ret = reg_node(pRExC_state,NOTHING);
6295     }
6296     if (!cached) {
6297         SvREFCNT_dec(sv_str);
6298     }
6299     if (sv_name) {
6300         SvREFCNT_dec(sv_name); 
6301     }
6302     return ret;
6303
6304 }
6305
6306
6307 /*
6308  * reg_recode
6309  *
6310  * It returns the code point in utf8 for the value in *encp.
6311  *    value: a code value in the source encoding
6312  *    encp:  a pointer to an Encode object
6313  *
6314  * If the result from Encode is not a single character,
6315  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
6316  */
6317 STATIC UV
6318 S_reg_recode(pTHX_ const char value, SV **encp)
6319 {
6320     STRLEN numlen = 1;
6321     SV * const sv = sv_2mortal(newSVpvn(&value, numlen));
6322     const char * const s = encp && *encp ? sv_recode_to_utf8(sv, *encp)
6323                                          : SvPVX(sv);
6324     const STRLEN newlen = SvCUR(sv);
6325     UV uv = UNICODE_REPLACEMENT;
6326
6327     if (newlen)
6328         uv = SvUTF8(sv)
6329              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
6330              : *(U8*)s;
6331
6332     if (!newlen || numlen != newlen) {
6333         uv = UNICODE_REPLACEMENT;
6334         if (encp)
6335             *encp = NULL;
6336     }
6337     return uv;
6338 }
6339
6340
6341 /*
6342  - regatom - the lowest level
6343
6344    Try to identify anything special at the start of the pattern. If there
6345    is, then handle it as required. This may involve generating a single regop,
6346    such as for an assertion; or it may involve recursing, such as to
6347    handle a () structure.
6348
6349    If the string doesn't start with something special then we gobble up
6350    as much literal text as we can.
6351
6352    Once we have been able to handle whatever type of thing started the
6353    sequence, we return.
6354
6355    Note: we have to be careful with escapes, as they can be both literal
6356    and special, and in the case of \10 and friends can either, depending
6357    on context. Specifically there are two seperate switches for handling
6358    escape sequences, with the one for handling literal escapes requiring
6359    a dummy entry for all of the special escapes that are actually handled
6360    by the other.
6361 */
6362
6363 STATIC regnode *
6364 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
6365 {
6366     dVAR;
6367     register regnode *ret = NULL;
6368     I32 flags;
6369     char *parse_start = RExC_parse;
6370     GET_RE_DEBUG_FLAGS_DECL;
6371     DEBUG_PARSE("atom");
6372     *flagp = WORST;             /* Tentatively. */
6373
6374
6375 tryagain:
6376     switch (*RExC_parse) {
6377     case '^':
6378         RExC_seen_zerolen++;
6379         nextchar(pRExC_state);
6380         if (RExC_flags & RXf_PMf_MULTILINE)
6381             ret = reg_node(pRExC_state, MBOL);
6382         else if (RExC_flags & RXf_PMf_SINGLELINE)
6383             ret = reg_node(pRExC_state, SBOL);
6384         else
6385             ret = reg_node(pRExC_state, BOL);
6386         Set_Node_Length(ret, 1); /* MJD */
6387         break;
6388     case '$':
6389         nextchar(pRExC_state);
6390         if (*RExC_parse)
6391             RExC_seen_zerolen++;
6392         if (RExC_flags & RXf_PMf_MULTILINE)
6393             ret = reg_node(pRExC_state, MEOL);
6394         else if (RExC_flags & RXf_PMf_SINGLELINE)
6395             ret = reg_node(pRExC_state, SEOL);
6396         else
6397             ret = reg_node(pRExC_state, EOL);
6398         Set_Node_Length(ret, 1); /* MJD */
6399         break;
6400     case '.':
6401         nextchar(pRExC_state);
6402         if (RExC_flags & RXf_PMf_SINGLELINE)
6403             ret = reg_node(pRExC_state, SANY);
6404         else
6405             ret = reg_node(pRExC_state, REG_ANY);
6406         *flagp |= HASWIDTH|SIMPLE;
6407         RExC_naughty++;
6408         Set_Node_Length(ret, 1); /* MJD */
6409         break;
6410     case '[':
6411     {
6412         char * const oregcomp_parse = ++RExC_parse;
6413         ret = regclass(pRExC_state,depth+1);
6414         if (*RExC_parse != ']') {
6415             RExC_parse = oregcomp_parse;
6416             vFAIL("Unmatched [");
6417         }
6418         nextchar(pRExC_state);
6419         *flagp |= HASWIDTH|SIMPLE;
6420         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
6421         break;
6422     }
6423     case '(':
6424         nextchar(pRExC_state);
6425         ret = reg(pRExC_state, 1, &flags,depth+1);
6426         if (ret == NULL) {
6427                 if (flags & TRYAGAIN) {
6428                     if (RExC_parse == RExC_end) {
6429                          /* Make parent create an empty node if needed. */
6430                         *flagp |= TRYAGAIN;
6431                         return(NULL);
6432                     }
6433                     goto tryagain;
6434                 }
6435                 return(NULL);
6436         }
6437         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE);
6438         break;
6439     case '|':
6440     case ')':
6441         if (flags & TRYAGAIN) {
6442             *flagp |= TRYAGAIN;
6443             return NULL;
6444         }
6445         vFAIL("Internal urp");
6446                                 /* Supposed to be caught earlier. */
6447         break;
6448     case '{':
6449         if (!regcurly(RExC_parse)) {
6450             RExC_parse++;
6451             goto defchar;
6452         }
6453         /* FALL THROUGH */
6454     case '?':
6455     case '+':
6456     case '*':
6457         RExC_parse++;
6458         vFAIL("Quantifier follows nothing");
6459         break;
6460     case '\\':
6461         /* Special Escapes
6462
6463            This switch handles escape sequences that resolve to some kind
6464            of special regop and not to literal text. Escape sequnces that
6465            resolve to literal text are handled below in the switch marked
6466            "Literal Escapes".
6467
6468            Every entry in this switch *must* have a corresponding entry
6469            in the literal escape switch. However, the opposite is not
6470            required, as the default for this switch is to jump to the
6471            literal text handling code.
6472         */
6473         switch (*++RExC_parse) {
6474         /* Special Escapes */
6475         case 'A':
6476             RExC_seen_zerolen++;
6477             ret = reg_node(pRExC_state, SBOL);
6478             *flagp |= SIMPLE;
6479             goto finish_meta_pat;
6480         case 'G':
6481             ret = reg_node(pRExC_state, GPOS);
6482             RExC_seen |= REG_SEEN_GPOS;
6483             *flagp |= SIMPLE;
6484             goto finish_meta_pat;
6485         case 'K':
6486             RExC_seen_zerolen++;
6487             ret = reg_node(pRExC_state, KEEPS);
6488             *flagp |= SIMPLE;
6489             goto finish_meta_pat;
6490         case 'Z':
6491             ret = reg_node(pRExC_state, SEOL);
6492             *flagp |= SIMPLE;
6493             RExC_seen_zerolen++;                /* Do not optimize RE away */
6494             goto finish_meta_pat;
6495         case 'z':
6496             ret = reg_node(pRExC_state, EOS);
6497             *flagp |= SIMPLE;
6498             RExC_seen_zerolen++;                /* Do not optimize RE away */
6499             goto finish_meta_pat;
6500         case 'C':
6501             ret = reg_node(pRExC_state, CANY);
6502             RExC_seen |= REG_SEEN_CANY;
6503             *flagp |= HASWIDTH|SIMPLE;
6504             goto finish_meta_pat;
6505         case 'X':
6506             ret = reg_node(pRExC_state, CLUMP);
6507             *flagp |= HASWIDTH;
6508             goto finish_meta_pat;
6509         case 'w':
6510             ret = reg_node(pRExC_state, (U8)(LOC ? ALNUML     : ALNUM));
6511             *flagp |= HASWIDTH|SIMPLE;
6512             goto finish_meta_pat;
6513         case 'W':
6514             ret = reg_node(pRExC_state, (U8)(LOC ? NALNUML    : NALNUM));
6515             *flagp |= HASWIDTH|SIMPLE;
6516             goto finish_meta_pat;
6517         case 'b':
6518             RExC_seen_zerolen++;
6519             RExC_seen |= REG_SEEN_LOOKBEHIND;
6520             ret = reg_node(pRExC_state, (U8)(LOC ? BOUNDL     : BOUND));
6521             *flagp |= SIMPLE;
6522             goto finish_meta_pat;
6523         case 'B':
6524             RExC_seen_zerolen++;
6525             RExC_seen |= REG_SEEN_LOOKBEHIND;
6526             ret = reg_node(pRExC_state, (U8)(LOC ? NBOUNDL    : NBOUND));
6527             *flagp |= SIMPLE;
6528             goto finish_meta_pat;
6529         case 's':
6530             ret = reg_node(pRExC_state, (U8)(LOC ? SPACEL     : SPACE));
6531             *flagp |= HASWIDTH|SIMPLE;
6532             goto finish_meta_pat;
6533         case 'S':
6534             ret = reg_node(pRExC_state, (U8)(LOC ? NSPACEL    : NSPACE));
6535             *flagp |= HASWIDTH|SIMPLE;
6536             goto finish_meta_pat;
6537         case 'd':
6538             ret = reg_node(pRExC_state, DIGIT);
6539             *flagp |= HASWIDTH|SIMPLE;
6540             goto finish_meta_pat;
6541         case 'D':
6542             ret = reg_node(pRExC_state, NDIGIT);
6543             *flagp |= HASWIDTH|SIMPLE;
6544             goto finish_meta_pat;
6545         case 'v':
6546             ret = reganode(pRExC_state, PRUNE, 0);
6547             ret->flags = 1;
6548             *flagp |= SIMPLE;
6549             goto finish_meta_pat;
6550         case 'V':
6551             ret = reganode(pRExC_state, SKIP, 0);
6552             ret->flags = 1;
6553             *flagp |= SIMPLE;
6554          finish_meta_pat:           
6555             nextchar(pRExC_state);
6556             Set_Node_Length(ret, 2); /* MJD */
6557             break;          
6558         case 'p':
6559         case 'P':
6560             {   
6561                 char* const oldregxend = RExC_end;
6562 #ifdef DEBUGGING
6563                 char* parse_start = RExC_parse - 2;
6564 #endif
6565
6566                 if (RExC_parse[1] == '{') {
6567                   /* a lovely hack--pretend we saw [\pX] instead */
6568                     RExC_end = strchr(RExC_parse, '}');
6569                     if (!RExC_end) {
6570                         const U8 c = (U8)*RExC_parse;
6571                         RExC_parse += 2;
6572                         RExC_end = oldregxend;
6573                         vFAIL2("Missing right brace on \\%c{}", c);
6574                     }
6575                     RExC_end++;
6576                 }
6577                 else {
6578                     RExC_end = RExC_parse + 2;
6579                     if (RExC_end > oldregxend)
6580                         RExC_end = oldregxend;
6581                 }
6582                 RExC_parse--;
6583
6584                 ret = regclass(pRExC_state,depth+1);
6585
6586                 RExC_end = oldregxend;
6587                 RExC_parse--;
6588
6589                 Set_Node_Offset(ret, parse_start + 2);
6590                 Set_Node_Cur_Length(ret);
6591                 nextchar(pRExC_state);
6592                 *flagp |= HASWIDTH|SIMPLE;
6593             }
6594             break;
6595         case 'N': 
6596             /* Handle \N{NAME} here and not below because it can be 
6597             multicharacter. join_exact() will join them up later on. 
6598             Also this makes sure that things like /\N{BLAH}+/ and 
6599             \N{BLAH} being multi char Just Happen. dmq*/
6600             ++RExC_parse;
6601             ret= reg_namedseq(pRExC_state, NULL); 
6602             break;
6603         case 'k':    /* Handle \k<NAME> and \k'NAME' */
6604         parse_named_seq:
6605         {   
6606             char ch= RExC_parse[1];         
6607             if (ch != '<' && ch != '\'' && ch != '{') {
6608                 RExC_parse++;
6609                 vFAIL2("Sequence %.2s... not terminated",parse_start);
6610             } else {
6611                 /* this pretty much dupes the code for (?P=...) in reg(), if
6612                    you change this make sure you change that */
6613                 char* name_start = (RExC_parse += 2);
6614                 U32 num = 0;
6615                 SV *sv_dat = reg_scan_name(pRExC_state,
6616                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6617                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
6618                 if (RExC_parse == name_start || *RExC_parse != ch)
6619                     vFAIL2("Sequence %.3s... not terminated",parse_start);
6620
6621                 if (!SIZE_ONLY) {
6622                     num = add_data( pRExC_state, 1, "S" );
6623                     RExC_rxi->data->data[num]=(void*)sv_dat;
6624                     SvREFCNT_inc(sv_dat);
6625                 }
6626
6627                 RExC_sawback = 1;
6628                 ret = reganode(pRExC_state,
6629                            (U8)(FOLD ? (LOC ? NREFFL : NREFF) : NREF),
6630                            num);
6631                 *flagp |= HASWIDTH;
6632
6633                 /* override incorrect value set in reganode MJD */
6634                 Set_Node_Offset(ret, parse_start+1);
6635                 Set_Node_Cur_Length(ret); /* MJD */
6636                 nextchar(pRExC_state);
6637
6638             }
6639             break;
6640         }
6641         case 'g': 
6642         case '1': case '2': case '3': case '4':
6643         case '5': case '6': case '7': case '8': case '9':
6644             {
6645                 I32 num;
6646                 bool isg = *RExC_parse == 'g';
6647                 bool isrel = 0; 
6648                 bool hasbrace = 0;
6649                 if (isg) {
6650                     RExC_parse++;
6651                     if (*RExC_parse == '{') {
6652                         RExC_parse++;
6653                         hasbrace = 1;
6654                     }
6655                     if (*RExC_parse == '-') {
6656                         RExC_parse++;
6657                         isrel = 1;
6658                     }
6659                     if (hasbrace && !isDIGIT(*RExC_parse)) {
6660                         if (isrel) RExC_parse--;
6661                         RExC_parse -= 2;                            
6662                         goto parse_named_seq;
6663                 }   }
6664                 num = atoi(RExC_parse);
6665                 if (isrel) {
6666                     num = RExC_npar - num;
6667                     if (num < 1)
6668                         vFAIL("Reference to nonexistent or unclosed group");
6669                 }
6670                 if (!isg && num > 9 && num >= RExC_npar)
6671                     goto defchar;
6672                 else {
6673                     char * const parse_start = RExC_parse - 1; /* MJD */
6674                     while (isDIGIT(*RExC_parse))
6675                         RExC_parse++;
6676                     if (parse_start == RExC_parse - 1) 
6677                         vFAIL("Unterminated \\g... pattern");
6678                     if (hasbrace) {
6679                         if (*RExC_parse != '}') 
6680                             vFAIL("Unterminated \\g{...} pattern");
6681                         RExC_parse++;
6682                     }    
6683                     if (!SIZE_ONLY) {
6684                         if (num > (I32)RExC_rx->nparens)
6685                             vFAIL("Reference to nonexistent group");
6686                     }
6687                     RExC_sawback = 1;
6688                     ret = reganode(pRExC_state,
6689                                    (U8)(FOLD ? (LOC ? REFFL : REFF) : REF),
6690                                    num);
6691                     *flagp |= HASWIDTH;
6692
6693                     /* override incorrect value set in reganode MJD */
6694                     Set_Node_Offset(ret, parse_start+1);
6695                     Set_Node_Cur_Length(ret); /* MJD */
6696                     RExC_parse--;
6697                     nextchar(pRExC_state);
6698                 }
6699             }
6700             break;
6701         case '\0':
6702             if (RExC_parse >= RExC_end)
6703                 FAIL("Trailing \\");
6704             /* FALL THROUGH */
6705         default:
6706             /* Do not generate "unrecognized" warnings here, we fall
6707                back into the quick-grab loop below */
6708             parse_start--;
6709             goto defchar;
6710         }
6711         break;
6712
6713     case '#':
6714         if (RExC_flags & RXf_PMf_EXTENDED) {
6715             if ( reg_skipcomment( pRExC_state ) )
6716                 goto tryagain;
6717         }
6718         /* FALL THROUGH */
6719
6720     default: {
6721             register STRLEN len;
6722             register UV ender;
6723             register char *p;
6724             char *s;
6725             STRLEN foldlen;
6726             U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
6727
6728             parse_start = RExC_parse - 1;
6729
6730             RExC_parse++;
6731
6732         defchar:
6733             ender = 0;
6734             ret = reg_node(pRExC_state,
6735                            (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
6736             s = STRING(ret);
6737             for (len = 0, p = RExC_parse - 1;
6738               len < 127 && p < RExC_end;
6739               len++)
6740             {
6741                 char * const oldp = p;
6742
6743                 if (RExC_flags & RXf_PMf_EXTENDED)
6744                     p = regwhite( pRExC_state, p );
6745                 switch (*p) {
6746                 case '^':
6747                 case '$':
6748                 case '.':
6749                 case '[':
6750                 case '(':
6751                 case ')':
6752                 case '|':
6753                     goto loopdone;
6754                 case '\\':
6755                     /* Literal Escapes Switch
6756
6757                        This switch is meant to handle escape sequences that
6758                        resolve to a literal character.
6759
6760                        Every escape sequence that represents something
6761                        else, like an assertion or a char class, is handled
6762                        in the switch marked 'Special Escapes' above in this
6763                        routine, but also has an entry here as anything that
6764                        isn't explicitly mentioned here will be treated as
6765                        an unescaped equivalent literal.
6766                     */
6767
6768                     switch (*++p) {
6769                     /* These are all the special escapes. */
6770                     case 'A':             /* Start assertion */
6771                     case 'b': case 'B':   /* Word-boundary assertion*/
6772                     case 'C':             /* Single char !DANGEROUS! */
6773                     case 'd': case 'D':   /* digit class */
6774                     case 'g': case 'G':   /* generic-backref, pos assertion */
6775                     case 'k': case 'K':   /* named backref, keep marker */
6776                     case 'N':             /* named char sequence */
6777                     case 'p': case 'P':   /* unicode property */
6778                     case 's': case 'S':   /* space class */
6779                     case 'v': case 'V':   /* (*PRUNE) and (*SKIP) */
6780                     case 'w': case 'W':   /* word class */
6781                     case 'X':             /* eXtended Unicode "combining character sequence" */
6782                     case 'z': case 'Z':   /* End of line/string assertion */
6783                         --p;
6784                         goto loopdone;
6785
6786                     /* Anything after here is an escape that resolves to a
6787                        literal. (Except digits, which may or may not)
6788                      */
6789                     case 'n':
6790                         ender = '\n';
6791                         p++;
6792                         break;
6793                     case 'r':
6794                         ender = '\r';
6795                         p++;
6796                         break;
6797                     case 't':
6798                         ender = '\t';
6799                         p++;
6800                         break;
6801                     case 'f':
6802                         ender = '\f';
6803                         p++;
6804                         break;
6805                     case 'e':
6806                           ender = ASCII_TO_NATIVE('\033');
6807                         p++;
6808                         break;
6809                     case 'a':
6810                           ender = ASCII_TO_NATIVE('\007');
6811                         p++;
6812                         break;
6813                     case 'x':
6814                         if (*++p == '{') {
6815                             char* const e = strchr(p, '}');
6816         
6817                             if (!e) {
6818                                 RExC_parse = p + 1;
6819                                 vFAIL("Missing right brace on \\x{}");
6820                             }
6821                             else {
6822                                 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
6823                                     | PERL_SCAN_DISALLOW_PREFIX;
6824                                 STRLEN numlen = e - p - 1;
6825                                 ender = grok_hex(p + 1, &numlen, &flags, NULL);
6826                                 if (ender > 0xff)
6827                                     RExC_utf8 = 1;
6828                                 p = e + 1;
6829                             }
6830                         }
6831                         else {
6832                             I32 flags = PERL_SCAN_DISALLOW_PREFIX;
6833                             STRLEN numlen = 2;
6834                             ender = grok_hex(p, &numlen, &flags, NULL);
6835                             p += numlen;
6836                         }
6837                         if (PL_encoding && ender < 0x100)
6838                             goto recode_encoding;
6839                         break;
6840                     case 'c':
6841                         p++;
6842                         ender = UCHARAT(p++);
6843                         ender = toCTRL(ender);
6844                         break;
6845                     case '0': case '1': case '2': case '3':case '4':
6846                     case '5': case '6': case '7': case '8':case '9':
6847                         if (*p == '0' ||
6848                           (isDIGIT(p[1]) && atoi(p) >= RExC_npar) ) {
6849                             I32 flags = 0;
6850                             STRLEN numlen = 3;
6851                             ender = grok_oct(p, &numlen, &flags, NULL);
6852                             p += numlen;
6853                         }
6854                         else {
6855                             --p;
6856                             goto loopdone;
6857                         }
6858                         if (PL_encoding && ender < 0x100)
6859                             goto recode_encoding;
6860                         break;
6861                     recode_encoding:
6862                         {
6863                             SV* enc = PL_encoding;
6864                             ender = reg_recode((const char)(U8)ender, &enc);
6865                             if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP))
6866                                 vWARN(p, "Invalid escape in the specified encoding");
6867                             RExC_utf8 = 1;
6868                         }
6869                         break;
6870                     case '\0':
6871                         if (p >= RExC_end)
6872                             FAIL("Trailing \\");
6873                         /* FALL THROUGH */
6874                     default:
6875                         if (!SIZE_ONLY&& isALPHA(*p) && ckWARN(WARN_REGEXP))
6876                             vWARN2(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p));
6877                         goto normal_default;
6878                     }
6879                     break;
6880                 default:
6881                   normal_default:
6882                     if (UTF8_IS_START(*p) && UTF) {
6883                         STRLEN numlen;
6884                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
6885                                                &numlen, UTF8_ALLOW_DEFAULT);
6886                         p += numlen;
6887                     }
6888                     else
6889                         ender = *p++;
6890                     break;
6891                 }
6892                 if ( RExC_flags & RXf_PMf_EXTENDED)
6893                     p = regwhite( pRExC_state, p );
6894                 if (UTF && FOLD) {
6895                     /* Prime the casefolded buffer. */
6896                     ender = toFOLD_uni(ender, tmpbuf, &foldlen);
6897                 }
6898                 if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */
6899                     if (len)
6900                         p = oldp;
6901                     else if (UTF) {
6902                          if (FOLD) {
6903                               /* Emit all the Unicode characters. */
6904                               STRLEN numlen;
6905                               for (foldbuf = tmpbuf;
6906                                    foldlen;
6907                                    foldlen -= numlen) {
6908                                    ender = utf8_to_uvchr(foldbuf, &numlen);
6909                                    if (numlen > 0) {
6910                                         const STRLEN unilen = reguni(pRExC_state, ender, s);
6911                                         s       += unilen;
6912                                         len     += unilen;
6913                                         /* In EBCDIC the numlen
6914                                          * and unilen can differ. */
6915                                         foldbuf += numlen;
6916                                         if (numlen >= foldlen)
6917                                              break;
6918                                    }
6919                                    else
6920                                         break; /* "Can't happen." */
6921                               }
6922                          }
6923                          else {
6924                               const STRLEN unilen = reguni(pRExC_state, ender, s);
6925                               if (unilen > 0) {
6926                                    s   += unilen;
6927                                    len += unilen;
6928                               }
6929                          }
6930                     }
6931                     else {
6932                         len++;
6933                         REGC((char)ender, s++);
6934                     }
6935                     break;
6936                 }
6937                 if (UTF) {
6938                      if (FOLD) {
6939                           /* Emit all the Unicode characters. */
6940                           STRLEN numlen;
6941                           for (foldbuf = tmpbuf;
6942                                foldlen;
6943                                foldlen -= numlen) {
6944                                ender = utf8_to_uvchr(foldbuf, &numlen);
6945                                if (numlen > 0) {
6946                                     const STRLEN unilen = reguni(pRExC_state, ender, s);
6947                                     len     += unilen;
6948                                     s       += unilen;
6949                                     /* In EBCDIC the numlen
6950                                      * and unilen can differ. */
6951                                     foldbuf += numlen;
6952                                     if (numlen >= foldlen)
6953                                          break;
6954                                }
6955                                else
6956                                     break;
6957                           }
6958                      }
6959                      else {
6960                           const STRLEN unilen = reguni(pRExC_state, ender, s);
6961                           if (unilen > 0) {
6962                                s   += unilen;
6963                                len += unilen;
6964                           }
6965                      }
6966                      len--;
6967                 }
6968                 else
6969                     REGC((char)ender, s++);
6970             }
6971         loopdone:
6972             RExC_parse = p - 1;
6973             Set_Node_Cur_Length(ret); /* MJD */
6974             nextchar(pRExC_state);
6975             {
6976                 /* len is STRLEN which is unsigned, need to copy to signed */
6977                 IV iv = len;
6978                 if (iv < 0)
6979                     vFAIL("Internal disaster");
6980             }
6981             if (len > 0)
6982                 *flagp |= HASWIDTH;
6983             if (len == 1 && UNI_IS_INVARIANT(ender))
6984                 *flagp |= SIMPLE;
6985                 
6986             if (SIZE_ONLY)
6987                 RExC_size += STR_SZ(len);
6988             else {
6989                 STR_LEN(ret) = len;
6990                 RExC_emit += STR_SZ(len);
6991             }
6992         }
6993         break;
6994     }
6995
6996     return(ret);
6997 }
6998
6999 STATIC char *
7000 S_regwhite( RExC_state_t *pRExC_state, char *p )
7001 {
7002     const char *e = RExC_end;
7003     while (p < e) {
7004         if (isSPACE(*p))
7005             ++p;
7006         else if (*p == '#') {
7007             bool ended = 0;
7008             do {
7009                 if (*p++ == '\n') {
7010                     ended = 1;
7011                     break;
7012                 }
7013             } while (p < e);
7014             if (!ended)
7015                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
7016         }
7017         else
7018             break;
7019     }
7020     return p;
7021 }
7022
7023 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
7024    Character classes ([:foo:]) can also be negated ([:^foo:]).
7025    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
7026    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
7027    but trigger failures because they are currently unimplemented. */
7028
7029 #define POSIXCC_DONE(c)   ((c) == ':')
7030 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
7031 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
7032
7033 STATIC I32
7034 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
7035 {
7036     dVAR;
7037     I32 namedclass = OOB_NAMEDCLASS;
7038
7039     if (value == '[' && RExC_parse + 1 < RExC_end &&
7040         /* I smell either [: or [= or [. -- POSIX has been here, right? */
7041         POSIXCC(UCHARAT(RExC_parse))) {
7042         const char c = UCHARAT(RExC_parse);
7043         char* const s = RExC_parse++;
7044         
7045         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
7046             RExC_parse++;
7047         if (RExC_parse == RExC_end)
7048             /* Grandfather lone [:, [=, [. */
7049             RExC_parse = s;
7050         else {
7051             const char* const t = RExC_parse++; /* skip over the c */
7052             assert(*t == c);
7053
7054             if (UCHARAT(RExC_parse) == ']') {
7055                 const char *posixcc = s + 1;
7056                 RExC_parse++; /* skip over the ending ] */
7057
7058                 if (*s == ':') {
7059                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
7060                     const I32 skip = t - posixcc;
7061
7062                     /* Initially switch on the length of the name.  */
7063                     switch (skip) {
7064                     case 4:
7065                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
7066                             namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
7067                         break;
7068                     case 5:
7069                         /* Names all of length 5.  */
7070                         /* alnum alpha ascii blank cntrl digit graph lower
7071                            print punct space upper  */
7072                         /* Offset 4 gives the best switch position.  */
7073                         switch (posixcc[4]) {
7074                         case 'a':
7075                             if (memEQ(posixcc, "alph", 4)) /* alpha */
7076                                 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
7077                             break;
7078                         case 'e':
7079                             if (memEQ(posixcc, "spac", 4)) /* space */
7080                                 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
7081                             break;
7082                         case 'h':
7083                             if (memEQ(posixcc, "grap", 4)) /* graph */
7084                                 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
7085                             break;
7086                         case 'i':
7087                             if (memEQ(posixcc, "asci", 4)) /* ascii */
7088                                 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
7089                             break;
7090                         case 'k':
7091                             if (memEQ(posixcc, "blan", 4)) /* blank */
7092                                 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
7093                             break;
7094                         case 'l':
7095                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
7096                                 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
7097                             break;
7098                         case 'm':
7099                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
7100                                 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
7101                             break;
7102                         case 'r':
7103                             if (memEQ(posixcc, "lowe", 4)) /* lower */
7104                                 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
7105                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
7106                                 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
7107                             break;
7108                         case 't':
7109                             if (memEQ(posixcc, "digi", 4)) /* digit */
7110                                 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
7111                             else if (memEQ(posixcc, "prin", 4)) /* print */
7112                                 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
7113                             else if (memEQ(posixcc, "punc", 4)) /* punct */
7114                                 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
7115                             break;
7116                         }
7117                         break;
7118                     case 6:
7119                         if (memEQ(posixcc, "xdigit", 6))
7120                             namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
7121                         break;
7122                     }
7123
7124                     if (namedclass == OOB_NAMEDCLASS)
7125                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
7126                                       t - s - 1, s + 1);
7127                     assert (posixcc[skip] == ':');
7128                     assert (posixcc[skip+1] == ']');
7129                 } else if (!SIZE_ONLY) {
7130                     /* [[=foo=]] and [[.foo.]] are still future. */
7131
7132                     /* adjust RExC_parse so the warning shows after
7133                        the class closes */
7134                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
7135                         RExC_parse++;
7136                     Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
7137                 }
7138             } else {
7139                 /* Maternal grandfather:
7140                  * "[:" ending in ":" but not in ":]" */
7141                 RExC_parse = s;
7142             }
7143         }
7144     }
7145
7146     return namedclass;
7147 }
7148
7149 STATIC void
7150 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
7151 {
7152     dVAR;
7153     if (POSIXCC(UCHARAT(RExC_parse))) {
7154         const char *s = RExC_parse;
7155         const char  c = *s++;
7156
7157         while (isALNUM(*s))
7158             s++;
7159         if (*s && c == *s && s[1] == ']') {
7160             if (ckWARN(WARN_REGEXP))
7161                 vWARN3(s+2,
7162                         "POSIX syntax [%c %c] belongs inside character classes",
7163                         c, c);
7164
7165             /* [[=foo=]] and [[.foo.]] are still future. */
7166             if (POSIXCC_NOTYET(c)) {
7167                 /* adjust RExC_parse so the error shows after
7168                    the class closes */
7169                 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
7170                     NOOP;
7171                 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
7172             }
7173         }
7174     }
7175 }
7176
7177
7178 #define _C_C_T_(NAME,TEST,WORD)                         \
7179 ANYOF_##NAME:                                           \
7180     if (LOC)                                            \
7181         ANYOF_CLASS_SET(ret, ANYOF_##NAME);             \
7182     else {                                              \
7183         for (value = 0; value < 256; value++)           \
7184             if (TEST)                                   \
7185                 ANYOF_BITMAP_SET(ret, value);           \
7186     }                                                   \
7187     yesno = '+';                                        \
7188     what = WORD;                                        \
7189     break;                                              \
7190 case ANYOF_N##NAME:                                     \
7191     if (LOC)                                            \
7192         ANYOF_CLASS_SET(ret, ANYOF_N##NAME);            \
7193     else {                                              \
7194         for (value = 0; value < 256; value++)           \
7195             if (!TEST)                                  \
7196                 ANYOF_BITMAP_SET(ret, value);           \
7197     }                                                   \
7198     yesno = '!';                                        \
7199     what = WORD;                                        \
7200     break
7201
7202
7203 /*
7204    parse a class specification and produce either an ANYOF node that
7205    matches the pattern or if the pattern matches a single char only and
7206    that char is < 256 and we are case insensitive then we produce an 
7207    EXACT node instead.
7208 */
7209
7210 STATIC regnode *
7211 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
7212 {
7213     dVAR;
7214     register UV value = 0;
7215     register UV nextvalue;
7216     register IV prevvalue = OOB_UNICODE;
7217     register IV range = 0;
7218     register regnode *ret;
7219     STRLEN numlen;
7220     IV namedclass;
7221     char *rangebegin = NULL;
7222     bool need_class = 0;
7223     SV *listsv = NULL;
7224     UV n;
7225     bool optimize_invert   = TRUE;
7226     AV* unicode_alternate  = NULL;
7227 #ifdef EBCDIC
7228     UV literal_endpoint = 0;
7229 #endif
7230     UV stored = 0;  /* number of chars stored in the class */
7231
7232     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
7233         case we need to change the emitted regop to an EXACT. */
7234     const char * orig_parse = RExC_parse;
7235     GET_RE_DEBUG_FLAGS_DECL;
7236 #ifndef DEBUGGING
7237     PERL_UNUSED_ARG(depth);
7238 #endif
7239
7240     DEBUG_PARSE("clas");
7241
7242     /* Assume we are going to generate an ANYOF node. */
7243     ret = reganode(pRExC_state, ANYOF, 0);
7244
7245     if (!SIZE_ONLY)
7246         ANYOF_FLAGS(ret) = 0;
7247
7248     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
7249         RExC_naughty++;
7250         RExC_parse++;
7251         if (!SIZE_ONLY)
7252             ANYOF_FLAGS(ret) |= ANYOF_INVERT;
7253     }
7254
7255     if (SIZE_ONLY) {
7256         RExC_size += ANYOF_SKIP;
7257         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
7258     }
7259     else {
7260         RExC_emit += ANYOF_SKIP;
7261         if (FOLD)
7262             ANYOF_FLAGS(ret) |= ANYOF_FOLD;
7263         if (LOC)
7264             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
7265         ANYOF_BITMAP_ZERO(ret);
7266         listsv = newSVpvs("# comment\n");
7267     }
7268
7269     nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
7270
7271     if (!SIZE_ONLY && POSIXCC(nextvalue))
7272         checkposixcc(pRExC_state);
7273
7274     /* allow 1st char to be ] (allowing it to be - is dealt with later) */
7275     if (UCHARAT(RExC_parse) == ']')
7276         goto charclassloop;
7277
7278 parseit:
7279     while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
7280
7281     charclassloop:
7282
7283         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
7284
7285         if (!range)
7286             rangebegin = RExC_parse;
7287         if (UTF) {
7288             value = utf8n_to_uvchr((U8*)RExC_parse,
7289                                    RExC_end - RExC_parse,
7290                                    &numlen, UTF8_ALLOW_DEFAULT);
7291             RExC_parse += numlen;
7292         }
7293         else
7294             value = UCHARAT(RExC_parse++);
7295
7296         nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
7297         if (value == '[' && POSIXCC(nextvalue))
7298             namedclass = regpposixcc(pRExC_state, value);
7299         else if (value == '\\') {
7300             if (UTF) {
7301                 value = utf8n_to_uvchr((U8*)RExC_parse,
7302                                    RExC_end - RExC_parse,
7303                                    &numlen, UTF8_ALLOW_DEFAULT);
7304                 RExC_parse += numlen;
7305             }
7306             else
7307                 value = UCHARAT(RExC_parse++);
7308             /* Some compilers cannot handle switching on 64-bit integer
7309              * values, therefore value cannot be an UV.  Yes, this will
7310              * be a problem later if we want switch on Unicode.
7311              * A similar issue a little bit later when switching on
7312              * namedclass. --jhi */
7313             switch ((I32)value) {
7314             case 'w':   namedclass = ANYOF_ALNUM;       break;
7315             case 'W':   namedclass = ANYOF_NALNUM;      break;
7316             case 's':   namedclass = ANYOF_SPACE;       break;
7317             case 'S':   namedclass = ANYOF_NSPACE;      break;
7318             case 'd':   namedclass = ANYOF_DIGIT;       break;
7319             case 'D':   namedclass = ANYOF_NDIGIT;      break;
7320             case 'N':  /* Handle \N{NAME} in class */
7321                 {
7322                     /* We only pay attention to the first char of 
7323                     multichar strings being returned. I kinda wonder
7324                     if this makes sense as it does change the behaviour
7325                     from earlier versions, OTOH that behaviour was broken
7326                     as well. */
7327                     UV v; /* value is register so we cant & it /grrr */
7328                     if (reg_namedseq(pRExC_state, &v)) {
7329                         goto parseit;
7330                     }
7331                     value= v; 
7332                 }
7333                 break;
7334             case 'p':
7335             case 'P':
7336                 {
7337                 char *e;
7338                 if (RExC_parse >= RExC_end)
7339                     vFAIL2("Empty \\%c{}", (U8)value);
7340                 if (*RExC_parse == '{') {
7341                     const U8 c = (U8)value;
7342                     e = strchr(RExC_parse++, '}');
7343                     if (!e)
7344                         vFAIL2("Missing right brace on \\%c{}", c);
7345                     while (isSPACE(UCHARAT(RExC_parse)))
7346                         RExC_parse++;
7347                     if (e == RExC_parse)
7348                         vFAIL2("Empty \\%c{}", c);
7349                     n = e - RExC_parse;
7350                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
7351                         n--;
7352                 }
7353                 else {
7354                     e = RExC_parse;
7355                     n = 1;
7356                 }
7357                 if (!SIZE_ONLY) {
7358                     if (UCHARAT(RExC_parse) == '^') {
7359                          RExC_parse++;
7360                          n--;
7361                          value = value == 'p' ? 'P' : 'p'; /* toggle */
7362                          while (isSPACE(UCHARAT(RExC_parse))) {
7363                               RExC_parse++;
7364                               n--;
7365                          }
7366                     }
7367                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%.*s\n",
7368                         (value=='p' ? '+' : '!'), (int)n, RExC_parse);
7369                 }
7370                 RExC_parse = e + 1;
7371                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7372                 namedclass = ANYOF_MAX;  /* no official name, but it's named */
7373                 }
7374                 break;
7375             case 'n':   value = '\n';                   break;
7376             case 'r':   value = '\r';                   break;
7377             case 't':   value = '\t';                   break;
7378             case 'f':   value = '\f';                   break;
7379             case 'b':   value = '\b';                   break;
7380             case 'e':   value = ASCII_TO_NATIVE('\033');break;
7381             case 'a':   value = ASCII_TO_NATIVE('\007');break;
7382             case 'x':
7383                 if (*RExC_parse == '{') {
7384                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
7385                         | PERL_SCAN_DISALLOW_PREFIX;
7386                     char * const e = strchr(RExC_parse++, '}');
7387                     if (!e)
7388                         vFAIL("Missing right brace on \\x{}");
7389
7390                     numlen = e - RExC_parse;
7391                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
7392                     RExC_parse = e + 1;
7393                 }
7394                 else {
7395                     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
7396                     numlen = 2;
7397                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
7398                     RExC_parse += numlen;
7399                 }
7400                 if (PL_encoding && value < 0x100)
7401                     goto recode_encoding;
7402                 break;
7403             case 'c':
7404                 value = UCHARAT(RExC_parse++);
7405                 value = toCTRL(value);
7406                 break;
7407             case '0': case '1': case '2': case '3': case '4':
7408             case '5': case '6': case '7': case '8': case '9':
7409                 {
7410                     I32 flags = 0;
7411                     numlen = 3;
7412                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
7413                     RExC_parse += numlen;
7414                     if (PL_encoding && value < 0x100)
7415                         goto recode_encoding;
7416                     break;
7417                 }
7418             recode_encoding:
7419                 {
7420                     SV* enc = PL_encoding;
7421                     value = reg_recode((const char)(U8)value, &enc);
7422                     if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP))
7423                         vWARN(RExC_parse,
7424                               "Invalid escape in the specified encoding");
7425                     break;
7426                 }
7427             default:
7428                 if (!SIZE_ONLY && isALPHA(value) && ckWARN(WARN_REGEXP))
7429                     vWARN2(RExC_parse,
7430                            "Unrecognized escape \\%c in character class passed through",
7431                            (int)value);
7432                 break;
7433             }
7434         } /* end of \blah */
7435 #ifdef EBCDIC
7436         else
7437             literal_endpoint++;
7438 #endif
7439
7440         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
7441
7442             if (!SIZE_ONLY && !need_class)
7443                 ANYOF_CLASS_ZERO(ret);
7444
7445             need_class = 1;
7446
7447             /* a bad range like a-\d, a-[:digit:] ? */
7448             if (range) {
7449                 if (!SIZE_ONLY) {
7450                     if (ckWARN(WARN_REGEXP)) {
7451                         const int w =
7452                             RExC_parse >= rangebegin ?
7453                             RExC_parse - rangebegin : 0;
7454                         vWARN4(RExC_parse,
7455                                "False [] range \"%*.*s\"",
7456                                w, w, rangebegin);
7457                     }
7458                     if (prevvalue < 256) {
7459                         ANYOF_BITMAP_SET(ret, prevvalue);
7460                         ANYOF_BITMAP_SET(ret, '-');
7461                     }
7462                     else {
7463                         ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7464                         Perl_sv_catpvf(aTHX_ listsv,
7465                                        "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
7466                     }
7467                 }
7468
7469                 range = 0; /* this was not a true range */
7470             }
7471
7472
7473     
7474             if (!SIZE_ONLY) {
7475                 const char *what = NULL;
7476                 char yesno = 0;
7477
7478                 if (namedclass > OOB_NAMEDCLASS)
7479                     optimize_invert = FALSE;
7480                 /* Possible truncation here but in some 64-bit environments
7481                  * the compiler gets heartburn about switch on 64-bit values.
7482                  * A similar issue a little earlier when switching on value.
7483                  * --jhi */
7484                 switch ((I32)namedclass) {
7485                 case _C_C_T_(ALNUM, isALNUM(value), "Word");
7486                 case _C_C_T_(ALNUMC, isALNUMC(value), "Alnum");
7487                 case _C_C_T_(ALPHA, isALPHA(value), "Alpha");
7488                 case _C_C_T_(BLANK, isBLANK(value), "Blank");
7489                 case _C_C_T_(CNTRL, isCNTRL(value), "Cntrl");
7490                 case _C_C_T_(GRAPH, isGRAPH(value), "Graph");
7491                 case _C_C_T_(LOWER, isLOWER(value), "Lower");
7492                 case _C_C_T_(PRINT, isPRINT(value), "Print");
7493                 case _C_C_T_(PSXSPC, isPSXSPC(value), "Space");
7494                 case _C_C_T_(PUNCT, isPUNCT(value), "Punct");
7495                 case _C_C_T_(SPACE, isSPACE(value), "SpacePerl");
7496                 case _C_C_T_(UPPER, isUPPER(value), "Upper");
7497                 case _C_C_T_(XDIGIT, isXDIGIT(value), "XDigit");
7498                 case ANYOF_ASCII:
7499                     if (LOC)
7500                         ANYOF_CLASS_SET(ret, ANYOF_ASCII);
7501                     else {
7502 #ifndef EBCDIC
7503                         for (value = 0; value < 128; value++)
7504                             ANYOF_BITMAP_SET(ret, value);
7505 #else  /* EBCDIC */
7506                         for (value = 0; value < 256; value++) {
7507                             if (isASCII(value))
7508                                 ANYOF_BITMAP_SET(ret, value);
7509                         }
7510 #endif /* EBCDIC */
7511                     }
7512                     yesno = '+';
7513                     what = "ASCII";
7514                     break;
7515                 case ANYOF_NASCII:
7516                     if (LOC)
7517                         ANYOF_CLASS_SET(ret, ANYOF_NASCII);
7518                     else {
7519 #ifndef EBCDIC
7520                         for (value = 128; value < 256; value++)
7521                             ANYOF_BITMAP_SET(ret, value);
7522 #else  /* EBCDIC */
7523                         for (value = 0; value < 256; value++) {
7524                             if (!isASCII(value))
7525                                 ANYOF_BITMAP_SET(ret, value);
7526                         }
7527 #endif /* EBCDIC */
7528                     }
7529                     yesno = '!';
7530                     what = "ASCII";
7531                     break;              
7532                 case ANYOF_DIGIT:
7533                     if (LOC)
7534                         ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
7535                     else {
7536                         /* consecutive digits assumed */
7537                         for (value = '0'; value <= '9'; value++)
7538                             ANYOF_BITMAP_SET(ret, value);
7539                     }
7540                     yesno = '+';
7541                     what = "Digit";
7542                     break;
7543                 case ANYOF_NDIGIT:
7544                     if (LOC)
7545                         ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
7546                     else {
7547                         /* consecutive digits assumed */
7548                         for (value = 0; value < '0'; value++)
7549                             ANYOF_BITMAP_SET(ret, value);
7550                         for (value = '9' + 1; value < 256; value++)
7551                             ANYOF_BITMAP_SET(ret, value);
7552                     }
7553                     yesno = '!';
7554                     what = "Digit";
7555                     break;              
7556                 case ANYOF_MAX:
7557                     /* this is to handle \p and \P */
7558                     break;
7559                 default:
7560                     vFAIL("Invalid [::] class");
7561                     break;
7562                 }
7563                 if (what) {
7564                     /* Strings such as "+utf8::isWord\n" */
7565                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
7566                 }
7567                 if (LOC)
7568                     ANYOF_FLAGS(ret) |= ANYOF_CLASS;
7569                 continue;
7570             }
7571         } /* end of namedclass \blah */
7572
7573         if (range) {
7574             if (prevvalue > (IV)value) /* b-a */ {
7575                 const int w = RExC_parse - rangebegin;
7576                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
7577                 range = 0; /* not a valid range */
7578             }
7579         }
7580         else {
7581             prevvalue = value; /* save the beginning of the range */
7582             if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
7583                 RExC_parse[1] != ']') {
7584                 RExC_parse++;
7585
7586                 /* a bad range like \w-, [:word:]- ? */
7587                 if (namedclass > OOB_NAMEDCLASS) {
7588                     if (ckWARN(WARN_REGEXP)) {
7589                         const int w =
7590                             RExC_parse >= rangebegin ?
7591                             RExC_parse - rangebegin : 0;
7592                         vWARN4(RExC_parse,
7593                                "False [] range \"%*.*s\"",
7594                                w, w, rangebegin);
7595                     }
7596                     if (!SIZE_ONLY)
7597                         ANYOF_BITMAP_SET(ret, '-');
7598                 } else
7599                     range = 1;  /* yeah, it's a range! */
7600                 continue;       /* but do it the next time */
7601             }
7602         }
7603
7604         /* now is the next time */
7605         /*stored += (value - prevvalue + 1);*/
7606         if (!SIZE_ONLY) {
7607             if (prevvalue < 256) {
7608                 const IV ceilvalue = value < 256 ? value : 255;
7609                 IV i;
7610 #ifdef EBCDIC
7611                 /* In EBCDIC [\x89-\x91] should include
7612                  * the \x8e but [i-j] should not. */
7613                 if (literal_endpoint == 2 &&
7614                     ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
7615                      (isUPPER(prevvalue) && isUPPER(ceilvalue))))
7616                 {
7617                     if (isLOWER(prevvalue)) {
7618                         for (i = prevvalue; i <= ceilvalue; i++)
7619                             if (isLOWER(i))
7620                                 ANYOF_BITMAP_SET(ret, i);
7621                     } else {
7622                         for (i = prevvalue; i <= ceilvalue; i++)
7623                             if (isUPPER(i))
7624                                 ANYOF_BITMAP_SET(ret, i);
7625                     }
7626                 }
7627                 else
7628 #endif
7629                       for (i = prevvalue; i <= ceilvalue; i++) {
7630                         if (!ANYOF_BITMAP_TEST(ret,i)) {
7631                             stored++;  
7632                             ANYOF_BITMAP_SET(ret, i);
7633                         }
7634                       }
7635           }
7636           if (value > 255 || UTF) {
7637                 const UV prevnatvalue  = NATIVE_TO_UNI(prevvalue);
7638                 const UV natvalue      = NATIVE_TO_UNI(value);
7639                 stored+=2; /* can't optimize this class */
7640                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7641                 if (prevnatvalue < natvalue) { /* what about > ? */
7642                     Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
7643                                    prevnatvalue, natvalue);
7644                 }
7645                 else if (prevnatvalue == natvalue) {
7646                     Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", natvalue);
7647                     if (FOLD) {
7648                          U8 foldbuf[UTF8_MAXBYTES_CASE+1];
7649                          STRLEN foldlen;
7650                          const UV f = to_uni_fold(natvalue, foldbuf, &foldlen);
7651
7652 #ifdef EBCDIC /* RD t/uni/fold ff and 6b */
7653                          if (RExC_precomp[0] == ':' &&
7654                              RExC_precomp[1] == '[' &&
7655                              (f == 0xDF || f == 0x92)) {
7656                              f = NATIVE_TO_UNI(f);
7657                         }
7658 #endif
7659                          /* If folding and foldable and a single
7660                           * character, insert also the folded version
7661                           * to the charclass. */
7662                          if (f != value) {
7663 #ifdef EBCDIC /* RD tunifold ligatures s,t fb05, fb06 */
7664                              if ((RExC_precomp[0] == ':' &&
7665                                   RExC_precomp[1] == '[' &&
7666                                   (f == 0xA2 &&
7667                                    (value == 0xFB05 || value == 0xFB06))) ?
7668                                  foldlen == ((STRLEN)UNISKIP(f) - 1) :
7669                                  foldlen == (STRLEN)UNISKIP(f) )
7670 #else
7671                               if (foldlen == (STRLEN)UNISKIP(f))
7672 #endif
7673                                   Perl_sv_catpvf(aTHX_ listsv,
7674                                                  "%04"UVxf"\n", f);
7675                               else {
7676                                   /* Any multicharacter foldings
7677                                    * require the following transform:
7678                                    * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst)
7679                                    * where E folds into "pq" and F folds
7680                                    * into "rst", all other characters
7681                                    * fold to single characters.  We save
7682                                    * away these multicharacter foldings,
7683                                    * to be later saved as part of the
7684                                    * additional "s" data. */
7685                                   SV *sv;
7686
7687                                   if (!unicode_alternate)
7688                                       unicode_alternate = newAV();
7689                                   sv = newSVpvn((char*)foldbuf, foldlen);
7690                                   SvUTF8_on(sv);
7691                                   av_push(unicode_alternate, sv);
7692                               }
7693                          }
7694
7695                          /* If folding and the value is one of the Greek
7696                           * sigmas insert a few more sigmas to make the
7697                           * folding rules of the sigmas to work right.
7698                           * Note that not all the possible combinations
7699                           * are handled here: some of them are handled
7700                           * by the standard folding rules, and some of
7701                           * them (literal or EXACTF cases) are handled
7702                           * during runtime in regexec.c:S_find_byclass(). */
7703                          if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
7704                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7705                                              (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
7706                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7707                                              (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
7708                          }
7709                          else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
7710                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7711                                              (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
7712                     }
7713                 }
7714             }
7715 #ifdef EBCDIC
7716             literal_endpoint = 0;
7717 #endif
7718         }
7719
7720         range = 0; /* this range (if it was one) is done now */
7721     }
7722
7723     if (need_class) {
7724         ANYOF_FLAGS(ret) |= ANYOF_LARGE;
7725         if (SIZE_ONLY)
7726             RExC_size += ANYOF_CLASS_ADD_SKIP;
7727         else
7728             RExC_emit += ANYOF_CLASS_ADD_SKIP;
7729     }
7730
7731
7732     if (SIZE_ONLY)
7733         return ret;
7734     /****** !SIZE_ONLY AFTER HERE *********/
7735
7736     if( stored == 1 && value < 256
7737         && !( ANYOF_FLAGS(ret) & ( ANYOF_FLAGS_ALL ^ ANYOF_FOLD ) )
7738     ) {
7739         /* optimize single char class to an EXACT node
7740            but *only* when its not a UTF/high char  */
7741         const char * cur_parse= RExC_parse;
7742         RExC_emit = (regnode *)orig_emit;
7743         RExC_parse = (char *)orig_parse;
7744         ret = reg_node(pRExC_state,
7745                        (U8)((ANYOF_FLAGS(ret) & ANYOF_FOLD) ? EXACTF : EXACT));
7746         RExC_parse = (char *)cur_parse;
7747         *STRING(ret)= (char)value;
7748         STR_LEN(ret)= 1;
7749         RExC_emit += STR_SZ(1);
7750         return ret;
7751     }
7752     /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
7753     if ( /* If the only flag is folding (plus possibly inversion). */
7754         ((ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD)
7755        ) {
7756         for (value = 0; value < 256; ++value) {
7757             if (ANYOF_BITMAP_TEST(ret, value)) {
7758                 UV fold = PL_fold[value];
7759
7760                 if (fold != value)
7761                     ANYOF_BITMAP_SET(ret, fold);
7762             }
7763         }
7764         ANYOF_FLAGS(ret) &= ~ANYOF_FOLD;
7765     }
7766
7767     /* optimize inverted simple patterns (e.g. [^a-z]) */
7768     if (optimize_invert &&
7769         /* If the only flag is inversion. */
7770         (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
7771         for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
7772             ANYOF_BITMAP(ret)[value] ^= ANYOF_FLAGS_ALL;
7773         ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
7774     }
7775     {
7776         AV * const av = newAV();
7777         SV *rv;
7778         /* The 0th element stores the character class description
7779          * in its textual form: used later (regexec.c:Perl_regclass_swash())
7780          * to initialize the appropriate swash (which gets stored in
7781          * the 1st element), and also useful for dumping the regnode.
7782          * The 2nd element stores the multicharacter foldings,
7783          * used later (regexec.c:S_reginclass()). */
7784         av_store(av, 0, listsv);
7785         av_store(av, 1, NULL);
7786         av_store(av, 2, (SV*)unicode_alternate);
7787         rv = newRV_noinc((SV*)av);
7788         n = add_data(pRExC_state, 1, "s");
7789         RExC_rxi->data->data[n] = (void*)rv;
7790         ARG_SET(ret, n);
7791     }
7792     return ret;
7793 }
7794 #undef _C_C_T_
7795
7796
7797 /* reg_skipcomment()
7798
7799    Absorbs an /x style # comments from the input stream.
7800    Returns true if there is more text remaining in the stream.
7801    Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
7802    terminates the pattern without including a newline.
7803
7804    Note its the callers responsibility to ensure that we are
7805    actually in /x mode
7806
7807 */
7808
7809 STATIC bool
7810 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
7811 {
7812     bool ended = 0;
7813     while (RExC_parse < RExC_end)
7814         if (*RExC_parse++ == '\n') {
7815             ended = 1;
7816             break;
7817         }
7818     if (!ended) {
7819         /* we ran off the end of the pattern without ending
7820            the comment, so we have to add an \n when wrapping */
7821         RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
7822         return 0;
7823     } else
7824         return 1;
7825 }
7826
7827 /* nextchar()
7828
7829    Advance that parse position, and optionall absorbs
7830    "whitespace" from the inputstream.
7831
7832    Without /x "whitespace" means (?#...) style comments only,
7833    with /x this means (?#...) and # comments and whitespace proper.
7834
7835    Returns the RExC_parse point from BEFORE the scan occurs.
7836
7837    This is the /x friendly way of saying RExC_parse++.
7838 */
7839
7840 STATIC char*
7841 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
7842 {
7843     char* const retval = RExC_parse++;
7844
7845     for (;;) {
7846         if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
7847                 RExC_parse[2] == '#') {
7848             while (*RExC_parse != ')') {
7849                 if (RExC_parse == RExC_end)
7850                     FAIL("Sequence (?#... not terminated");
7851                 RExC_parse++;
7852             }
7853             RExC_parse++;
7854             continue;
7855         }
7856         if (RExC_flags & RXf_PMf_EXTENDED) {
7857             if (isSPACE(*RExC_parse)) {
7858                 RExC_parse++;
7859                 continue;
7860             }
7861             else if (*RExC_parse == '#') {
7862                 if ( reg_skipcomment( pRExC_state ) )
7863                     continue;
7864             }
7865         }
7866         return retval;
7867     }
7868 }
7869
7870 /*
7871 - reg_node - emit a node
7872 */
7873 STATIC regnode *                        /* Location. */
7874 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
7875 {
7876     dVAR;
7877     register regnode *ptr;
7878     regnode * const ret = RExC_emit;
7879     GET_RE_DEBUG_FLAGS_DECL;
7880
7881     if (SIZE_ONLY) {
7882         SIZE_ALIGN(RExC_size);
7883         RExC_size += 1;
7884         return(ret);
7885     }
7886 #ifdef DEBUGGING
7887     if (OP(RExC_emit) == 255)
7888         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %s: %d ",
7889             reg_name[op], OP(RExC_emit));
7890 #endif  
7891     NODE_ALIGN_FILL(ret);
7892     ptr = ret;
7893     FILL_ADVANCE_NODE(ptr, op);
7894 #ifdef RE_TRACK_PATTERN_OFFSETS
7895     if (RExC_offsets) {         /* MJD */
7896         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
7897               "reg_node", __LINE__, 
7898               reg_name[op],
7899               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
7900                 ? "Overwriting end of array!\n" : "OK",
7901               (UV)(RExC_emit - RExC_emit_start),
7902               (UV)(RExC_parse - RExC_start),
7903               (UV)RExC_offsets[0])); 
7904         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
7905     }
7906 #endif
7907     RExC_emit = ptr;
7908     return(ret);
7909 }
7910
7911 /*
7912 - reganode - emit a node with an argument
7913 */
7914 STATIC regnode *                        /* Location. */
7915 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
7916 {
7917     dVAR;
7918     register regnode *ptr;
7919     regnode * const ret = RExC_emit;
7920     GET_RE_DEBUG_FLAGS_DECL;
7921
7922     if (SIZE_ONLY) {
7923         SIZE_ALIGN(RExC_size);
7924         RExC_size += 2;
7925         /* 
7926            We can't do this:
7927            
7928            assert(2==regarglen[op]+1); 
7929         
7930            Anything larger than this has to allocate the extra amount.
7931            If we changed this to be:
7932            
7933            RExC_size += (1 + regarglen[op]);
7934            
7935            then it wouldn't matter. Its not clear what side effect
7936            might come from that so its not done so far.
7937            -- dmq
7938         */
7939         return(ret);
7940     }
7941 #ifdef DEBUGGING
7942     if (OP(RExC_emit) == 255)
7943         Perl_croak(aTHX_ "panic: reganode overwriting end of allocated program space");
7944 #endif 
7945     NODE_ALIGN_FILL(ret);
7946     ptr = ret;
7947     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
7948 #ifdef RE_TRACK_PATTERN_OFFSETS
7949     if (RExC_offsets) {         /* MJD */
7950         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
7951               "reganode",
7952               __LINE__,
7953               reg_name[op],
7954               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
7955               "Overwriting end of array!\n" : "OK",
7956               (UV)(RExC_emit - RExC_emit_start),
7957               (UV)(RExC_parse - RExC_start),
7958               (UV)RExC_offsets[0])); 
7959         Set_Cur_Node_Offset;
7960     }
7961 #endif            
7962     RExC_emit = ptr;
7963     return(ret);
7964 }
7965
7966 /*
7967 - reguni - emit (if appropriate) a Unicode character
7968 */
7969 STATIC STRLEN
7970 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
7971 {
7972     dVAR;
7973     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
7974 }
7975
7976 /*
7977 - reginsert - insert an operator in front of already-emitted operand
7978 *
7979 * Means relocating the operand.
7980 */
7981 STATIC void
7982 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
7983 {
7984     dVAR;
7985     register regnode *src;
7986     register regnode *dst;
7987     register regnode *place;
7988     const int offset = regarglen[(U8)op];
7989     const int size = NODE_STEP_REGNODE + offset;
7990     GET_RE_DEBUG_FLAGS_DECL;
7991 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
7992     DEBUG_PARSE_FMT("inst"," - %s",reg_name[op]);
7993     if (SIZE_ONLY) {
7994         RExC_size += size;
7995         return;
7996     }
7997
7998     src = RExC_emit;
7999     RExC_emit += size;
8000     dst = RExC_emit;
8001     if (RExC_open_parens) {
8002         int paren;
8003         DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);
8004         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
8005             if ( RExC_open_parens[paren] >= opnd ) {
8006                 DEBUG_PARSE_FMT("open"," - %d",size);
8007                 RExC_open_parens[paren] += size;
8008             } else {
8009                 DEBUG_PARSE_FMT("open"," - %s","ok");
8010             }
8011             if ( RExC_close_parens[paren] >= opnd ) {
8012                 DEBUG_PARSE_FMT("close"," - %d",size);
8013                 RExC_close_parens[paren] += size;
8014             } else {
8015                 DEBUG_PARSE_FMT("close"," - %s","ok");
8016             }
8017         }
8018     }
8019
8020     while (src > opnd) {
8021         StructCopy(--src, --dst, regnode);
8022 #ifdef RE_TRACK_PATTERN_OFFSETS
8023         if (RExC_offsets) {     /* MJD 20010112 */
8024             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
8025                   "reg_insert",
8026                   __LINE__,
8027                   reg_name[op],
8028                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
8029                     ? "Overwriting end of array!\n" : "OK",
8030                   (UV)(src - RExC_emit_start),
8031                   (UV)(dst - RExC_emit_start),
8032                   (UV)RExC_offsets[0])); 
8033             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
8034             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
8035         }
8036 #endif
8037     }
8038     
8039
8040     place = opnd;               /* Op node, where operand used to be. */
8041 #ifdef RE_TRACK_PATTERN_OFFSETS
8042     if (RExC_offsets) {         /* MJD */
8043         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
8044               "reginsert",
8045               __LINE__,
8046               reg_name[op],
8047               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
8048               ? "Overwriting end of array!\n" : "OK",
8049               (UV)(place - RExC_emit_start),
8050               (UV)(RExC_parse - RExC_start),
8051               (UV)RExC_offsets[0]));
8052         Set_Node_Offset(place, RExC_parse);
8053         Set_Node_Length(place, 1);
8054     }
8055 #endif    
8056     src = NEXTOPER(place);
8057     FILL_ADVANCE_NODE(place, op);
8058     Zero(src, offset, regnode);
8059 }
8060
8061 /*
8062 - regtail - set the next-pointer at the end of a node chain of p to val.
8063 - SEE ALSO: regtail_study
8064 */
8065 /* TODO: All three parms should be const */
8066 STATIC void
8067 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
8068 {
8069     dVAR;
8070     register regnode *scan;
8071     GET_RE_DEBUG_FLAGS_DECL;
8072 #ifndef DEBUGGING
8073     PERL_UNUSED_ARG(depth);
8074 #endif
8075
8076     if (SIZE_ONLY)
8077         return;
8078
8079     /* Find last node. */
8080     scan = p;
8081     for (;;) {
8082         regnode * const temp = regnext(scan);
8083         DEBUG_PARSE_r({
8084             SV * const mysv=sv_newmortal();
8085             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
8086             regprop(RExC_rx, mysv, scan);
8087             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
8088                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
8089                     (temp == NULL ? "->" : ""),
8090                     (temp == NULL ? reg_name[OP(val)] : "")
8091             );
8092         });
8093         if (temp == NULL)
8094             break;
8095         scan = temp;
8096     }
8097
8098     if (reg_off_by_arg[OP(scan)]) {
8099         ARG_SET(scan, val - scan);
8100     }
8101     else {
8102         NEXT_OFF(scan) = val - scan;
8103     }
8104 }
8105
8106 #ifdef DEBUGGING
8107 /*
8108 - regtail_study - set the next-pointer at the end of a node chain of p to val.
8109 - Look for optimizable sequences at the same time.
8110 - currently only looks for EXACT chains.
8111
8112 This is expermental code. The idea is to use this routine to perform 
8113 in place optimizations on branches and groups as they are constructed,
8114 with the long term intention of removing optimization from study_chunk so
8115 that it is purely analytical.
8116
8117 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
8118 to control which is which.
8119
8120 */
8121 /* TODO: All four parms should be const */
8122
8123 STATIC U8
8124 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
8125 {
8126     dVAR;
8127     register regnode *scan;
8128     U8 exact = PSEUDO;
8129 #ifdef EXPERIMENTAL_INPLACESCAN
8130     I32 min = 0;
8131 #endif
8132
8133     GET_RE_DEBUG_FLAGS_DECL;
8134
8135
8136     if (SIZE_ONLY)
8137         return exact;
8138
8139     /* Find last node. */
8140
8141     scan = p;
8142     for (;;) {
8143         regnode * const temp = regnext(scan);
8144 #ifdef EXPERIMENTAL_INPLACESCAN
8145         if (PL_regkind[OP(scan)] == EXACT)
8146             if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
8147                 return EXACT;
8148 #endif
8149         if ( exact ) {
8150             switch (OP(scan)) {
8151                 case EXACT:
8152                 case EXACTF:
8153                 case EXACTFL:
8154                         if( exact == PSEUDO )
8155                             exact= OP(scan);
8156                         else if ( exact != OP(scan) )
8157                             exact= 0;
8158                 case NOTHING:
8159                     break;
8160                 default:
8161                     exact= 0;
8162             }
8163         }
8164         DEBUG_PARSE_r({
8165             SV * const mysv=sv_newmortal();
8166             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
8167             regprop(RExC_rx, mysv, scan);
8168             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
8169                 SvPV_nolen_const(mysv),
8170                 REG_NODE_NUM(scan),
8171                 reg_name[exact]);
8172         });
8173         if (temp == NULL)
8174             break;
8175         scan = temp;
8176     }
8177     DEBUG_PARSE_r({
8178         SV * const mysv_val=sv_newmortal();
8179         DEBUG_PARSE_MSG("");
8180         regprop(RExC_rx, mysv_val, val);
8181         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
8182                       SvPV_nolen_const(mysv_val),
8183                       (IV)REG_NODE_NUM(val),
8184                       (IV)(val - scan)
8185         );
8186     });
8187     if (reg_off_by_arg[OP(scan)]) {
8188         ARG_SET(scan, val - scan);
8189     }
8190     else {
8191         NEXT_OFF(scan) = val - scan;
8192     }
8193
8194     return exact;
8195 }
8196 #endif
8197
8198 /*
8199  - regcurly - a little FSA that accepts {\d+,?\d*}
8200  */
8201 STATIC I32
8202 S_regcurly(register const char *s)
8203 {
8204     if (*s++ != '{')
8205         return FALSE;
8206     if (!isDIGIT(*s))
8207         return FALSE;
8208     while (isDIGIT(*s))
8209         s++;
8210     if (*s == ',')
8211         s++;
8212     while (isDIGIT(*s))
8213         s++;
8214     if (*s != '}')
8215         return FALSE;
8216     return TRUE;
8217 }
8218
8219
8220 /*
8221  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
8222  */
8223 void
8224 Perl_regdump(pTHX_ const regexp *r)
8225 {
8226 #ifdef DEBUGGING
8227     dVAR;
8228     SV * const sv = sv_newmortal();
8229     SV *dsv= sv_newmortal();
8230     RXi_GET_DECL(r,ri);
8231
8232     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
8233
8234     /* Header fields of interest. */
8235     if (r->anchored_substr) {
8236         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
8237             RE_SV_DUMPLEN(r->anchored_substr), 30);
8238         PerlIO_printf(Perl_debug_log,
8239                       "anchored %s%s at %"IVdf" ",
8240                       s, RE_SV_TAIL(r->anchored_substr),
8241                       (IV)r->anchored_offset);
8242     } else if (r->anchored_utf8) {
8243         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
8244             RE_SV_DUMPLEN(r->anchored_utf8), 30);
8245         PerlIO_printf(Perl_debug_log,
8246                       "anchored utf8 %s%s at %"IVdf" ",
8247                       s, RE_SV_TAIL(r->anchored_utf8),
8248                       (IV)r->anchored_offset);
8249     }                 
8250     if (r->float_substr) {
8251         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
8252             RE_SV_DUMPLEN(r->float_substr), 30);
8253         PerlIO_printf(Perl_debug_log,
8254                       "floating %s%s at %"IVdf"..%"UVuf" ",
8255                       s, RE_SV_TAIL(r->float_substr),
8256                       (IV)r->float_min_offset, (UV)r->float_max_offset);
8257     } else if (r->float_utf8) {
8258         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
8259             RE_SV_DUMPLEN(r->float_utf8), 30);
8260         PerlIO_printf(Perl_debug_log,
8261                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
8262                       s, RE_SV_TAIL(r->float_utf8),
8263                       (IV)r->float_min_offset, (UV)r->float_max_offset);
8264     }
8265     if (r->check_substr || r->check_utf8)
8266         PerlIO_printf(Perl_debug_log,
8267                       (const char *)
8268                       (r->check_substr == r->float_substr
8269                        && r->check_utf8 == r->float_utf8
8270                        ? "(checking floating" : "(checking anchored"));
8271     if (r->extflags & RXf_NOSCAN)
8272         PerlIO_printf(Perl_debug_log, " noscan");
8273     if (r->extflags & RXf_CHECK_ALL)
8274         PerlIO_printf(Perl_debug_log, " isall");
8275     if (r->check_substr || r->check_utf8)
8276         PerlIO_printf(Perl_debug_log, ") ");
8277
8278     if (ri->regstclass) {
8279         regprop(r, sv, ri->regstclass);
8280         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
8281     }
8282     if (r->extflags & RXf_ANCH) {
8283         PerlIO_printf(Perl_debug_log, "anchored");
8284         if (r->extflags & RXf_ANCH_BOL)
8285             PerlIO_printf(Perl_debug_log, "(BOL)");
8286         if (r->extflags & RXf_ANCH_MBOL)
8287             PerlIO_printf(Perl_debug_log, "(MBOL)");
8288         if (r->extflags & RXf_ANCH_SBOL)
8289             PerlIO_printf(Perl_debug_log, "(SBOL)");
8290         if (r->extflags & RXf_ANCH_GPOS)
8291             PerlIO_printf(Perl_debug_log, "(GPOS)");
8292         PerlIO_putc(Perl_debug_log, ' ');
8293     }
8294     if (r->extflags & RXf_GPOS_SEEN)
8295         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
8296     if (r->intflags & PREGf_SKIP)
8297         PerlIO_printf(Perl_debug_log, "plus ");
8298     if (r->intflags & PREGf_IMPLICIT)
8299         PerlIO_printf(Perl_debug_log, "implicit ");
8300     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
8301     if (r->extflags & RXf_EVAL_SEEN)
8302         PerlIO_printf(Perl_debug_log, "with eval ");
8303     PerlIO_printf(Perl_debug_log, "\n");
8304 #else
8305     PERL_UNUSED_CONTEXT;
8306     PERL_UNUSED_ARG(r);
8307 #endif  /* DEBUGGING */
8308 }
8309
8310 /*
8311 - regprop - printable representation of opcode
8312 */
8313 void
8314 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
8315 {
8316 #ifdef DEBUGGING
8317     dVAR;
8318     register int k;
8319     RXi_GET_DECL(prog,progi);
8320     GET_RE_DEBUG_FLAGS_DECL;
8321     
8322
8323     sv_setpvn(sv, "", 0);
8324
8325     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
8326         /* It would be nice to FAIL() here, but this may be called from
8327            regexec.c, and it would be hard to supply pRExC_state. */
8328         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
8329     sv_catpv(sv, reg_name[OP(o)]); /* Take off const! */
8330
8331     k = PL_regkind[OP(o)];
8332
8333     if (k == EXACT) {
8334         SV * const dsv = sv_2mortal(newSVpvs(""));
8335         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
8336          * is a crude hack but it may be the best for now since 
8337          * we have no flag "this EXACTish node was UTF-8" 
8338          * --jhi */
8339         const char * const s = 
8340             pv_pretty(dsv, STRING(o), STR_LEN(o), 60, 
8341                 PL_colors[0], PL_colors[1],
8342                 PERL_PV_ESCAPE_UNI_DETECT |
8343                 PERL_PV_PRETTY_ELIPSES    |
8344                 PERL_PV_PRETTY_LTGT    
8345             ); 
8346         Perl_sv_catpvf(aTHX_ sv, " %s", s );
8347     } else if (k == TRIE) {
8348         /* print the details of the trie in dumpuntil instead, as
8349          * progi->data isn't available here */
8350         const char op = OP(o);
8351         const U32 n = ARG(o);
8352         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
8353                (reg_ac_data *)progi->data->data[n] :
8354                NULL;
8355         const reg_trie_data * const trie
8356             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
8357         
8358         Perl_sv_catpvf(aTHX_ sv, "-%s",reg_name[o->flags]);
8359         DEBUG_TRIE_COMPILE_r(
8360             Perl_sv_catpvf(aTHX_ sv,
8361                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
8362                 (UV)trie->startstate,
8363                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
8364                 (UV)trie->wordcount,
8365                 (UV)trie->minlen,
8366                 (UV)trie->maxlen,
8367                 (UV)TRIE_CHARCOUNT(trie),
8368                 (UV)trie->uniquecharcount
8369             )
8370         );
8371         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
8372             int i;
8373             int rangestart = -1;
8374             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
8375             Perl_sv_catpvf(aTHX_ sv, "[");
8376             for (i = 0; i <= 256; i++) {
8377                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
8378                     if (rangestart == -1)
8379                         rangestart = i;
8380                 } else if (rangestart != -1) {
8381                     if (i <= rangestart + 3)
8382                         for (; rangestart < i; rangestart++)
8383                             put_byte(sv, rangestart);
8384                     else {
8385                         put_byte(sv, rangestart);
8386                         sv_catpvs(sv, "-");
8387                         put_byte(sv, i - 1);
8388                     }
8389                     rangestart = -1;
8390                 }
8391             }
8392             Perl_sv_catpvf(aTHX_ sv, "]");
8393         } 
8394          
8395     } else if (k == CURLY) {
8396         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
8397             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
8398         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
8399     }
8400     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
8401         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
8402     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
8403         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
8404         if ( prog->paren_names ) {
8405             if ( k != REF || OP(o) < NREF) {        
8406                 AV *list= (AV *)progi->data->data[progi->name_list_idx];
8407                 SV **name= av_fetch(list, ARG(o), 0 );
8408                 if (name)
8409                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
8410             }       
8411             else {
8412                 AV *list= (AV *)progi->data->data[ progi->name_list_idx ];
8413                 SV *sv_dat=(SV*)progi->data->data[ ARG( o ) ];
8414                 I32 *nums=(I32*)SvPVX(sv_dat);
8415                 SV **name= av_fetch(list, nums[0], 0 );
8416                 I32 n;
8417                 if (name) {
8418                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
8419                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
8420                                     (n ? "," : ""), (IV)nums[n]);
8421                     }
8422                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
8423                 }
8424             }
8425         }            
8426     } else if (k == GOSUB) 
8427         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
8428     else if (k == VERB) {
8429         if (!o->flags) 
8430             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
8431                 SVfARG((SV*)progi->data->data[ ARG( o ) ]));
8432     } else if (k == LOGICAL)
8433         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
8434     else if (k == ANYOF) {
8435         int i, rangestart = -1;
8436         const U8 flags = ANYOF_FLAGS(o);
8437
8438         /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
8439         static const char * const anyofs[] = {
8440             "\\w",
8441             "\\W",
8442             "\\s",
8443             "\\S",
8444             "\\d",
8445             "\\D",
8446             "[:alnum:]",
8447             "[:^alnum:]",
8448             "[:alpha:]",
8449             "[:^alpha:]",
8450             "[:ascii:]",
8451             "[:^ascii:]",
8452             "[:ctrl:]",
8453             "[:^ctrl:]",
8454             "[:graph:]",
8455             "[:^graph:]",
8456             "[:lower:]",
8457             "[:^lower:]",
8458             "[:print:]",
8459             "[:^print:]",
8460             "[:punct:]",
8461             "[:^punct:]",
8462             "[:upper:]",
8463             "[:^upper:]",
8464             "[:xdigit:]",
8465             "[:^xdigit:]",
8466             "[:space:]",
8467             "[:^space:]",
8468             "[:blank:]",
8469             "[:^blank:]"
8470         };
8471
8472         if (flags & ANYOF_LOCALE)
8473             sv_catpvs(sv, "{loc}");
8474         if (flags & ANYOF_FOLD)
8475             sv_catpvs(sv, "{i}");
8476         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
8477         if (flags & ANYOF_INVERT)
8478             sv_catpvs(sv, "^");
8479         for (i = 0; i <= 256; i++) {
8480             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
8481                 if (rangestart == -1)
8482                     rangestart = i;
8483             } else if (rangestart != -1) {
8484                 if (i <= rangestart + 3)
8485                     for (; rangestart < i; rangestart++)
8486                         put_byte(sv, rangestart);
8487                 else {
8488                     put_byte(sv, rangestart);
8489                     sv_catpvs(sv, "-");
8490                     put_byte(sv, i - 1);
8491                 }
8492                 rangestart = -1;
8493             }
8494         }
8495
8496         if (o->flags & ANYOF_CLASS)
8497             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
8498                 if (ANYOF_CLASS_TEST(o,i))
8499                     sv_catpv(sv, anyofs[i]);
8500
8501         if (flags & ANYOF_UNICODE)
8502             sv_catpvs(sv, "{unicode}");
8503         else if (flags & ANYOF_UNICODE_ALL)
8504             sv_catpvs(sv, "{unicode_all}");
8505
8506         {
8507             SV *lv;
8508             SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
8509         
8510             if (lv) {
8511                 if (sw) {
8512                     U8 s[UTF8_MAXBYTES_CASE+1];
8513                 
8514                     for (i = 0; i <= 256; i++) { /* just the first 256 */
8515                         uvchr_to_utf8(s, i);
8516                         
8517                         if (i < 256 && swash_fetch(sw, s, TRUE)) {
8518                             if (rangestart == -1)
8519                                 rangestart = i;
8520                         } else if (rangestart != -1) {
8521                             if (i <= rangestart + 3)
8522                                 for (; rangestart < i; rangestart++) {
8523                                     const U8 * const e = uvchr_to_utf8(s,rangestart);
8524                                     U8 *p;
8525                                     for(p = s; p < e; p++)
8526                                         put_byte(sv, *p);
8527                                 }
8528                             else {
8529                                 const U8 *e = uvchr_to_utf8(s,rangestart);
8530                                 U8 *p;
8531                                 for (p = s; p < e; p++)
8532                                     put_byte(sv, *p);
8533                                 sv_catpvs(sv, "-");
8534                                 e = uvchr_to_utf8(s, i-1);
8535                                 for (p = s; p < e; p++)
8536                                     put_byte(sv, *p);
8537                                 }
8538                                 rangestart = -1;
8539                             }
8540                         }
8541                         
8542                     sv_catpvs(sv, "..."); /* et cetera */
8543                 }
8544
8545                 {
8546                     char *s = savesvpv(lv);
8547                     char * const origs = s;
8548                 
8549                     while (*s && *s != '\n')
8550                         s++;
8551                 
8552                     if (*s == '\n') {
8553                         const char * const t = ++s;
8554                         
8555                         while (*s) {
8556                             if (*s == '\n')
8557                                 *s = ' ';
8558                             s++;
8559                         }
8560                         if (s[-1] == ' ')
8561                             s[-1] = 0;
8562                         
8563                         sv_catpv(sv, t);
8564                     }
8565                 
8566                     Safefree(origs);
8567                 }
8568             }
8569         }
8570
8571         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
8572     }
8573     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
8574         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
8575 #else
8576     PERL_UNUSED_CONTEXT;
8577     PERL_UNUSED_ARG(sv);
8578     PERL_UNUSED_ARG(o);
8579     PERL_UNUSED_ARG(prog);
8580 #endif  /* DEBUGGING */
8581 }
8582
8583 SV *
8584 Perl_re_intuit_string(pTHX_ regexp *prog)
8585 {                               /* Assume that RE_INTUIT is set */
8586     dVAR;
8587     GET_RE_DEBUG_FLAGS_DECL;
8588     PERL_UNUSED_CONTEXT;
8589
8590     DEBUG_COMPILE_r(
8591         {
8592             const char * const s = SvPV_nolen_const(prog->check_substr
8593                       ? prog->check_substr : prog->check_utf8);
8594
8595             if (!PL_colorset) reginitcolors();
8596             PerlIO_printf(Perl_debug_log,
8597                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
8598                       PL_colors[4],
8599                       prog->check_substr ? "" : "utf8 ",
8600                       PL_colors[5],PL_colors[0],
8601                       s,
8602                       PL_colors[1],
8603                       (strlen(s) > 60 ? "..." : ""));
8604         } );
8605
8606     return prog->check_substr ? prog->check_substr : prog->check_utf8;
8607 }
8608
8609 /* 
8610    pregfree() 
8611    
8612    handles refcounting and freeing the perl core regexp structure. When 
8613    it is necessary to actually free the structure the first thing it 
8614    does is call the 'free' method of the regexp_engine associated to to 
8615    the regexp, allowing the handling of the void *pprivate; member 
8616    first. (This routine is not overridable by extensions, which is why 
8617    the extensions free is called first.)
8618    
8619    See regdupe and regdupe_internal if you change anything here. 
8620 */
8621 #ifndef PERL_IN_XSUB_RE
8622 void
8623 Perl_pregfree(pTHX_ struct regexp *r)
8624 {
8625     dVAR;
8626     GET_RE_DEBUG_FLAGS_DECL;
8627
8628     if (!r || (--r->refcnt > 0))
8629         return;
8630         
8631     CALLREGFREE_PVT(r); /* free the private data */
8632     RX_MATCH_COPY_FREE(r);
8633 #ifdef PERL_OLD_COPY_ON_WRITE
8634     if (r->saved_copy)
8635         SvREFCNT_dec(r->saved_copy);
8636 #endif
8637     if (r->substrs) {
8638         if (r->anchored_substr)
8639             SvREFCNT_dec(r->anchored_substr);
8640         if (r->anchored_utf8)
8641             SvREFCNT_dec(r->anchored_utf8);
8642         if (r->float_substr)
8643             SvREFCNT_dec(r->float_substr);
8644         if (r->float_utf8)
8645             SvREFCNT_dec(r->float_utf8);
8646         Safefree(r->substrs);
8647     }
8648     if (r->paren_names)
8649         SvREFCNT_dec(r->paren_names);
8650     Safefree(r->wrapped);
8651     Safefree(r->startp);
8652     Safefree(r->endp);
8653     Safefree(r);
8654 }
8655 #endif
8656
8657 /* regfree_internal() 
8658
8659    Free the private data in a regexp. This is overloadable by 
8660    extensions. Perl takes care of the regexp structure in pregfree(), 
8661    this covers the *pprivate pointer which technically perldoesnt 
8662    know about, however of course we have to handle the 
8663    regexp_internal structure when no extension is in use. 
8664    
8665    Note this is called before freeing anything in the regexp 
8666    structure. 
8667  */
8668  
8669 void
8670 Perl_regfree_internal(pTHX_ struct regexp *r)
8671 {
8672     dVAR;
8673     RXi_GET_DECL(r,ri);
8674     GET_RE_DEBUG_FLAGS_DECL;
8675     
8676     DEBUG_COMPILE_r({
8677         if (!PL_colorset)
8678             reginitcolors();
8679         {
8680             SV *dsv= sv_newmortal();
8681             RE_PV_QUOTED_DECL(s, (r->extflags & RXf_UTF8),
8682                 dsv, r->precomp, r->prelen, 60);
8683             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
8684                 PL_colors[4],PL_colors[5],s);
8685         }
8686     });
8687 #ifdef RE_TRACK_PATTERN_OFFSETS
8688     if (ri->u.offsets)
8689         Safefree(ri->u.offsets);             /* 20010421 MJD */
8690 #endif
8691     if (ri->data) {
8692         int n = ri->data->count;
8693         PAD* new_comppad = NULL;
8694         PAD* old_comppad;
8695         PADOFFSET refcnt;
8696
8697         while (--n >= 0) {
8698           /* If you add a ->what type here, update the comment in regcomp.h */
8699             switch (ri->data->what[n]) {
8700             case 's':
8701             case 'S':
8702             case 'u':
8703                 SvREFCNT_dec((SV*)ri->data->data[n]);
8704                 break;
8705             case 'f':
8706                 Safefree(ri->data->data[n]);
8707                 break;
8708             case 'p':
8709                 new_comppad = (AV*)ri->data->data[n];
8710                 break;
8711             case 'o':
8712                 if (new_comppad == NULL)
8713                     Perl_croak(aTHX_ "panic: pregfree comppad");
8714                 PAD_SAVE_LOCAL(old_comppad,
8715                     /* Watch out for global destruction's random ordering. */
8716                     (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
8717                 );
8718                 OP_REFCNT_LOCK;
8719                 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
8720                 OP_REFCNT_UNLOCK;
8721                 if (!refcnt)
8722                     op_free((OP_4tree*)ri->data->data[n]);
8723
8724                 PAD_RESTORE_LOCAL(old_comppad);
8725                 SvREFCNT_dec((SV*)new_comppad);
8726                 new_comppad = NULL;
8727                 break;
8728             case 'n':
8729                 break;
8730             case 'T':           
8731                 { /* Aho Corasick add-on structure for a trie node.
8732                      Used in stclass optimization only */
8733                     U32 refcount;
8734                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
8735                     OP_REFCNT_LOCK;
8736                     refcount = --aho->refcount;
8737                     OP_REFCNT_UNLOCK;
8738                     if ( !refcount ) {
8739                         PerlMemShared_free(aho->states);
8740                         PerlMemShared_free(aho->fail);
8741                          /* do this last!!!! */
8742                         PerlMemShared_free(ri->data->data[n]);
8743                         PerlMemShared_free(ri->regstclass);
8744                     }
8745                 }
8746                 break;
8747             case 't':
8748                 {
8749                     /* trie structure. */
8750                     U32 refcount;
8751                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
8752                     OP_REFCNT_LOCK;
8753                     refcount = --trie->refcount;
8754                     OP_REFCNT_UNLOCK;
8755                     if ( !refcount ) {
8756                         PerlMemShared_free(trie->charmap);
8757                         PerlMemShared_free(trie->states);
8758                         PerlMemShared_free(trie->trans);
8759                         if (trie->bitmap)
8760                             PerlMemShared_free(trie->bitmap);
8761                         if (trie->wordlen)
8762                             PerlMemShared_free(trie->wordlen);
8763                         if (trie->jump)
8764                             PerlMemShared_free(trie->jump);
8765                         if (trie->nextword)
8766                             PerlMemShared_free(trie->nextword);
8767                         /* do this last!!!! */
8768                         PerlMemShared_free(ri->data->data[n]);
8769                     }
8770                 }
8771                 break;
8772             default:
8773                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
8774             }
8775         }
8776         Safefree(ri->data->what);
8777         Safefree(ri->data);
8778     }
8779     if (ri->swap) {
8780         Safefree(ri->swap->startp);
8781         Safefree(ri->swap->endp);
8782         Safefree(ri->swap);
8783     }
8784     Safefree(ri);
8785 }
8786
8787 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8788 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8789 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8790 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
8791
8792 /* 
8793    regdupe - duplicate a regexp. 
8794    
8795    This routine is called by sv.c's re_dup and is expected to clone a 
8796    given regexp structure. It is a no-op when not under USE_ITHREADS. 
8797    (Originally this *was* re_dup() for change history see sv.c)
8798    
8799    After all of the core data stored in struct regexp is duplicated
8800    the regexp_engine.dupe method is used to copy any private data
8801    stored in the *pprivate pointer. This allows extensions to handle
8802    any duplication it needs to do.
8803
8804    See pregfree() and regfree_internal() if you change anything here. 
8805 */
8806 #if defined(USE_ITHREADS)
8807 #ifndef PERL_IN_XSUB_RE
8808 regexp *
8809 Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param)
8810 {
8811     dVAR;
8812     regexp *ret;
8813     int i, npar;
8814     struct reg_substr_datum *s;
8815
8816     if (!r)
8817         return (REGEXP *)NULL;
8818
8819     if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8820         return ret;
8821
8822     
8823     npar = r->nparens+1;
8824     Newxz(ret, 1, regexp);
8825     Newx(ret->startp, npar, I32);
8826     Copy(r->startp, ret->startp, npar, I32);
8827     Newx(ret->endp, npar, I32);
8828     Copy(r->endp, ret->endp, npar, I32);
8829
8830     if (r->substrs) {
8831         Newx(ret->substrs, 1, struct reg_substr_data);
8832         for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8833             s->min_offset = r->substrs->data[i].min_offset;
8834             s->max_offset = r->substrs->data[i].max_offset;
8835             s->end_shift  = r->substrs->data[i].end_shift;
8836             s->substr     = sv_dup_inc(r->substrs->data[i].substr, param);
8837             s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
8838         }
8839     } else 
8840         ret->substrs = NULL;    
8841
8842     ret->wrapped        = SAVEPVN(r->wrapped, r->wraplen);
8843     ret->precomp        = ret->wrapped + (r->precomp - r->wrapped);
8844     ret->prelen         = r->prelen;
8845     ret->wraplen        = r->wraplen;
8846
8847     ret->refcnt         = r->refcnt;
8848     ret->minlen         = r->minlen;
8849     ret->minlenret      = r->minlenret;
8850     ret->nparens        = r->nparens;
8851     ret->lastparen      = r->lastparen;
8852     ret->lastcloseparen = r->lastcloseparen;
8853     ret->intflags       = r->intflags;
8854     ret->extflags       = r->extflags;
8855
8856     ret->sublen         = r->sublen;
8857
8858     ret->engine         = r->engine;
8859     
8860     ret->paren_names    = hv_dup_inc(r->paren_names, param);
8861
8862     if (RX_MATCH_COPIED(ret))
8863         ret->subbeg  = SAVEPVN(r->subbeg, r->sublen);
8864     else
8865         ret->subbeg = NULL;
8866 #ifdef PERL_OLD_COPY_ON_WRITE
8867     ret->saved_copy = NULL;
8868 #endif
8869     
8870     ret->pprivate = r->pprivate;
8871     if (ret->pprivate) 
8872         RXi_SET(ret,CALLREGDUPE_PVT(ret,param));
8873     
8874     ptr_table_store(PL_ptr_table, r, ret);
8875     return ret;
8876 }
8877 #endif /* PERL_IN_XSUB_RE */
8878
8879 /*
8880    regdupe_internal()
8881    
8882    This is the internal complement to regdupe() which is used to copy
8883    the structure pointed to by the *pprivate pointer in the regexp.
8884    This is the core version of the extension overridable cloning hook.
8885    The regexp structure being duplicated will be copied by perl prior
8886    to this and will be provided as the regexp *r argument, however 
8887    with the /old/ structures pprivate pointer value. Thus this routine
8888    may override any copying normally done by perl.
8889    
8890    It returns a pointer to the new regexp_internal structure.
8891 */
8892
8893 void *
8894 Perl_regdupe_internal(pTHX_ const regexp *r, CLONE_PARAMS *param)
8895 {
8896     dVAR;
8897     regexp_internal *reti;
8898     int len, npar;
8899     RXi_GET_DECL(r,ri);
8900     
8901     npar = r->nparens+1;
8902     len = ProgLen(ri);
8903     
8904     Newxc(reti, sizeof(regexp_internal) + (len+1)*sizeof(regnode), char, regexp_internal);
8905     Copy(ri->program, reti->program, len+1, regnode);
8906     
8907     if(ri->swap) {
8908         Newx(reti->swap, 1, regexp_paren_ofs);
8909         /* no need to copy these */
8910         Newx(reti->swap->startp, npar, I32);
8911         Newx(reti->swap->endp, npar, I32);
8912     } else {
8913         reti->swap = NULL;
8914     }
8915
8916     reti->regstclass = NULL;
8917
8918     if (ri->data) {
8919         struct reg_data *d;
8920         const int count = ri->data->count;
8921         int i;
8922
8923         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
8924                 char, struct reg_data);
8925         Newx(d->what, count, U8);
8926
8927         d->count = count;
8928         for (i = 0; i < count; i++) {
8929             d->what[i] = ri->data->what[i];
8930             switch (d->what[i]) {
8931                 /* legal options are one of: sSfpontTu
8932                    see also regcomp.h and pregfree() */
8933             case 's':
8934             case 'S':
8935             case 'p': /* actually an AV, but the dup function is identical.  */
8936             case 'u': /* actually an HV, but the dup function is identical.  */
8937                 d->data[i] = sv_dup_inc((SV *)ri->data->data[i], param);
8938                 break;
8939             case 'f':
8940                 /* This is cheating. */
8941                 Newx(d->data[i], 1, struct regnode_charclass_class);
8942                 StructCopy(ri->data->data[i], d->data[i],
8943                             struct regnode_charclass_class);
8944                 reti->regstclass = (regnode*)d->data[i];
8945                 break;
8946             case 'o':
8947                 /* Compiled op trees are readonly and in shared memory,
8948                    and can thus be shared without duplication. */
8949                 OP_REFCNT_LOCK;
8950                 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
8951                 OP_REFCNT_UNLOCK;
8952                 break;
8953             case 'T':
8954                 /* Trie stclasses are readonly and can thus be shared
8955                  * without duplication. We free the stclass in pregfree
8956                  * when the corresponding reg_ac_data struct is freed.
8957                  */
8958                 reti->regstclass= ri->regstclass;
8959                 /* Fall through */
8960             case 't':
8961                 OP_REFCNT_LOCK;
8962                 ((reg_trie_data*)ri->data->data[i])->refcount++;
8963                 OP_REFCNT_UNLOCK;
8964                 /* Fall through */
8965             case 'n':
8966                 d->data[i] = ri->data->data[i];
8967                 break;
8968             default:
8969                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
8970             }
8971         }
8972
8973         reti->data = d;
8974     }
8975     else
8976         reti->data = NULL;
8977
8978     reti->name_list_idx = ri->name_list_idx;
8979
8980 #ifdef RE_TRACK_PATTERN_OFFSETS
8981     if (ri->u.offsets) {
8982         Newx(reti->u.offsets, 2*len+1, U32);
8983         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
8984     }
8985 #else
8986     SetProgLen(reti,len);
8987 #endif
8988
8989     return (void*)reti;
8990 }
8991
8992 #endif    /* USE_ITHREADS */
8993
8994 /* 
8995    reg_stringify() 
8996    
8997    converts a regexp embedded in a MAGIC struct to its stringified form, 
8998    caching the converted form in the struct and returns the cached 
8999    string. 
9000
9001    If lp is nonnull then it is used to return the length of the 
9002    resulting string
9003    
9004    If flags is nonnull and the returned string contains UTF8 then 
9005    (*flags & 1) will be true.
9006    
9007    If haseval is nonnull then it is used to return whether the pattern 
9008    contains evals.
9009    
9010    Normally called via macro: 
9011    
9012         CALLREG_STRINGIFY(mg,&len,&utf8);
9013         
9014    And internally with
9015    
9016         CALLREG_AS_STR(mg,&lp,&flags,&haseval)        
9017     
9018    See sv_2pv_flags() in sv.c for an example of internal usage.
9019     
9020  */
9021 #ifndef PERL_IN_XSUB_RE
9022
9023 char *
9024 Perl_reg_stringify(pTHX_ MAGIC *mg, STRLEN *lp, U32 *flags, I32 *haseval ) {
9025     dVAR;
9026     const regexp * const re = (regexp *)mg->mg_obj;
9027     if (haseval) 
9028         *haseval = re->seen_evals;
9029     if (flags)    
9030         *flags = ((re->extflags & RXf_UTF8) ? 1 : 0);
9031     if (lp)
9032         *lp = re->wraplen;
9033     return re->wrapped;
9034 }
9035
9036 /*
9037  - regnext - dig the "next" pointer out of a node
9038  */
9039 regnode *
9040 Perl_regnext(pTHX_ register regnode *p)
9041 {
9042     dVAR;
9043     register I32 offset;
9044
9045     if (!p)
9046         return(NULL);
9047
9048     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
9049     if (offset == 0)
9050         return(NULL);
9051
9052     return(p+offset);
9053 }
9054 #endif
9055
9056 STATIC void     
9057 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
9058 {
9059     va_list args;
9060     STRLEN l1 = strlen(pat1);
9061     STRLEN l2 = strlen(pat2);
9062     char buf[512];
9063     SV *msv;
9064     const char *message;
9065
9066     if (l1 > 510)
9067         l1 = 510;
9068     if (l1 + l2 > 510)
9069         l2 = 510 - l1;
9070     Copy(pat1, buf, l1 , char);
9071     Copy(pat2, buf + l1, l2 , char);
9072     buf[l1 + l2] = '\n';
9073     buf[l1 + l2 + 1] = '\0';
9074 #ifdef I_STDARG
9075     /* ANSI variant takes additional second argument */
9076     va_start(args, pat2);
9077 #else
9078     va_start(args);
9079 #endif
9080     msv = vmess(buf, &args);
9081     va_end(args);
9082     message = SvPV_const(msv,l1);
9083     if (l1 > 512)
9084         l1 = 512;
9085     Copy(message, buf, l1 , char);
9086     buf[l1-1] = '\0';                   /* Overwrite \n */
9087     Perl_croak(aTHX_ "%s", buf);
9088 }
9089
9090 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
9091
9092 #ifndef PERL_IN_XSUB_RE
9093 void
9094 Perl_save_re_context(pTHX)
9095 {
9096     dVAR;
9097
9098     struct re_save_state *state;
9099
9100     SAVEVPTR(PL_curcop);
9101     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
9102
9103     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
9104     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
9105     SSPUSHINT(SAVEt_RE_STATE);
9106
9107     Copy(&PL_reg_state, state, 1, struct re_save_state);
9108
9109     PL_reg_start_tmp = 0;
9110     PL_reg_start_tmpl = 0;
9111     PL_reg_oldsaved = NULL;
9112     PL_reg_oldsavedlen = 0;
9113     PL_reg_maxiter = 0;
9114     PL_reg_leftiter = 0;
9115     PL_reg_poscache = NULL;
9116     PL_reg_poscache_size = 0;
9117 #ifdef PERL_OLD_COPY_ON_WRITE
9118     PL_nrs = NULL;
9119 #endif
9120
9121     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
9122     if (PL_curpm) {
9123         const REGEXP * const rx = PM_GETRE(PL_curpm);
9124         if (rx) {
9125             U32 i;
9126             for (i = 1; i <= rx->nparens; i++) {
9127                 char digits[TYPE_CHARS(long)];
9128                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
9129                 GV *const *const gvp
9130                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
9131
9132                 if (gvp) {
9133                     GV * const gv = *gvp;
9134                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
9135                         save_scalar(gv);
9136                 }
9137             }
9138         }
9139     }
9140 }
9141 #endif
9142
9143 static void
9144 clear_re(pTHX_ void *r)
9145 {
9146     dVAR;
9147     ReREFCNT_dec((regexp *)r);
9148 }
9149
9150 #ifdef DEBUGGING
9151
9152 STATIC void
9153 S_put_byte(pTHX_ SV *sv, int c)
9154 {
9155     if (isCNTRL(c) || c == 255 || !isPRINT(c))
9156         Perl_sv_catpvf(aTHX_ sv, "\\%o", c);
9157     else if (c == '-' || c == ']' || c == '\\' || c == '^')
9158         Perl_sv_catpvf(aTHX_ sv, "\\%c", c);
9159     else
9160         Perl_sv_catpvf(aTHX_ sv, "%c", c);
9161 }
9162
9163
9164 #define CLEAR_OPTSTART \
9165     if (optstart) STMT_START { \
9166             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
9167             optstart=NULL; \
9168     } STMT_END
9169
9170 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
9171
9172 STATIC const regnode *
9173 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
9174             const regnode *last, const regnode *plast, 
9175             SV* sv, I32 indent, U32 depth)
9176 {
9177     dVAR;
9178     register U8 op = PSEUDO;    /* Arbitrary non-END op. */
9179     register const regnode *next;
9180     const regnode *optstart= NULL;
9181     
9182     RXi_GET_DECL(r,ri);
9183     GET_RE_DEBUG_FLAGS_DECL;
9184     
9185 #ifdef DEBUG_DUMPUNTIL
9186     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
9187         last ? last-start : 0,plast ? plast-start : 0);
9188 #endif
9189             
9190     if (plast && plast < last) 
9191         last= plast;
9192
9193     while (PL_regkind[op] != END && (!last || node < last)) {
9194         /* While that wasn't END last time... */
9195         NODE_ALIGN(node);
9196         op = OP(node);
9197         if (op == CLOSE || op == WHILEM)
9198             indent--;
9199         next = regnext((regnode *)node);
9200
9201         /* Where, what. */
9202         if (OP(node) == OPTIMIZED) {
9203             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
9204                 optstart = node;
9205             else
9206                 goto after_print;
9207         } else
9208             CLEAR_OPTSTART;
9209         
9210         regprop(r, sv, node);
9211         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
9212                       (int)(2*indent + 1), "", SvPVX_const(sv));
9213         
9214         if (OP(node) != OPTIMIZED) {                  
9215             if (next == NULL)           /* Next ptr. */
9216                 PerlIO_printf(Perl_debug_log, " (0)");
9217             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
9218                 PerlIO_printf(Perl_debug_log, " (FAIL)");
9219             else 
9220                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
9221             (void)PerlIO_putc(Perl_debug_log, '\n'); 
9222         }
9223         
9224       after_print:
9225         if (PL_regkind[(U8)op] == BRANCHJ) {
9226             assert(next);
9227             {
9228                 register const regnode *nnode = (OP(next) == LONGJMP
9229                                              ? regnext((regnode *)next)
9230                                              : next);
9231                 if (last && nnode > last)
9232                     nnode = last;
9233                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
9234             }
9235         }
9236         else if (PL_regkind[(U8)op] == BRANCH) {
9237             assert(next);
9238             DUMPUNTIL(NEXTOPER(node), next);
9239         }
9240         else if ( PL_regkind[(U8)op]  == TRIE ) {
9241             const regnode *this_trie = node;
9242             const char op = OP(node);
9243             const U32 n = ARG(node);
9244             const reg_ac_data * const ac = op>=AHOCORASICK ?
9245                (reg_ac_data *)ri->data->data[n] :
9246                NULL;
9247             const reg_trie_data * const trie =
9248                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
9249 #ifdef DEBUGGING
9250             AV *const trie_words = (AV *) ri->data->data[n + TRIE_WORDS_OFFSET];
9251 #endif
9252             const regnode *nextbranch= NULL;
9253             I32 word_idx;
9254             sv_setpvn(sv, "", 0);
9255             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
9256                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
9257                 
9258                 PerlIO_printf(Perl_debug_log, "%*s%s ",
9259                    (int)(2*(indent+3)), "",
9260                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
9261                             PL_colors[0], PL_colors[1],
9262                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
9263                             PERL_PV_PRETTY_ELIPSES    |
9264                             PERL_PV_PRETTY_LTGT
9265                             )
9266                             : "???"
9267                 );
9268                 if (trie->jump) {
9269                     U16 dist= trie->jump[word_idx+1];
9270                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
9271                                   (UV)((dist ? this_trie + dist : next) - start));
9272                     if (dist) {
9273                         if (!nextbranch)
9274                             nextbranch= this_trie + trie->jump[0];    
9275                         DUMPUNTIL(this_trie + dist, nextbranch);
9276                     }
9277                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
9278                         nextbranch= regnext((regnode *)nextbranch);
9279                 } else {
9280                     PerlIO_printf(Perl_debug_log, "\n");
9281                 }
9282             }
9283             if (last && next > last)
9284                 node= last;
9285             else
9286                 node= next;
9287         }
9288         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
9289             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
9290                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
9291         }
9292         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
9293             assert(next);
9294             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
9295         }
9296         else if ( op == PLUS || op == STAR) {
9297             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
9298         }
9299         else if (op == ANYOF) {
9300             /* arglen 1 + class block */
9301             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_LARGE)
9302                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
9303             node = NEXTOPER(node);
9304         }
9305         else if (PL_regkind[(U8)op] == EXACT) {
9306             /* Literal string, where present. */
9307             node += NODE_SZ_STR(node) - 1;
9308             node = NEXTOPER(node);
9309         }
9310         else {
9311             node = NEXTOPER(node);
9312             node += regarglen[(U8)op];
9313         }
9314         if (op == CURLYX || op == OPEN)
9315             indent++;
9316     }
9317     CLEAR_OPTSTART;
9318 #ifdef DEBUG_DUMPUNTIL    
9319     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
9320 #endif
9321     return node;
9322 }
9323
9324 #endif  /* DEBUGGING */
9325
9326 /*
9327  * Local variables:
9328  * c-indentation-style: bsd
9329  * c-basic-offset: 4
9330  * indent-tabs-mode: t
9331  * End:
9332  *
9333  * ex: set ts=8 sts=4 sw=4 noet:
9334  */