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